source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137       if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334 c      print *," Processor",myrank," left SUM_ENERGY"
 335 #ifdef TIMING
 336 #ifdef MPI
 337       time_sumene=time_sumene+MPI_Wtime()-time00
 338 #else
 339       time_sumene=time_sumene+tcpu()-time00
 340 #endif
 341 #endif
 342       return
 343       end
 344 c-------------------------------------------------------------------------------
 345       subroutine sum_energy(energia,reduce)
 346       implicit real*8 (a-h,o-z)
 347       include 'DIMENSIONS'
 348 #ifndef ISNAN
 349       external proc_proc
 350 #ifdef WINPGI
 351 cMS$ATTRIBUTES C ::  proc_proc
 352 #endif
 353 #endif
 354 #ifdef MPI
 355       include "mpif.h"
 356 #endif
 357       include 'COMMON.SETUP'
 358       include 'COMMON.IOUNITS'
 359       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.SBRIDGE'
 364       include 'COMMON.CHAIN'
 365       include 'COMMON.VAR'
 366       include 'COMMON.CONTROL'
 367       include 'COMMON.TIME1'
 368       logical reduce
 369 #ifdef MPI
 370       if (nfgtasks.gt.1 .and. reduce) then
 371 #ifdef DEBUG
 372         write (iout,*) "energies before REDUCE"
 373         call enerprint(energia)
 374         call flush(iout)
 375 #endif
 376         do i=0,n_ene
 377           enebuff(i)=energia(i)
 378         enddo
 379         time00=MPI_Wtime()
 380         call MPI_Barrier(FG_COMM,IERR)
 381         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 382         time00=MPI_Wtime()
 383         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 385 #ifdef DEBUG
 386         write (iout,*) "energies after REDUCE"
 387         call enerprint(energia)
 388         call flush(iout)
 389 #endif
 390         time_Reduce=time_Reduce+MPI_Wtime()-time00
 391       endif
 392       if (fg_rank.eq.0) then
 393 #endif
 394 #ifdef TSCSC
 395       evdw=energia(22)+wsct*energia(23)
 396 #else
 397       evdw=energia(1)
 398 #endif
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435 #else
 436       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 437      & +wang*ebe+wtor*etors+wscloc*escloc
 438      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 439      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 440      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 441      & +wbond*estr+Uconst+wsccor*esccor
 442 #endif
 443       energia(0)=etot
 444 c detecting NaNQ
 445 #ifdef ISNAN
 446 #ifdef AIX
 447       if (isnan(etot).ne.0) energia(0)=1.0d+99
 448 #else
 449       if (isnan(etot)) energia(0)=1.0d+99
 450 #endif
 451 #else
 452       i=0
 453 #ifdef WINPGI
 454       idumm=proc_proc(etot,i)
 455 #else
 456       call proc_proc(etot,i)
 457 #endif
 458       if(i.eq.1)energia(0)=1.0d+99
 459 #endif
 460 #ifdef MPI
 461       endif
 462 #endif
 463       return
 464       end
 465 c-------------------------------------------------------------------------------
 466       subroutine sum_gradient
 467       implicit real*8 (a-h,o-z)
 468       include 'DIMENSIONS'
 469 #ifndef ISNAN
 470       external proc_proc
 471 #ifdef WINPGI
 472 cMS$ATTRIBUTES C ::  proc_proc
 473 #endif
 474 #endif
 475 #ifdef MPI
 476       include 'mpif.h'
 477 #endif
 478       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 479      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 480       include 'COMMON.SETUP'
 481       include 'COMMON.IOUNITS'
 482       include 'COMMON.FFIELD'
 483       include 'COMMON.DERIV'
 484       include 'COMMON.INTERACT'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CHAIN'
 487       include 'COMMON.VAR'
 488       include 'COMMON.CONTROL'
 489       include 'COMMON.TIME1'
 490       include 'COMMON.MAXGRAD'
 491       include 'COMMON.SCCOR'
 492 #ifdef TIMING
 493 #ifdef MPI
 494       time01=MPI_Wtime()
 495 #else
 496       time01=tcpu()
 497 #endif
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 504      &   (gvdwcT(j,i),j=1,3)
 505       enddo
 506       call flush(iout)
 507 #endif
 508 #ifdef MPI
 509 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 510         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 511      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 512 #endif
 513 C
 514 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 515 C            in virtual-bond-vector coordinates
 516 C
 517 #ifdef DEBUG
 518 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 521 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 522 c      enddo
 523 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 524 c      do i=1,nres-1
 525 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 526 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 527 c      enddo
 528       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 529       do i=1,nres
 530         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 531      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 532      &   g_corr5_loc(i)
 533       enddo
 534       call flush(iout)
 535 #endif
 536 #ifdef SPLITELE
 537 #ifdef TSCSC
 538       do i=1,nct
 539         do j=1,3
 540           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 541      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 542      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 543      &                wel_loc*gel_loc_long(j,i)+
 544      &                wcorr*gradcorr_long(j,i)+
 545      &                wcorr5*gradcorr5_long(j,i)+
 546      &                wcorr6*gradcorr6_long(j,i)+
 547      &                wturn6*gcorr6_turn_long(j,i)+
 548      &                wstrain*ghpbc(j,i)
 549         enddo
 550       enddo
 551 #else
 552       do i=1,nct
 553         do j=1,3
 554           gradbufc(j,i)=wsc*gvdwc(j,i)+
 555      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 556      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 557      &                wel_loc*gel_loc_long(j,i)+
 558      &                wcorr*gradcorr_long(j,i)+
 559      &                wcorr5*gradcorr5_long(j,i)+
 560      &                wcorr6*gradcorr6_long(j,i)+
 561      &                wturn6*gcorr6_turn_long(j,i)+
 562      &                wstrain*ghpbc(j,i)
 563         enddo
 564       enddo
 565 #endif
 566 #else
 567       do i=1,nct
 568         do j=1,3
 569           gradbufc(j,i)=wsc*gvdwc(j,i)+
 570      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 571      &                welec*gelc_long(j,i)+
 572      &                wbond*gradb(j,i)+
 573      &                wel_loc*gel_loc_long(j,i)+
 574      &                wcorr*gradcorr_long(j,i)+
 575      &                wcorr5*gradcorr5_long(j,i)+
 576      &                wcorr6*gradcorr6_long(j,i)+
 577      &                wturn6*gcorr6_turn_long(j,i)+
 578      &                wstrain*ghpbc(j,i)
 579         enddo
 580       enddo
 581 #endif
 582 #ifdef MPI
 583       if (nfgtasks.gt.1) then
 584       time00=MPI_Wtime()
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc before allreduce"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       do i=1,nres
 593         do j=1,3
 594           gradbufc_sum(j,i)=gradbufc(j,i)
 595         enddo
 596       enddo
 597 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 598 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 599 c      time_reduce=time_reduce+MPI_Wtime()-time00
 600 #ifdef DEBUG
 601 c      write (iout,*) "gradbufc_sum after allreduce"
 602 c      do i=1,nres
 603 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 604 c      enddo
 605 c      call flush(iout)
 606 #endif
 607 #ifdef TIMING
 608 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 609 #endif
 610       do i=nnt,nres
 611         do k=1,3
 612           gradbufc(k,i)=0.0d0
 613         enddo
 614       enddo
 615 #ifdef DEBUG
 616       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 617       write (iout,*) (i," jgrad_start",jgrad_start(i),
 618      &                  " jgrad_end  ",jgrad_end(i),
 619      &                  i=igrad_start,igrad_end)
 620 #endif
 621 c
 622 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 623 c do not parallelize this part.
 624 c
 625 c      do i=igrad_start,igrad_end
 626 c        do j=jgrad_start(i),jgrad_end(i)
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632       do j=1,3
 633         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 634       enddo
 635       do i=nres-2,nnt,-1
 636         do j=1,3
 637           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc after summing"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       else
 648 #endif
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       do i=1,nres
 657         do j=1,3
 658           gradbufc_sum(j,i)=gradbufc(j,i)
 659           gradbufc(j,i)=0.0d0
 660         enddo
 661       enddo
 662       do j=1,3
 663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 664       enddo
 665       do i=nres-2,nnt,-1
 666         do j=1,3
 667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 668         enddo
 669       enddo
 670 c      do i=nnt,nres-1
 671 c        do k=1,3
 672 c          gradbufc(k,i)=0.0d0
 673 c        enddo
 674 c        do j=i+1,nres
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gradbufc after summing"
 682       do i=1,nres
 683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688       endif
 689 #endif
 690       do k=1,3
 691         gradbufc(k,nres)=0.0d0
 692       enddo
 693       do i=1,nct
 694         do j=1,3
 695 #ifdef SPLITELE
 696           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 697      &                wel_loc*gel_loc(j,i)+
 698      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 699      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 700      &                wel_loc*gel_loc_long(j,i)+
 701      &                wcorr*gradcorr_long(j,i)+
 702      &                wcorr5*gradcorr5_long(j,i)+
 703      &                wcorr6*gradcorr6_long(j,i)+
 704      &                wturn6*gcorr6_turn_long(j,i))+
 705      &                wbond*gradb(j,i)+
 706      &                wcorr*gradcorr(j,i)+
 707      &                wturn3*gcorr3_turn(j,i)+
 708      &                wturn4*gcorr4_turn(j,i)+
 709      &                wcorr5*gradcorr5(j,i)+
 710      &                wcorr6*gradcorr6(j,i)+
 711      &                wturn6*gcorr6_turn(j,i)+
 712      &                wsccor*gsccorc(j,i)
 713      &               +wscloc*gscloc(j,i)
 714 #else
 715           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 716      &                wel_loc*gel_loc(j,i)+
 717      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 718      &                welec*gelc_long(j,i)+
 719      &                wel_loc*gel_loc_long(j,i)+
 720      &                wcorr*gcorr_long(j,i)+
 721      &                wcorr5*gradcorr5_long(j,i)+
 722      &                wcorr6*gradcorr6_long(j,i)+
 723      &                wturn6*gcorr6_turn_long(j,i))+
 724      &                wbond*gradb(j,i)+
 725      &                wcorr*gradcorr(j,i)+
 726      &                wturn3*gcorr3_turn(j,i)+
 727      &                wturn4*gcorr4_turn(j,i)+
 728      &                wcorr5*gradcorr5(j,i)+
 729      &                wcorr6*gradcorr6(j,i)+
 730      &                wturn6*gcorr6_turn(j,i)+
 731      &                wsccor*gsccorc(j,i)
 732      &               +wscloc*gscloc(j,i)
 733 #endif
 734 #ifdef TSCSC
 735           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 736      &                  wscp*gradx_scp(j,i)+
 737      &                  wbond*gradbx(j,i)+
 738      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 739      &                  wsccor*gsccorx(j,i)
 740      &                 +wscloc*gsclocx(j,i)
 741 #else
 742           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 743      &                  wbond*gradbx(j,i)+
 744      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 745      &                  wsccor*gsccorx(j,i)
 746      &                 +wscloc*gsclocx(j,i)
 747 #endif
 748         enddo
 749       enddo
 750 #ifdef DEBUG
 751       write (iout,*) "gloc before adding corr"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       do i=1,nres-3
 757         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 758      &   +wcorr5*g_corr5_loc(i)
 759      &   +wcorr6*g_corr6_loc(i)
 760      &   +wturn4*gel_loc_turn4(i)
 761      &   +wturn3*gel_loc_turn3(i)
 762      &   +wturn6*gel_loc_turn6(i)
 763      &   +wel_loc*gel_loc_loc(i)
 764       enddo
 765 #ifdef DEBUG
 766       write (iout,*) "gloc after adding corr"
 767       do i=1,4*nres
 768         write (iout,*) i,gloc(i,icg)
 769       enddo
 770 #endif
 771 #ifdef MPI
 772       if (nfgtasks.gt.1) then
 773         do j=1,3
 774           do i=1,nres
 775             gradbufc(j,i)=gradc(j,i,icg)
 776             gradbufx(j,i)=gradx(j,i,icg)
 777           enddo
 778         enddo
 779         do i=1,4*nres
 780           glocbuf(i)=gloc(i,icg)
 781         enddo
 782 #ifdef DEBUG
 783       write (iout,*) "gloc_sc before reduce"
 784       do i=1,nres
 785        do j=1,3
 786         write (iout,*) i,j,gloc_sc(j,i,icg)
 787        enddo
 788       enddo
 789 #endif
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         time_reduce=time_reduce+MPI_Wtime()-time00
 808 #ifdef DEBUG
 809       write (iout,*) "gloc_sc after reduce"
 810       do i=1,nres
 811        do j=1,3
 812         write (iout,*) i,j,gloc_sc(j,i,icg)
 813        enddo
 814       enddo
 815 #endif
 816 #ifdef DEBUG
 817       write (iout,*) "gloc after reduce"
 818       do i=1,4*nres
 819         write (iout,*) i,gloc(i,icg)
 820       enddo
 821 #endif
 822       endif
 823 #endif
 824       if (gnorm_check) then
 825 c
 826 c Compute the maximum elements of the gradient
 827 c
 828       gvdwc_max=0.0d0
 829       gvdwc_scp_max=0.0d0
 830       gelc_max=0.0d0
 831       gvdwpp_max=0.0d0
 832       gradb_max=0.0d0
 833       ghpbc_max=0.0d0
 834       gradcorr_max=0.0d0
 835       gel_loc_max=0.0d0
 836       gcorr3_turn_max=0.0d0
 837       gcorr4_turn_max=0.0d0
 838       gradcorr5_max=0.0d0
 839       gradcorr6_max=0.0d0
 840       gcorr6_turn_max=0.0d0
 841       gsccorc_max=0.0d0
 842       gscloc_max=0.0d0
 843       gvdwx_max=0.0d0
 844       gradx_scp_max=0.0d0
 845       ghpbx_max=0.0d0
 846       gradxorr_max=0.0d0
 847       gsccorx_max=0.0d0
 848       gsclocx_max=0.0d0
 849       do i=1,nct
 850         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 851         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 852 #ifdef TSCSC
 853         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855 #endif
 856         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 857         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 858      &   gvdwc_scp_max=gvdwc_scp_norm
 859         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 860         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 861         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 862         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 863         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 864         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 865         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 866         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 867         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 868         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 869         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 870         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 871         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 872      &    gcorr3_turn(1,i)))
 873         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 874      &    gcorr3_turn_max=gcorr3_turn_norm
 875         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 876      &    gcorr4_turn(1,i)))
 877         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 878      &    gcorr4_turn_max=gcorr4_turn_norm
 879         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 880         if (gradcorr5_norm.gt.gradcorr5_max)
 881      &    gradcorr5_max=gradcorr5_norm
 882         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 883         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 884         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 885      &    gcorr6_turn(1,i)))
 886         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 887      &    gcorr6_turn_max=gcorr6_turn_norm
 888         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 889         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 890         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 891         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 892         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 893         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 894 #ifdef TSCSC
 895         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 896         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 897 #endif
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942 #ifdef MPI
 943       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 944 #else
 945       time_sumgradient=time_sumgradient+tcpu()-time01
 946 #endif
 947 #endif
 948       return
 949       end
 950 c-------------------------------------------------------------------------------
 951       subroutine rescale_weights(t_bath)
 952       implicit real*8 (a-h,o-z)
 953       include 'DIMENSIONS'
 954       include 'COMMON.IOUNITS'
 955       include 'COMMON.FFIELD'
 956       include 'COMMON.SBRIDGE'
 957       double precision kfac /2.4d0/
 958       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 959 c      facT=temp0/t_bath
 960 c      facT=2*temp0/(t_bath+temp0)
 961       if (rescale_mode.eq.0) then
 962         facT=1.0d0
 963         facT2=1.0d0
 964         facT3=1.0d0
 965         facT4=1.0d0
 966         facT5=1.0d0
 967       else if (rescale_mode.eq.1) then
 968         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 969         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 970         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 971         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 972         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 973       else if (rescale_mode.eq.2) then
 974         x=t_bath/temp0
 975         x2=x*x
 976         x3=x2*x
 977         x4=x3*x
 978         x5=x4*x
 979         facT=licznik/dlog(dexp(x)+dexp(-x))
 980         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 981         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 982         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 983         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 984       else
 985         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 986         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 987 #ifdef MPI
 988        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 989 #endif
 990        stop 555
 991       endif
 992       welec=weights(3)*fact
 993       wcorr=weights(4)*fact3
 994       wcorr5=weights(5)*fact4
 995       wcorr6=weights(6)*fact5
 996       wel_loc=weights(7)*fact2
 997       wturn3=weights(8)*fact2
 998       wturn4=weights(9)*fact3
 999       wturn6=weights(10)*fact5
1000       wtor=weights(13)*fact
1001       wtor_d=weights(14)*fact2
1002       wsccor=weights(21)*fact
1003 #ifdef TSCSC
1004 c      wsct=t_bath/temp0
1005       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1006 #endif
1007       return
1008       end
1009 C------------------------------------------------------------------------
1010       subroutine enerprint(energia)
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       include 'COMMON.IOUNITS'
1014       include 'COMMON.FFIELD'
1015       include 'COMMON.SBRIDGE'
1016       include 'COMMON.MD'
1017       double precision energia(0:n_ene)
1018       etot=energia(0)
1019 #ifdef TSCSC
1020       evdw=energia(22)+wsct*energia(23)
1021 #else
1022       evdw=energia(1)
1023 #endif
1024       evdw2=energia(2)
1025 #ifdef SCP14
1026       evdw2=energia(2)+energia(18)
1027 #else
1028       evdw2=energia(2)
1029 #endif
1030       ees=energia(3)
1031 #ifdef SPLITELE
1032       evdw1=energia(16)
1033 #endif
1034       ecorr=energia(4)
1035       ecorr5=energia(5)
1036       ecorr6=energia(6)
1037       eel_loc=energia(7)
1038       eello_turn3=energia(8)
1039       eello_turn4=energia(9)
1040       eello_turn6=energia(10)
1041       ebe=energia(11)
1042       escloc=energia(12)
1043       etors=energia(13)
1044       etors_d=energia(14)
1045       ehpb=energia(15)
1046       edihcnstr=energia(19)
1047       estr=energia(17)
1048       Uconst=energia(20)
1049       esccor=energia(21)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1052      &  estr,wbond,ebe,wang,
1053      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1054      &  ecorr,wcorr,
1055      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1056      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1057      &  edihcnstr,ebr*nss,
1058      &  Uconst,etot
1059    10 format (/'Virtual-chain energies:'//
1060      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1061      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1062      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1063      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1064      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1065      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1066      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1067      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1068      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1069      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1070      & ' (SS bridges & dist. cnstr.)'/
1071      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1072      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1075      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1076      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1077      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1078      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1079      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1080      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1081      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1082      & 'ETOT=  ',1pE16.6,' (total)')
1083 #else
1084       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1085      &  estr,wbond,ebe,wang,
1086      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1087      &  ecorr,wcorr,
1088      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1089      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1090      &  ebr*nss,Uconst,etot
1091    10 format (/'Virtual-chain energies:'//
1092      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1093      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1094      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1095      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1096      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1097      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1098      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1099      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1100      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1101      & ' (SS bridges & dist. cnstr.)'/
1102      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1106      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1107      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1108      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1109      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1110      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1111      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1112      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw,evdw_p,evdw_m)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=itype(i)
1142         itypi1=itype(i+1)
1143         xi=c(1,nres+i)
1144         yi=c(2,nres+i)
1145         zi=c(3,nres+i)
1146 C Change 12/1/95
1147         num_conti=0
1148 C
1149 C Calculate SC interaction energy.
1150 C
1151         do iint=1,nint_gr(i)
1152 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1153 cd   &                  'iend=',iend(i,iint)
1154           do j=istart(i,iint),iend(i,iint)
1155             itypj=itype(j)
1156             xj=c(1,nres+j)-xi
1157             yj=c(2,nres+j)-yi
1158             zj=c(3,nres+j)-zi
1159 C Change 12/1/95 to calculate four-body interactions
1160             rij=xj*xj+yj*yj+zj*zj
1161             rrij=1.0D0/rij
1162 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1163             eps0ij=eps(itypi,itypj)
1164             fac=rrij**expon2
1165             e1=fac*fac*aa(itypi,itypj)
1166             e2=fac*bb(itypi,itypj)
1167             evdwij=e1+e2
1168 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1169 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1170 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1171 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1172 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1173 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1174 #ifdef TSCSC
1175             if (bb(itypi,itypj).gt.0) then
1176                evdw_p=evdw_p+evdwij
1177             else
1178                evdw_m=evdw_m+evdwij
1179             endif
1180 #else
1181             evdw=evdw+evdwij
1182 #endif
1183 C
1184 C Calculate the components of the gradient in DC and X
1185 C
1186             fac=-rrij*(e1+evdwij)
1187             gg(1)=xj*fac
1188             gg(2)=yj*fac
1189             gg(3)=zj*fac
1190 #ifdef TSCSC
1191             if (bb(itypi,itypj).gt.0.0d0) then
1192               do k=1,3
1193                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1194                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1196                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1197               enddo
1198             else
1199               do k=1,3
1200                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1201                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1202                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1203                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1204               enddo
1205             endif
1206 #else
1207             do k=1,3
1208               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1209               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1210               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1211               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1212             enddo
1213 #endif
1214 cgrad            do k=i,j-1
1215 cgrad              do l=1,3
1216 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1217 cgrad              enddo
1218 cgrad            enddo
1219 C
1220 C 12/1/95, revised on 5/20/97
1221 C
1222 C Calculate the contact function. The ith column of the array JCONT will
1223 C contain the numbers of atoms that make contacts with the atom I (of numbers
1224 C greater than I). The arrays FACONT and GACONT will contain the values of
1225 C the contact function and its derivative.
1226 C
1227 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1228 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1229 C Uncomment next line, if the correlation interactions are contact function only
1230             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1231               rij=dsqrt(rij)
1232               sigij=sigma(itypi,itypj)
1233               r0ij=rs0(itypi,itypj)
1234 C
1235 C Check whether the SC's are not too far to make a contact.
1236 C
1237               rcut=1.5d0*r0ij
1238               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1239 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1240 C
1241               if (fcont.gt.0.0D0) then
1242 C If the SC-SC distance if close to sigma, apply spline.
1243 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1244 cAdam &             fcont1,fprimcont1)
1245 cAdam           fcont1=1.0d0-fcont1
1246 cAdam           if (fcont1.gt.0.0d0) then
1247 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1248 cAdam             fcont=fcont*fcont1
1249 cAdam           endif
1250 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1251 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1252 cga             do k=1,3
1253 cga               gg(k)=gg(k)*eps0ij
1254 cga             enddo
1255 cga             eps0ij=-evdwij*eps0ij
1256 C Uncomment for AL's type of SC correlation interactions.
1257 cadam           eps0ij=-evdwij
1258                 num_conti=num_conti+1
1259                 jcont(num_conti,i)=j
1260                 facont(num_conti,i)=fcont*eps0ij
1261                 fprimcont=eps0ij*fprimcont/rij
1262                 fcont=expon*fcont
1263 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1264 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1265 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1266 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1267                 gacont(1,num_conti,i)=-fprimcont*xj
1268                 gacont(2,num_conti,i)=-fprimcont*yj
1269                 gacont(3,num_conti,i)=-fprimcont*zj
1270 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1271 cd              write (iout,'(2i3,3f10.5)')
1272 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1273               endif
1274             endif
1275           enddo      ! j
1276         enddo        ! iint
1277 C Change 12/1/95
1278         num_cont(i)=num_conti
1279       enddo          ! i
1280       do i=1,nct
1281         do j=1,3
1282           gvdwc(j,i)=expon*gvdwc(j,i)
1283           gvdwx(j,i)=expon*gvdwx(j,i)
1284         enddo
1285       enddo
1286 C******************************************************************************
1287 C
1288 C                              N O T E !!!
1289 C
1290 C To save time, the factor of EXPON has been extracted from ALL components
1291 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1292 C use!
1293 C
1294 C******************************************************************************
1295       return
1296       end
1297 C-----------------------------------------------------------------------------
1298       subroutine eljk(evdw,evdw_p,evdw_m)
1299 C
1300 C This subroutine calculates the interaction energy of nonbonded side chains
1301 C assuming the LJK potential of interaction.
1302 C
1303       implicit real*8 (a-h,o-z)
1304       include 'DIMENSIONS'
1305       include 'COMMON.GEO'
1306       include 'COMMON.VAR'
1307       include 'COMMON.LOCAL'
1308       include 'COMMON.CHAIN'
1309       include 'COMMON.DERIV'
1310       include 'COMMON.INTERACT'
1311       include 'COMMON.IOUNITS'
1312       include 'COMMON.NAMES'
1313       dimension gg(3)
1314       logical scheck
1315 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1316       evdw=0.0D0
1317       do i=iatsc_s,iatsc_e
1318         itypi=itype(i)
1319         itypi1=itype(i+1)
1320         xi=c(1,nres+i)
1321         yi=c(2,nres+i)
1322         zi=c(3,nres+i)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             itypj=itype(j)
1329             xj=c(1,nres+j)-xi
1330             yj=c(2,nres+j)-yi
1331             zj=c(3,nres+j)-zi
1332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1333             fac_augm=rrij**expon
1334             e_augm=augm(itypi,itypj)*fac_augm
1335             r_inv_ij=dsqrt(rrij)
1336             rij=1.0D0/r_inv_ij
1337             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1338             fac=r_shift_inv**expon
1339             e1=fac*fac*aa(itypi,itypj)
1340             e2=fac*bb(itypi,itypj)
1341             evdwij=e_augm+e1+e2
1342 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1343 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1344 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1345 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1346 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1347 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1348 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1349 #ifdef TSCSC
1350             if (bb(itypi,itypj).gt.0) then
1351                evdw_p=evdw_p+evdwij
1352             else
1353                evdw_m=evdw_m+evdwij
1354             endif
1355 #else
1356             evdw=evdw+evdwij
1357 #endif
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365 #ifdef TSCSC
1366             if (bb(itypi,itypj).gt.0.0d0) then
1367               do k=1,3
1368                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1369                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1370                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1371                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1372               enddo
1373             else
1374               do k=1,3
1375                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1376                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1377                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1378                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1379               enddo
1380             endif
1381 #else
1382             do k=1,3
1383               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1384               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1385               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1386               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1387             enddo
1388 #endif
1389 cgrad            do k=i,j-1
1390 cgrad              do l=1,3
1391 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1392 cgrad              enddo
1393 cgrad            enddo
1394           enddo      ! j
1395         enddo        ! iint
1396       enddo          ! i
1397       do i=1,nct
1398         do j=1,3
1399           gvdwc(j,i)=expon*gvdwc(j,i)
1400           gvdwx(j,i)=expon*gvdwx(j,i)
1401         enddo
1402       enddo
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine ebp(evdw,evdw_p,evdw_m)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Berne-Pechukas potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       common /srutu/ icall
1423 c     double precision rrsave(maxdim)
1424       logical lprn
1425       evdw=0.0D0
1426 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1427       evdw=0.0D0
1428 c     if (icall.eq.0) then
1429 c       lprn=.true.
1430 c     else
1431         lprn=.false.
1432 c     endif
1433       ind=0
1434       do i=iatsc_s,iatsc_e
1435         itypi=itype(i)
1436         itypi1=itype(i+1)
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 C
1446 C Calculate SC interaction energy.
1447 C
1448         do iint=1,nint_gr(i)
1449           do j=istart(i,iint),iend(i,iint)
1450             ind=ind+1
1451             itypj=itype(j)
1452 c            dscj_inv=dsc_inv(itypj)
1453             dscj_inv=vbld_inv(j+nres)
1454             chi1=chi(itypi,itypj)
1455             chi2=chi(itypj,itypi)
1456             chi12=chi1*chi2
1457             chip1=chip(itypi)
1458             chip2=chip(itypj)
1459             chip12=chip1*chip2
1460             alf1=alp(itypi)
1461             alf2=alp(itypj)
1462             alf12=0.5D0*(alf1+alf2)
1463 C For diagnostics only!!!
1464 c           chi1=0.0D0
1465 c           chi2=0.0D0
1466 c           chi12=0.0D0
1467 c           chip1=0.0D0
1468 c           chip2=0.0D0
1469 c           chip12=0.0D0
1470 c           alf1=0.0D0
1471 c           alf2=0.0D0
1472 c           alf12=0.0D0
1473             xj=c(1,nres+j)-xi
1474             yj=c(2,nres+j)-yi
1475             zj=c(3,nres+j)-zi
1476             dxj=dc_norm(1,nres+j)
1477             dyj=dc_norm(2,nres+j)
1478             dzj=dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480 cd          if (icall.eq.0) then
1481 cd            rrsave(ind)=rrij
1482 cd          else
1483 cd            rrij=rrsave(ind)
1484 cd          endif
1485             rij=dsqrt(rrij)
1486 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1487             call sc_angular
1488 C Calculate whole angle-dependent part of epsilon and contributions
1489 C to its derivatives
1490             fac=(rrij*sigsq)**expon2
1491             e1=fac*fac*aa(itypi,itypj)
1492             e2=fac*bb(itypi,itypj)
1493             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1494             eps2der=evdwij*eps3rt
1495             eps3der=evdwij*eps2rt
1496             evdwij=evdwij*eps2rt*eps3rt
1497 #ifdef TSCSC
1498             if (bb(itypi,itypj).gt.0) then
1499                evdw_p=evdw_p+evdwij
1500             else
1501                evdw_m=evdw_m+evdwij
1502             endif
1503 #else
1504             evdw=evdw+evdwij
1505 #endif
1506             if (lprn) then
1507             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1508             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1509 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1510 cd     &        restyp(itypi),i,restyp(itypj),j,
1511 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1512 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1513 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1514 cd     &        evdwij
1515             endif
1516 C Calculate gradient components.
1517             e1=e1*eps1*eps2rt**2*eps3rt**2
1518             fac=-expon*(e1+evdwij)
1519             sigder=fac/sigsq
1520             fac=rrij*fac
1521 C Calculate radial part of the gradient
1522             gg(1)=xj*fac
1523             gg(2)=yj*fac
1524             gg(3)=zj*fac
1525 C Calculate the angular part of the gradient and sum add the contributions
1526 C to the appropriate components of the Cartesian gradient.
1527 #ifdef TSCSC
1528             if (bb(itypi,itypj).gt.0) then
1529                call sc_grad
1530             else
1531                call sc_grad_T
1532             endif
1533 #else
1534             call sc_grad
1535 #endif
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c     stop
1540       return
1541       end
1542 C-----------------------------------------------------------------------------
1543       subroutine egb(evdw,evdw_p,evdw_m)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the Gay-Berne potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       include 'COMMON.GEO'
1551       include 'COMMON.VAR'
1552       include 'COMMON.LOCAL'
1553       include 'COMMON.CHAIN'
1554       include 'COMMON.DERIV'
1555       include 'COMMON.NAMES'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.IOUNITS'
1558       include 'COMMON.CALC'
1559       include 'COMMON.CONTROL'
1560       include 'COMMON.SBRIDGE'
1561       logical lprn
1562       evdw=0.0D0
1563 ccccc      energy_dec=.false.
1564 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1565       evdw=0.0D0
1566       evdw_p=0.0D0
1567       evdw_m=0.0D0
1568       lprn=.false.
1569 c     if (icall.eq.0) lprn=.false.
1570       ind=0
1571       do i=iatsc_s,iatsc_e
1572         itypi=itype(i)
1573         itypi1=itype(i+1)
1574         xi=c(1,nres+i)
1575         yi=c(2,nres+i)
1576         zi=c(3,nres+i)
1577         dxi=dc_norm(1,nres+i)
1578         dyi=dc_norm(2,nres+i)
1579         dzi=dc_norm(3,nres+i)
1580 c        dsci_inv=dsc_inv(itypi)
1581         dsci_inv=vbld_inv(i+nres)
1582 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1583 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1584 C
1585 C Calculate SC interaction energy.
1586 C
1587         do iint=1,nint_gr(i)
1588           do j=istart(i,iint),iend(i,iint)
1589             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1590               call dyn_ssbond_ene(i,j,evdwij)
1591               evdw=evdw+evdwij
1592 cdebug              write(iout,*) 'dyn_ssbond_ene ',evdwij
1593             ELSE
1594             ind=ind+1
1595             itypj=itype(j)
1596 c            dscj_inv=dsc_inv(itypj)
1597             dscj_inv=vbld_inv(j+nres)
1598 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1599 c     &       1.0d0/vbld(j+nres)
1600 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1601             sig0ij=sigma(itypi,itypj)
1602             chi1=chi(itypi,itypj)
1603             chi2=chi(itypj,itypi)
1604             chi12=chi1*chi2
1605             chip1=chip(itypi)
1606             chip2=chip(itypj)
1607             chip12=chip1*chip2
1608             alf1=alp(itypi)
1609             alf2=alp(itypj)
1610             alf12=0.5D0*(alf1+alf2)
1611 C For diagnostics only!!!
1612 c           chi1=0.0D0
1613 c           chi2=0.0D0
1614 c           chi12=0.0D0
1615 c           chip1=0.0D0
1616 c           chip2=0.0D0
1617 c           chip12=0.0D0
1618 c           alf1=0.0D0
1619 c           alf2=0.0D0
1620 c           alf12=0.0D0
1621             xj=c(1,nres+j)-xi
1622             yj=c(2,nres+j)-yi
1623             zj=c(3,nres+j)-zi
1624             dxj=dc_norm(1,nres+j)
1625             dyj=dc_norm(2,nres+j)
1626             dzj=dc_norm(3,nres+j)
1627 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1628 c            write (iout,*) "j",j," dc_norm",
1629 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1630             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1631             rij=dsqrt(rrij)
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+sig0ij
1638 c for diagnostics; uncomment
1639 c            rij_shift=1.2*sig0ij
1640 C I hate to put IF's in the loops, but here don't have another choice!!!!
1641             if (rij_shift.le.0.0D0) then
1642               evdw=1.0D20
1643 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1644 cd     &        restyp(itypi),i,restyp(itypj),j,
1645 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1646               return
1647             endif
1648             sigder=-sig*sigsq
1649 c---------------------------------------------------------------
1650             rij_shift=1.0D0/rij_shift
1651             fac=rij_shift**expon
1652             e1=fac*fac*aa(itypi,itypj)
1653             e2=fac*bb(itypi,itypj)
1654             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1655             eps2der=evdwij*eps3rt
1656             eps3der=evdwij*eps2rt
1657 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1658 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1659             evdwij=evdwij*eps2rt*eps3rt
1660 #ifdef TSCSC
1661             if (bb(itypi,itypj).gt.0) then
1662                evdw_p=evdw_p+evdwij
1663             else
1664                evdw_m=evdw_m+evdwij
1665             endif
1666 #else
1667             evdw=evdw+evdwij
1668 #endif
1669             if (lprn) then
1670             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1671             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1672             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1673      &        restyp(itypi),i,restyp(itypj),j,
1674      &        epsi,sigm,chi1,chi2,chip1,chip2,
1675      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1676      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1677      &        evdwij
1678             endif
1679
1680             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1681      &                        'evdw',i,j,evdwij
1682
1683 C Calculate gradient components.
1684             e1=e1*eps1*eps2rt**2*eps3rt**2
1685             fac=-expon*(e1+evdwij)*rij_shift
1686             sigder=fac*sigder
1687             fac=rij*fac
1688 c            fac=0.0d0
1689 C Calculate the radial part of the gradient
1690             gg(1)=xj*fac
1691             gg(2)=yj*fac
1692             gg(3)=zj*fac
1693 C Calculate angular part of the gradient.
1694 #ifdef TSCSC
1695             if (bb(itypi,itypj).gt.0) then
1696                call sc_grad
1697             else
1698                call sc_grad_T
1699             endif
1700 #else
1701             call sc_grad
1702 #endif
1703             ENDIF    ! dyn_ss
1704           enddo      ! j
1705         enddo        ! iint
1706       enddo          ! i
1707 c      write (iout,*) "Number of loop steps in EGB:",ind
1708 cccc      energy_dec=.false.
1709       return
1710       end
1711 C-----------------------------------------------------------------------------
1712       subroutine egbv(evdw,evdw_p,evdw_m)
1713 C
1714 C This subroutine calculates the interaction energy of nonbonded side chains
1715 C assuming the Gay-Berne-Vorobjev potential of interaction.
1716 C
1717       implicit real*8 (a-h,o-z)
1718       include 'DIMENSIONS'
1719       include 'COMMON.GEO'
1720       include 'COMMON.VAR'
1721       include 'COMMON.LOCAL'
1722       include 'COMMON.CHAIN'
1723       include 'COMMON.DERIV'
1724       include 'COMMON.NAMES'
1725       include 'COMMON.INTERACT'
1726       include 'COMMON.IOUNITS'
1727       include 'COMMON.CALC'
1728       common /srutu/ icall
1729       logical lprn
1730       evdw=0.0D0
1731 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1732       evdw=0.0D0
1733       lprn=.false.
1734 c     if (icall.eq.0) lprn=.true.
1735       ind=0
1736       do i=iatsc_s,iatsc_e
1737         itypi=itype(i)
1738         itypi1=itype(i+1)
1739         xi=c(1,nres+i)
1740         yi=c(2,nres+i)
1741         zi=c(3,nres+i)
1742         dxi=dc_norm(1,nres+i)
1743         dyi=dc_norm(2,nres+i)
1744         dzi=dc_norm(3,nres+i)
1745 c        dsci_inv=dsc_inv(itypi)
1746         dsci_inv=vbld_inv(i+nres)
1747 C
1748 C Calculate SC interaction energy.
1749 C
1750         do iint=1,nint_gr(i)
1751           do j=istart(i,iint),iend(i,iint)
1752             ind=ind+1
1753             itypj=itype(j)
1754 c            dscj_inv=dsc_inv(itypj)
1755             dscj_inv=vbld_inv(j+nres)
1756             sig0ij=sigma(itypi,itypj)
1757             r0ij=r0(itypi,itypj)
1758             chi1=chi(itypi,itypj)
1759             chi2=chi(itypj,itypi)
1760             chi12=chi1*chi2
1761             chip1=chip(itypi)
1762             chip2=chip(itypj)
1763             chip12=chip1*chip2
1764             alf1=alp(itypi)
1765             alf2=alp(itypj)
1766             alf12=0.5D0*(alf1+alf2)
1767 C For diagnostics only!!!
1768 c           chi1=0.0D0
1769 c           chi2=0.0D0
1770 c           chi12=0.0D0
1771 c           chip1=0.0D0
1772 c           chip2=0.0D0
1773 c           chip12=0.0D0
1774 c           alf1=0.0D0
1775 c           alf2=0.0D0
1776 c           alf12=0.0D0
1777             xj=c(1,nres+j)-xi
1778             yj=c(2,nres+j)-yi
1779             zj=c(3,nres+j)-zi
1780             dxj=dc_norm(1,nres+j)
1781             dyj=dc_norm(2,nres+j)
1782             dzj=dc_norm(3,nres+j)
1783             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1784             rij=dsqrt(rrij)
1785 C Calculate angle-dependent terms of energy and contributions to their
1786 C derivatives.
1787             call sc_angular
1788             sigsq=1.0D0/sigsq
1789             sig=sig0ij*dsqrt(sigsq)
1790             rij_shift=1.0D0/rij-sig+r0ij
1791 C I hate to put IF's in the loops, but here don't have another choice!!!!
1792             if (rij_shift.le.0.0D0) then
1793               evdw=1.0D20
1794               return
1795             endif
1796             sigder=-sig*sigsq
1797 c---------------------------------------------------------------
1798             rij_shift=1.0D0/rij_shift
1799             fac=rij_shift**expon
1800             e1=fac*fac*aa(itypi,itypj)
1801             e2=fac*bb(itypi,itypj)
1802             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1803             eps2der=evdwij*eps3rt
1804             eps3der=evdwij*eps2rt
1805             fac_augm=rrij**expon
1806             e_augm=augm(itypi,itypj)*fac_augm
1807             evdwij=evdwij*eps2rt*eps3rt
1808 #ifdef TSCSC
1809             if (bb(itypi,itypj).gt.0) then
1810                evdw_p=evdw_p+evdwij+e_augm
1811             else
1812                evdw_m=evdw_m+evdwij+e_augm
1813             endif
1814 #else
1815             evdw=evdw+evdwij+e_augm
1816 #endif
1817             if (lprn) then
1818             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1819             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1820             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1821      &        restyp(itypi),i,restyp(itypj),j,
1822      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1823      &        chi1,chi2,chip1,chip2,
1824      &        eps1,eps2rt**2,eps3rt**2,
1825      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1826      &        evdwij+e_augm
1827             endif
1828 C Calculate gradient components.
1829             e1=e1*eps1*eps2rt**2*eps3rt**2
1830             fac=-expon*(e1+evdwij)*rij_shift
1831             sigder=fac*sigder
1832             fac=rij*fac-2*expon*rrij*e_augm
1833 C Calculate the radial part of the gradient
1834             gg(1)=xj*fac
1835             gg(2)=yj*fac
1836             gg(3)=zj*fac
1837 C Calculate angular part of the gradient.
1838 #ifdef TSCSC
1839             if (bb(itypi,itypj).gt.0) then
1840                call sc_grad
1841             else
1842                call sc_grad_T
1843             endif
1844 #else
1845             call sc_grad
1846 #endif
1847           enddo      ! j
1848         enddo        ! iint
1849       enddo          ! i
1850       end
1851 C-----------------------------------------------------------------------------
1852       subroutine sc_angular
1853 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1854 C om12. Called by ebp, egb, and egbv.
1855       implicit none
1856       include 'COMMON.CALC'
1857       include 'COMMON.IOUNITS'
1858       erij(1)=xj*rij
1859       erij(2)=yj*rij
1860       erij(3)=zj*rij
1861       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1862       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1863       om12=dxi*dxj+dyi*dyj+dzi*dzj
1864       chiom12=chi12*om12
1865 C Calculate eps1(om12) and its derivative in om12
1866       faceps1=1.0D0-om12*chiom12
1867       faceps1_inv=1.0D0/faceps1
1868       eps1=dsqrt(faceps1_inv)
1869 C Following variable is eps1*deps1/dom12
1870       eps1_om12=faceps1_inv*chiom12
1871 c diagnostics only
1872 c      faceps1_inv=om12
1873 c      eps1=om12
1874 c      eps1_om12=1.0d0
1875 c      write (iout,*) "om12",om12," eps1",eps1
1876 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1877 C and om12.
1878       om1om2=om1*om2
1879       chiom1=chi1*om1
1880       chiom2=chi2*om2
1881       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1882       sigsq=1.0D0-facsig*faceps1_inv
1883       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1884       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1885       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1886 c diagnostics only
1887 c      sigsq=1.0d0
1888 c      sigsq_om1=0.0d0
1889 c      sigsq_om2=0.0d0
1890 c      sigsq_om12=0.0d0
1891 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1892 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1893 c     &    " eps1",eps1
1894 C Calculate eps2 and its derivatives in om1, om2, and om12.
1895       chipom1=chip1*om1
1896       chipom2=chip2*om2
1897       chipom12=chip12*om12
1898       facp=1.0D0-om12*chipom12
1899       facp_inv=1.0D0/facp
1900       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1901 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1902 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1903 C Following variable is the square root of eps2
1904       eps2rt=1.0D0-facp1*facp_inv
1905 C Following three variables are the derivatives of the square root of eps
1906 C in om1, om2, and om12.
1907       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1908       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1909       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1910 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1911       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1912 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1913 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1914 c     &  " eps2rt_om12",eps2rt_om12
1915 C Calculate whole angle-dependent part of epsilon and contributions
1916 C to its derivatives
1917       return
1918       end
1919
1920 C----------------------------------------------------------------------------
1921       subroutine sc_grad_T
1922       implicit real*8 (a-h,o-z)
1923       include 'DIMENSIONS'
1924       include 'COMMON.CHAIN'
1925       include 'COMMON.DERIV'
1926       include 'COMMON.CALC'
1927       include 'COMMON.IOUNITS'
1928       double precision dcosom1(3),dcosom2(3)
1929       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1930       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1931       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1932      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1933 c diagnostics only
1934 c      eom1=0.0d0
1935 c      eom2=0.0d0
1936 c      eom12=evdwij*eps1_om12
1937 c end diagnostics
1938 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1939 c     &  " sigder",sigder
1940 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1941 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1942       do k=1,3
1943         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1944         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1945       enddo
1946       do k=1,3
1947         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1948       enddo
1949 c      write (iout,*) "gg",(gg(k),k=1,3)
1950       do k=1,3
1951         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1952      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1953      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1954         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1955      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1956      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1957 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1958 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1959 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1960 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1961       enddo
1962 C
1963 C Calculate the components of the gradient in DC and X
1964 C
1965 cgrad      do k=i,j-1
1966 cgrad        do l=1,3
1967 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1968 cgrad        enddo
1969 cgrad      enddo
1970       do l=1,3
1971         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1972         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1973       enddo
1974       return
1975       end
1976
1977 C----------------------------------------------------------------------------
1978       subroutine sc_grad
1979       implicit real*8 (a-h,o-z)
1980       include 'DIMENSIONS'
1981       include 'COMMON.CHAIN'
1982       include 'COMMON.DERIV'
1983       include 'COMMON.CALC'
1984       include 'COMMON.IOUNITS'
1985       double precision dcosom1(3),dcosom2(3)
1986       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1987       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1988       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1989      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1990 c diagnostics only
1991 c      eom1=0.0d0
1992 c      eom2=0.0d0
1993 c      eom12=evdwij*eps1_om12
1994 c end diagnostics
1995 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1996 c     &  " sigder",sigder
1997 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1998 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1999       do k=1,3
2000         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2001         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2002       enddo
2003       do k=1,3
2004         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2005       enddo
2006 c      write (iout,*) "gg",(gg(k),k=1,3)
2007       do k=1,3
2008         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2009      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2010      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2011         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2012      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2013      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2014 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2015 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2016 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2017 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2018       enddo
2019 C
2020 C Calculate the components of the gradient in DC and X
2021 C
2022 cgrad      do k=i,j-1
2023 cgrad        do l=1,3
2024 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2025 cgrad        enddo
2026 cgrad      enddo
2027       do l=1,3
2028         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2029         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2030       enddo
2031       return
2032       end
2033 C-----------------------------------------------------------------------
2034       subroutine e_softsphere(evdw)
2035 C
2036 C This subroutine calculates the interaction energy of nonbonded side chains
2037 C assuming the LJ potential of interaction.
2038 C
2039       implicit real*8 (a-h,o-z)
2040       include 'DIMENSIONS'
2041       parameter (accur=1.0d-10)
2042       include 'COMMON.GEO'
2043       include 'COMMON.VAR'
2044       include 'COMMON.LOCAL'
2045       include 'COMMON.CHAIN'
2046       include 'COMMON.DERIV'
2047       include 'COMMON.INTERACT'
2048       include 'COMMON.TORSION'
2049       include 'COMMON.SBRIDGE'
2050       include 'COMMON.NAMES'
2051       include 'COMMON.IOUNITS'
2052       include 'COMMON.CONTACTS'
2053       dimension gg(3)
2054 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2055       evdw=0.0D0
2056       do i=iatsc_s,iatsc_e
2057         itypi=itype(i)
2058         itypi1=itype(i+1)
2059         xi=c(1,nres+i)
2060         yi=c(2,nres+i)
2061         zi=c(3,nres+i)
2062 C
2063 C Calculate SC interaction energy.
2064 C
2065         do iint=1,nint_gr(i)
2066 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2067 cd   &                  'iend=',iend(i,iint)
2068           do j=istart(i,iint),iend(i,iint)
2069             itypj=itype(j)
2070             xj=c(1,nres+j)-xi
2071             yj=c(2,nres+j)-yi
2072             zj=c(3,nres+j)-zi
2073             rij=xj*xj+yj*yj+zj*zj
2074 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2075             r0ij=r0(itypi,itypj)
2076             r0ijsq=r0ij*r0ij
2077 c            print *,i,j,r0ij,dsqrt(rij)
2078             if (rij.lt.r0ijsq) then
2079               evdwij=0.25d0*(rij-r0ijsq)**2
2080               fac=rij-r0ijsq
2081             else
2082               evdwij=0.0d0
2083               fac=0.0d0
2084             endif
2085             evdw=evdw+evdwij
2086 C
2087 C Calculate the components of the gradient in DC and X
2088 C
2089             gg(1)=xj*fac
2090             gg(2)=yj*fac
2091             gg(3)=zj*fac
2092             do k=1,3
2093               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2094               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2095               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2096               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2097             enddo
2098 cgrad            do k=i,j-1
2099 cgrad              do l=1,3
2100 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2101 cgrad              enddo
2102 cgrad            enddo
2103           enddo ! j
2104         enddo ! iint
2105       enddo ! i
2106       return
2107       end
2108 C--------------------------------------------------------------------------
2109       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2110      &              eello_turn4)
2111 C
2112 C Soft-sphere potential of p-p interaction
2113 C
2114       implicit real*8 (a-h,o-z)
2115       include 'DIMENSIONS'
2116       include 'COMMON.CONTROL'
2117       include 'COMMON.IOUNITS'
2118       include 'COMMON.GEO'
2119       include 'COMMON.VAR'
2120       include 'COMMON.LOCAL'
2121       include 'COMMON.CHAIN'
2122       include 'COMMON.DERIV'
2123       include 'COMMON.INTERACT'
2124       include 'COMMON.CONTACTS'
2125       include 'COMMON.TORSION'
2126       include 'COMMON.VECTORS'
2127       include 'COMMON.FFIELD'
2128       dimension ggg(3)
2129 cd      write(iout,*) 'In EELEC_soft_sphere'
2130       ees=0.0D0
2131       evdw1=0.0D0
2132       eel_loc=0.0d0
2133       eello_turn3=0.0d0
2134       eello_turn4=0.0d0
2135       ind=0
2136       do i=iatel_s,iatel_e
2137         dxi=dc(1,i)
2138         dyi=dc(2,i)
2139         dzi=dc(3,i)
2140         xmedi=c(1,i)+0.5d0*dxi
2141         ymedi=c(2,i)+0.5d0*dyi
2142         zmedi=c(3,i)+0.5d0*dzi
2143         num_conti=0
2144 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2145         do j=ielstart(i),ielend(i)
2146           ind=ind+1
2147           iteli=itel(i)
2148           itelj=itel(j)
2149           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2150           r0ij=rpp(iteli,itelj)
2151           r0ijsq=r0ij*r0ij
2152           dxj=dc(1,j)
2153           dyj=dc(2,j)
2154           dzj=dc(3,j)
2155           xj=c(1,j)+0.5D0*dxj-xmedi
2156           yj=c(2,j)+0.5D0*dyj-ymedi
2157           zj=c(3,j)+0.5D0*dzj-zmedi
2158           rij=xj*xj+yj*yj+zj*zj
2159           if (rij.lt.r0ijsq) then
2160             evdw1ij=0.25d0*(rij-r0ijsq)**2
2161             fac=rij-r0ijsq
2162           else
2163             evdw1ij=0.0d0
2164             fac=0.0d0
2165           endif
2166           evdw1=evdw1+evdw1ij
2167 C
2168 C Calculate contributions to the Cartesian gradient.
2169 C
2170           ggg(1)=fac*xj
2171           ggg(2)=fac*yj
2172           ggg(3)=fac*zj
2173           do k=1,3
2174             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2175             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2176           enddo
2177 *
2178 * Loop over residues i+1 thru j-1.
2179 *
2180 cgrad          do k=i+1,j-1
2181 cgrad            do l=1,3
2182 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2183 cgrad            enddo
2184 cgrad          enddo
2185         enddo ! j
2186       enddo   ! i
2187 cgrad      do i=nnt,nct-1
2188 cgrad        do k=1,3
2189 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2190 cgrad        enddo
2191 cgrad        do j=i+1,nct-1
2192 cgrad          do k=1,3
2193 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2194 cgrad          enddo
2195 cgrad        enddo
2196 cgrad      enddo
2197       return
2198       end
2199 c------------------------------------------------------------------------------
2200       subroutine vec_and_deriv
2201       implicit real*8 (a-h,o-z)
2202       include 'DIMENSIONS'
2203 #ifdef MPI
2204       include 'mpif.h'
2205 #endif
2206       include 'COMMON.IOUNITS'
2207       include 'COMMON.GEO'
2208       include 'COMMON.VAR'
2209       include 'COMMON.LOCAL'
2210       include 'COMMON.CHAIN'
2211       include 'COMMON.VECTORS'
2212       include 'COMMON.SETUP'
2213       include 'COMMON.TIME1'
2214       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2215 C Compute the local reference systems. For reference system (i), the
2216 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2217 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2218 #ifdef PARVEC
2219       do i=ivec_start,ivec_end
2220 #else
2221       do i=1,nres-1
2222 #endif
2223           if (i.eq.nres-1) then
2224 C Case of the last full residue
2225 C Compute the Z-axis
2226             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2227             costh=dcos(pi-theta(nres))
2228             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2229             do k=1,3
2230               uz(k,i)=fac*uz(k,i)
2231             enddo
2232 C Compute the derivatives of uz
2233             uzder(1,1,1)= 0.0d0
2234             uzder(2,1,1)=-dc_norm(3,i-1)
2235             uzder(3,1,1)= dc_norm(2,i-1)
2236             uzder(1,2,1)= dc_norm(3,i-1)
2237             uzder(2,2,1)= 0.0d0
2238             uzder(3,2,1)=-dc_norm(1,i-1)
2239             uzder(1,3,1)=-dc_norm(2,i-1)
2240             uzder(2,3,1)= dc_norm(1,i-1)
2241             uzder(3,3,1)= 0.0d0
2242             uzder(1,1,2)= 0.0d0
2243             uzder(2,1,2)= dc_norm(3,i)
2244             uzder(3,1,2)=-dc_norm(2,i)
2245             uzder(1,2,2)=-dc_norm(3,i)
2246             uzder(2,2,2)= 0.0d0
2247             uzder(3,2,2)= dc_norm(1,i)
2248             uzder(1,3,2)= dc_norm(2,i)
2249             uzder(2,3,2)=-dc_norm(1,i)
2250             uzder(3,3,2)= 0.0d0
2251 C Compute the Y-axis
2252             facy=fac
2253             do k=1,3
2254               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2255             enddo
2256 C Compute the derivatives of uy
2257             do j=1,3
2258               do k=1,3
2259                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2260      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2261                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2262               enddo
2263               uyder(j,j,1)=uyder(j,j,1)-costh
2264               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2265             enddo
2266             do j=1,2
2267               do k=1,3
2268                 do l=1,3
2269                   uygrad(l,k,j,i)=uyder(l,k,j)
2270                   uzgrad(l,k,j,i)=uzder(l,k,j)
2271                 enddo
2272               enddo
2273             enddo
2274             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2275             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2276             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2277             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2278           else
2279 C Other residues
2280 C Compute the Z-axis
2281             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2282             costh=dcos(pi-theta(i+2))
2283             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2284             do k=1,3
2285               uz(k,i)=fac*uz(k,i)
2286             enddo
2287 C Compute the derivatives of uz
2288             uzder(1,1,1)= 0.0d0
2289             uzder(2,1,1)=-dc_norm(3,i+1)
2290             uzder(3,1,1)= dc_norm(2,i+1)
2291             uzder(1,2,1)= dc_norm(3,i+1)
2292             uzder(2,2,1)= 0.0d0
2293             uzder(3,2,1)=-dc_norm(1,i+1)
2294             uzder(1,3,1)=-dc_norm(2,i+1)
2295             uzder(2,3,1)= dc_norm(1,i+1)
2296             uzder(3,3,1)= 0.0d0
2297             uzder(1,1,2)= 0.0d0
2298             uzder(2,1,2)= dc_norm(3,i)
2299             uzder(3,1,2)=-dc_norm(2,i)
2300             uzder(1,2,2)=-dc_norm(3,i)
2301             uzder(2,2,2)= 0.0d0
2302             uzder(3,2,2)= dc_norm(1,i)
2303             uzder(1,3,2)= dc_norm(2,i)
2304             uzder(2,3,2)=-dc_norm(1,i)
2305             uzder(3,3,2)= 0.0d0
2306 C Compute the Y-axis
2307             facy=fac
2308             do k=1,3
2309               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2310             enddo
2311 C Compute the derivatives of uy
2312             do j=1,3
2313               do k=1,3
2314                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2315      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2316                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2317               enddo
2318               uyder(j,j,1)=uyder(j,j,1)-costh
2319               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2320             enddo
2321             do j=1,2
2322               do k=1,3
2323                 do l=1,3
2324                   uygrad(l,k,j,i)=uyder(l,k,j)
2325                   uzgrad(l,k,j,i)=uzder(l,k,j)
2326                 enddo
2327               enddo
2328             enddo
2329             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2330             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2331             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2332             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2333           endif
2334       enddo
2335       do i=1,nres-1
2336         vbld_inv_temp(1)=vbld_inv(i+1)
2337         if (i.lt.nres-1) then
2338           vbld_inv_temp(2)=vbld_inv(i+2)
2339           else
2340           vbld_inv_temp(2)=vbld_inv(i)
2341           endif
2342         do j=1,2
2343           do k=1,3
2344             do l=1,3
2345               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2346               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2347             enddo
2348           enddo
2349         enddo
2350       enddo
2351 #if defined(PARVEC) && defined(MPI)
2352       if (nfgtasks1.gt.1) then
2353         time00=MPI_Wtime()
2354 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2355 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2356 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2357         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2358      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2359      &   FG_COMM1,IERR)
2360         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2361      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2362      &   FG_COMM1,IERR)
2363         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2364      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2365      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2366         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2367      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2368      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2369         time_gather=time_gather+MPI_Wtime()-time00
2370       endif
2371 c      if (fg_rank.eq.0) then
2372 c        write (iout,*) "Arrays UY and UZ"
2373 c        do i=1,nres-1
2374 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2375 c     &     (uz(k,i),k=1,3)
2376 c        enddo
2377 c      endif
2378 #endif
2379       return
2380       end
2381 C-----------------------------------------------------------------------------
2382       subroutine check_vecgrad
2383       implicit real*8 (a-h,o-z)
2384       include 'DIMENSIONS'
2385       include 'COMMON.IOUNITS'
2386       include 'COMMON.GEO'
2387       include 'COMMON.VAR'
2388       include 'COMMON.LOCAL'
2389       include 'COMMON.CHAIN'
2390       include 'COMMON.VECTORS'
2391       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2392       dimension uyt(3,maxres),uzt(3,maxres)
2393       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2394       double precision delta /1.0d-7/
2395       call vec_and_deriv
2396 cd      do i=1,nres
2397 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2398 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2399 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2400 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2401 cd     &     (dc_norm(if90,i),if90=1,3)
2402 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2403 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2404 cd          write(iout,'(a)')
2405 cd      enddo
2406       do i=1,nres
2407         do j=1,2
2408           do k=1,3
2409             do l=1,3
2410               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2411               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2412             enddo
2413           enddo
2414         enddo
2415       enddo
2416       call vec_and_deriv
2417       do i=1,nres
2418         do j=1,3
2419           uyt(j,i)=uy(j,i)
2420           uzt(j,i)=uz(j,i)
2421         enddo
2422       enddo
2423       do i=1,nres
2424 cd        write (iout,*) 'i=',i
2425         do k=1,3
2426           erij(k)=dc_norm(k,i)
2427         enddo
2428         do j=1,3
2429           do k=1,3
2430             dc_norm(k,i)=erij(k)
2431           enddo
2432           dc_norm(j,i)=dc_norm(j,i)+delta
2433 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2434 c          do k=1,3
2435 c            dc_norm(k,i)=dc_norm(k,i)/fac
2436 c          enddo
2437 c          write (iout,*) (dc_norm(k,i),k=1,3)
2438 c          write (iout,*) (erij(k),k=1,3)
2439           call vec_and_deriv
2440           do k=1,3
2441             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2442             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2443             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2444             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2445           enddo
2446 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2447 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2448 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2449         enddo
2450         do k=1,3
2451           dc_norm(k,i)=erij(k)
2452         enddo
2453 cd        do k=1,3
2454 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2455 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2456 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2457 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2458 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2459 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2460 cd          write (iout,'(a)')
2461 cd        enddo
2462       enddo
2463       return
2464       end
2465 C--------------------------------------------------------------------------
2466       subroutine set_matrices
2467       implicit real*8 (a-h,o-z)
2468       include 'DIMENSIONS'
2469 #ifdef MPI
2470       include "mpif.h"
2471       include "COMMON.SETUP"
2472       integer IERR
2473       integer status(MPI_STATUS_SIZE)
2474 #endif
2475       include 'COMMON.IOUNITS'
2476       include 'COMMON.GEO'
2477       include 'COMMON.VAR'
2478       include 'COMMON.LOCAL'
2479       include 'COMMON.CHAIN'
2480       include 'COMMON.DERIV'
2481       include 'COMMON.INTERACT'
2482       include 'COMMON.CONTACTS'
2483       include 'COMMON.TORSION'
2484       include 'COMMON.VECTORS'
2485       include 'COMMON.FFIELD'
2486       double precision auxvec(2),auxmat(2,2)
2487 C
2488 C Compute the virtual-bond-torsional-angle dependent quantities needed
2489 C to calculate the el-loc multibody terms of various order.
2490 C
2491 #ifdef PARMAT
2492       do i=ivec_start+2,ivec_end+2
2493 #else
2494       do i=3,nres+1
2495 #endif
2496         if (i .lt. nres+1) then
2497           sin1=dsin(phi(i))
2498           cos1=dcos(phi(i))
2499           sintab(i-2)=sin1
2500           costab(i-2)=cos1
2501           obrot(1,i-2)=cos1
2502           obrot(2,i-2)=sin1
2503           sin2=dsin(2*phi(i))
2504           cos2=dcos(2*phi(i))
2505           sintab2(i-2)=sin2
2506           costab2(i-2)=cos2
2507           obrot2(1,i-2)=cos2
2508           obrot2(2,i-2)=sin2
2509           Ug(1,1,i-2)=-cos1
2510           Ug(1,2,i-2)=-sin1
2511           Ug(2,1,i-2)=-sin1
2512           Ug(2,2,i-2)= cos1
2513           Ug2(1,1,i-2)=-cos2
2514           Ug2(1,2,i-2)=-sin2
2515           Ug2(2,1,i-2)=-sin2
2516           Ug2(2,2,i-2)= cos2
2517         else
2518           costab(i-2)=1.0d0
2519           sintab(i-2)=0.0d0
2520           obrot(1,i-2)=1.0d0
2521           obrot(2,i-2)=0.0d0
2522           obrot2(1,i-2)=0.0d0
2523           obrot2(2,i-2)=0.0d0
2524           Ug(1,1,i-2)=1.0d0
2525           Ug(1,2,i-2)=0.0d0
2526           Ug(2,1,i-2)=0.0d0
2527           Ug(2,2,i-2)=1.0d0
2528           Ug2(1,1,i-2)=0.0d0
2529           Ug2(1,2,i-2)=0.0d0
2530           Ug2(2,1,i-2)=0.0d0
2531           Ug2(2,2,i-2)=0.0d0
2532         endif
2533         if (i .gt. 3 .and. i .lt. nres+1) then
2534           obrot_der(1,i-2)=-sin1
2535           obrot_der(2,i-2)= cos1
2536           Ugder(1,1,i-2)= sin1
2537           Ugder(1,2,i-2)=-cos1
2538           Ugder(2,1,i-2)=-cos1
2539           Ugder(2,2,i-2)=-sin1
2540           dwacos2=cos2+cos2
2541           dwasin2=sin2+sin2
2542           obrot2_der(1,i-2)=-dwasin2
2543           obrot2_der(2,i-2)= dwacos2
2544           Ug2der(1,1,i-2)= dwasin2
2545           Ug2der(1,2,i-2)=-dwacos2
2546           Ug2der(2,1,i-2)=-dwacos2
2547           Ug2der(2,2,i-2)=-dwasin2
2548         else
2549           obrot_der(1,i-2)=0.0d0
2550           obrot_der(2,i-2)=0.0d0
2551           Ugder(1,1,i-2)=0.0d0
2552           Ugder(1,2,i-2)=0.0d0
2553           Ugder(2,1,i-2)=0.0d0
2554           Ugder(2,2,i-2)=0.0d0
2555           obrot2_der(1,i-2)=0.0d0
2556           obrot2_der(2,i-2)=0.0d0
2557           Ug2der(1,1,i-2)=0.0d0
2558           Ug2der(1,2,i-2)=0.0d0
2559           Ug2der(2,1,i-2)=0.0d0
2560           Ug2der(2,2,i-2)=0.0d0
2561         endif
2562 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2563         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2564           iti = itortyp(itype(i-2))
2565         else
2566           iti=ntortyp+1
2567         endif
2568 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2569         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2570           iti1 = itortyp(itype(i-1))
2571         else
2572           iti1=ntortyp+1
2573         endif
2574 cd        write (iout,*) '*******i',i,' iti1',iti
2575 cd        write (iout,*) 'b1',b1(:,iti)
2576 cd        write (iout,*) 'b2',b2(:,iti)
2577 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2578 c        if (i .gt. iatel_s+2) then
2579         if (i .gt. nnt+2) then
2580           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2581           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2582           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2583      &    then
2584           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2585           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2586           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2587           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2588           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2589           endif
2590         else
2591           do k=1,2
2592             Ub2(k,i-2)=0.0d0
2593             Ctobr(k,i-2)=0.0d0
2594             Dtobr2(k,i-2)=0.0d0
2595             do l=1,2
2596               EUg(l,k,i-2)=0.0d0
2597               CUg(l,k,i-2)=0.0d0
2598               DUg(l,k,i-2)=0.0d0
2599               DtUg2(l,k,i-2)=0.0d0
2600             enddo
2601           enddo
2602         endif
2603         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2604         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2605         do k=1,2
2606           muder(k,i-2)=Ub2der(k,i-2)
2607         enddo
2608 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2609         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2610           iti1 = itortyp(itype(i-1))
2611         else
2612           iti1=ntortyp+1
2613         endif
2614         do k=1,2
2615           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2616         enddo
2617 cd        write (iout,*) 'mu ',mu(:,i-2)
2618 cd        write (iout,*) 'mu1',mu1(:,i-2)
2619 cd        write (iout,*) 'mu2',mu2(:,i-2)
2620         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2621      &  then
2622         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2623         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2624         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2625         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2626         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2627 C Vectors and matrices dependent on a single virtual-bond dihedral.
2628         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2629         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2630         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2631         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2632         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2633         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2634         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2635         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2636         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2637         endif
2638       enddo
2639 C Matrices dependent on two consecutive virtual-bond dihedrals.
2640 C The order of matrices is from left to right.
2641       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2642      &then
2643 c      do i=max0(ivec_start,2),ivec_end
2644       do i=2,nres-1
2645         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2646         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2647         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2648         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2649         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2650         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2651         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2652         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2653       enddo
2654       endif
2655 #if defined(MPI) && defined(PARMAT)
2656 #ifdef DEBUG
2657 c      if (fg_rank.eq.0) then
2658         write (iout,*) "Arrays UG and UGDER before GATHER"
2659         do i=1,nres-1
2660           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2661      &     ((ug(l,k,i),l=1,2),k=1,2),
2662      &     ((ugder(l,k,i),l=1,2),k=1,2)
2663         enddo
2664         write (iout,*) "Arrays UG2 and UG2DER"
2665         do i=1,nres-1
2666           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2667      &     ((ug2(l,k,i),l=1,2),k=1,2),
2668      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2669         enddo
2670         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2671         do i=1,nres-1
2672           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2673      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2674      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2675         enddo
2676         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2677         do i=1,nres-1
2678           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2679      &     costab(i),sintab(i),costab2(i),sintab2(i)
2680         enddo
2681         write (iout,*) "Array MUDER"
2682         do i=1,nres-1
2683           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2684         enddo
2685 c      endif
2686 #endif
2687       if (nfgtasks.gt.1) then
2688         time00=MPI_Wtime()
2689 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2690 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2691 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2692 #ifdef MATGATHER
2693         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2694      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2695      &   FG_COMM1,IERR)
2696         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2700      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2701      &   FG_COMM1,IERR)
2702         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2703      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2704      &   FG_COMM1,IERR)
2705         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2706      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2707      &   FG_COMM1,IERR)
2708         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2709      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2710      &   FG_COMM1,IERR)
2711         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2712      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2713      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2714         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2715      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2716      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2717         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2718      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2719      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2720         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2721      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2722      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2723         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2724      &  then
2725         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2733      &   FG_COMM1,IERR)
2734        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2736      &   FG_COMM1,IERR)
2737         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2741      &   ivec_count(fg_rank1),
2742      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2743      &   FG_COMM1,IERR)
2744         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2745      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2757      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2758      &   FG_COMM1,IERR)
2759         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2766      &   ivec_count(fg_rank1),
2767      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2768      &   FG_COMM1,IERR)
2769         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2770      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2771      &   FG_COMM1,IERR)
2772        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2773      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2774      &   FG_COMM1,IERR)
2775         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2777      &   FG_COMM1,IERR)
2778        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2782      &   ivec_count(fg_rank1),
2783      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2784      &   FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2786      &   ivec_count(fg_rank1),
2787      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2788      &   FG_COMM1,IERR)
2789         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2790      &   ivec_count(fg_rank1),
2791      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2792      &   MPI_MAT2,FG_COMM1,IERR)
2793         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2794      &   ivec_count(fg_rank1),
2795      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2796      &   MPI_MAT2,FG_COMM1,IERR)
2797         endif
2798 #else
2799 c Passes matrix info through the ring
2800       isend=fg_rank1
2801       irecv=fg_rank1-1
2802       if (irecv.lt.0) irecv=nfgtasks1-1
2803       iprev=irecv
2804       inext=fg_rank1+1
2805       if (inext.ge.nfgtasks1) inext=0
2806       do i=1,nfgtasks1-1
2807 c        write (iout,*) "isend",isend," irecv",irecv
2808 c        call flush(iout)
2809         lensend=lentyp(isend)
2810         lenrecv=lentyp(irecv)
2811 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2812 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2813 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2814 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2815 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2816 c        write (iout,*) "Gather ROTAT1"
2817 c        call flush(iout)
2818 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2819 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2820 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2821 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2822 c        write (iout,*) "Gather ROTAT2"
2823 c        call flush(iout)
2824         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2825      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2826      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2827      &   iprev,4400+irecv,FG_COMM,status,IERR)
2828 c        write (iout,*) "Gather ROTAT_OLD"
2829 c        call flush(iout)
2830         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2831      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2832      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2833      &   iprev,5500+irecv,FG_COMM,status,IERR)
2834 c        write (iout,*) "Gather PRECOMP11"
2835 c        call flush(iout)
2836         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2837      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2838      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2839      &   iprev,6600+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather PRECOMP12"
2841 c        call flush(iout)
2842         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2843      &  then
2844         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2845      &   MPI_ROTAT2(lensend),inext,7700+isend,
2846      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2847      &   iprev,7700+irecv,FG_COMM,status,IERR)
2848 c        write (iout,*) "Gather PRECOMP21"
2849 c        call flush(iout)
2850         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2851      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2852      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2853      &   iprev,8800+irecv,FG_COMM,status,IERR)
2854 c        write (iout,*) "Gather PRECOMP22"
2855 c        call flush(iout)
2856         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2857      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2858      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2859      &   MPI_PRECOMP23(lenrecv),
2860      &   iprev,9900+irecv,FG_COMM,status,IERR)
2861 c        write (iout,*) "Gather PRECOMP23"
2862 c        call flush(iout)
2863         endif
2864         isend=irecv
2865         irecv=irecv-1
2866         if (irecv.lt.0) irecv=nfgtasks1-1
2867       enddo
2868 #endif
2869         time_gather=time_gather+MPI_Wtime()-time00
2870       endif
2871 #ifdef DEBUG
2872 c      if (fg_rank.eq.0) then
2873         write (iout,*) "Arrays UG and UGDER"
2874         do i=1,nres-1
2875           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2876      &     ((ug(l,k,i),l=1,2),k=1,2),
2877      &     ((ugder(l,k,i),l=1,2),k=1,2)
2878         enddo
2879         write (iout,*) "Arrays UG2 and UG2DER"
2880         do i=1,nres-1
2881           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2882      &     ((ug2(l,k,i),l=1,2),k=1,2),
2883      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2884         enddo
2885         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2886         do i=1,nres-1
2887           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2888      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2889      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2890         enddo
2891         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2892         do i=1,nres-1
2893           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2894      &     costab(i),sintab(i),costab2(i),sintab2(i)
2895         enddo
2896         write (iout,*) "Array MUDER"
2897         do i=1,nres-1
2898           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2899         enddo
2900 c      endif
2901 #endif
2902 #endif
2903 cd      do i=1,nres
2904 cd        iti = itortyp(itype(i))
2905 cd        write (iout,*) i
2906 cd        do j=1,2
2907 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2908 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2909 cd        enddo
2910 cd      enddo
2911       return
2912       end
2913 C--------------------------------------------------------------------------
2914       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2915 C
2916 C This subroutine calculates the average interaction energy and its gradient
2917 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2918 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2919 C The potential depends both on the distance of peptide-group centers and on
2920 C the orientation of the CA-CA virtual bonds.
2921 C
2922       implicit real*8 (a-h,o-z)
2923 #ifdef MPI
2924       include 'mpif.h'
2925 #endif
2926       include 'DIMENSIONS'
2927       include 'COMMON.CONTROL'
2928       include 'COMMON.SETUP'
2929       include 'COMMON.IOUNITS'
2930       include 'COMMON.GEO'
2931       include 'COMMON.VAR'
2932       include 'COMMON.LOCAL'
2933       include 'COMMON.CHAIN'
2934       include 'COMMON.DERIV'
2935       include 'COMMON.INTERACT'
2936       include 'COMMON.CONTACTS'
2937       include 'COMMON.TORSION'
2938       include 'COMMON.VECTORS'
2939       include 'COMMON.FFIELD'
2940       include 'COMMON.TIME1'
2941       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2942      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2943       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2944      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2945       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2946      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2947      &    num_conti,j1,j2
2948 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2949 #ifdef MOMENT
2950       double precision scal_el /1.0d0/
2951 #else
2952       double precision scal_el /0.5d0/
2953 #endif
2954 C 12/13/98
2955 C 13-go grudnia roku pamietnego...
2956       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2957      &                   0.0d0,1.0d0,0.0d0,
2958      &                   0.0d0,0.0d0,1.0d0/
2959 cd      write(iout,*) 'In EELEC'
2960 cd      do i=1,nloctyp
2961 cd        write(iout,*) 'Type',i
2962 cd        write(iout,*) 'B1',B1(:,i)
2963 cd        write(iout,*) 'B2',B2(:,i)
2964 cd        write(iout,*) 'CC',CC(:,:,i)
2965 cd        write(iout,*) 'DD',DD(:,:,i)
2966 cd        write(iout,*) 'EE',EE(:,:,i)
2967 cd      enddo
2968 cd      call check_vecgrad
2969 cd      stop
2970       if (icheckgrad.eq.1) then
2971         do i=1,nres-1
2972           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2973           do k=1,3
2974             dc_norm(k,i)=dc(k,i)*fac
2975           enddo
2976 c          write (iout,*) 'i',i,' fac',fac
2977         enddo
2978       endif
2979       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2980      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2981      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2982 c        call vec_and_deriv
2983 #ifdef TIMING
2984         time01=MPI_Wtime()
2985 #endif
2986         call set_matrices
2987 #ifdef TIMING
2988         time_mat=time_mat+MPI_Wtime()-time01
2989 #endif
2990       endif
2991 cd      do i=1,nres-1
2992 cd        write (iout,*) 'i=',i
2993 cd        do k=1,3
2994 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2995 cd        enddo
2996 cd        do k=1,3
2997 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2998 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2999 cd        enddo
3000 cd      enddo
3001       t_eelecij=0.0d0
3002       ees=0.0D0
3003       evdw1=0.0D0
3004       eel_loc=0.0d0
3005       eello_turn3=0.0d0
3006       eello_turn4=0.0d0
3007       ind=0
3008       do i=1,nres
3009         num_cont_hb(i)=0
3010       enddo
3011 cd      print '(a)','Enter EELEC'
3012 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3013       do i=1,nres
3014         gel_loc_loc(i)=0.0d0
3015         gcorr_loc(i)=0.0d0
3016       enddo
3017 c
3018 c
3019 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3020 C
3021 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3022 C
3023       do i=iturn3_start,iturn3_end
3024         dxi=dc(1,i)
3025         dyi=dc(2,i)
3026         dzi=dc(3,i)
3027         dx_normi=dc_norm(1,i)
3028         dy_normi=dc_norm(2,i)
3029         dz_normi=dc_norm(3,i)
3030         xmedi=c(1,i)+0.5d0*dxi
3031         ymedi=c(2,i)+0.5d0*dyi
3032         zmedi=c(3,i)+0.5d0*dzi
3033         num_conti=0
3034         call eelecij(i,i+2,ees,evdw1,eel_loc)
3035         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3036         num_cont_hb(i)=num_conti
3037       enddo
3038       do i=iturn4_start,iturn4_end
3039         dxi=dc(1,i)
3040         dyi=dc(2,i)
3041         dzi=dc(3,i)
3042         dx_normi=dc_norm(1,i)
3043         dy_normi=dc_norm(2,i)
3044         dz_normi=dc_norm(3,i)
3045         xmedi=c(1,i)+0.5d0*dxi
3046         ymedi=c(2,i)+0.5d0*dyi
3047         zmedi=c(3,i)+0.5d0*dzi
3048         num_conti=num_cont_hb(i)
3049         call eelecij(i,i+3,ees,evdw1,eel_loc)
3050         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3051         num_cont_hb(i)=num_conti
3052       enddo   ! i
3053 c
3054 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3055 c
3056       do i=iatel_s,iatel_e
3057         dxi=dc(1,i)
3058         dyi=dc(2,i)
3059         dzi=dc(3,i)
3060         dx_normi=dc_norm(1,i)
3061         dy_normi=dc_norm(2,i)
3062         dz_normi=dc_norm(3,i)
3063         xmedi=c(1,i)+0.5d0*dxi
3064         ymedi=c(2,i)+0.5d0*dyi
3065         zmedi=c(3,i)+0.5d0*dzi
3066 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3067         num_conti=num_cont_hb(i)
3068         do j=ielstart(i),ielend(i)
3069           call eelecij(i,j,ees,evdw1,eel_loc)
3070         enddo ! j
3071         num_cont_hb(i)=num_conti
3072       enddo   ! i
3073 c      write (iout,*) "Number of loop steps in EELEC:",ind
3074 cd      do i=1,nres
3075 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3076 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3077 cd      enddo
3078 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3079 ccc      eel_loc=eel_loc+eello_turn3
3080 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3081       return
3082       end
3083 C-------------------------------------------------------------------------------
3084       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3085       implicit real*8 (a-h,o-z)
3086       include 'DIMENSIONS'
3087 #ifdef MPI
3088       include "mpif.h"
3089 #endif
3090       include 'COMMON.CONTROL'
3091       include 'COMMON.IOUNITS'
3092       include 'COMMON.GEO'
3093       include 'COMMON.VAR'
3094       include 'COMMON.LOCAL'
3095       include 'COMMON.CHAIN'
3096       include 'COMMON.DERIV'
3097       include 'COMMON.INTERACT'
3098       include 'COMMON.CONTACTS'
3099       include 'COMMON.TORSION'
3100       include 'COMMON.VECTORS'
3101       include 'COMMON.FFIELD'
3102       include 'COMMON.TIME1'
3103       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3104      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3105       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3106      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3107       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3108      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3109      &    num_conti,j1,j2
3110 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3111 #ifdef MOMENT
3112       double precision scal_el /1.0d0/
3113 #else
3114       double precision scal_el /0.5d0/
3115 #endif
3116 C 12/13/98
3117 C 13-go grudnia roku pamietnego...
3118       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3119      &                   0.0d0,1.0d0,0.0d0,
3120      &                   0.0d0,0.0d0,1.0d0/
3121 c          time00=MPI_Wtime()
3122 cd      write (iout,*) "eelecij",i,j
3123 c          ind=ind+1
3124           iteli=itel(i)
3125           itelj=itel(j)
3126           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3127           aaa=app(iteli,itelj)
3128           bbb=bpp(iteli,itelj)
3129           ael6i=ael6(iteli,itelj)
3130           ael3i=ael3(iteli,itelj)
3131           dxj=dc(1,j)
3132           dyj=dc(2,j)
3133           dzj=dc(3,j)
3134           dx_normj=dc_norm(1,j)
3135           dy_normj=dc_norm(2,j)
3136           dz_normj=dc_norm(3,j)
3137           xj=c(1,j)+0.5D0*dxj-xmedi
3138           yj=c(2,j)+0.5D0*dyj-ymedi
3139           zj=c(3,j)+0.5D0*dzj-zmedi
3140           rij=xj*xj+yj*yj+zj*zj
3141           rrmij=1.0D0/rij
3142           rij=dsqrt(rij)
3143           rmij=1.0D0/rij
3144           r3ij=rrmij*rmij
3145           r6ij=r3ij*r3ij
3146           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3147           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3148           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3149           fac=cosa-3.0D0*cosb*cosg
3150           ev1=aaa*r6ij*r6ij
3151 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3152           if (j.eq.i+2) ev1=scal_el*ev1
3153           ev2=bbb*r6ij
3154           fac3=ael6i*r6ij
3155           fac4=ael3i*r3ij
3156           evdwij=ev1+ev2
3157           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3158           el2=fac4*fac
3159           eesij=el1+el2
3160 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3161           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3162           ees=ees+eesij
3163           evdw1=evdw1+evdwij
3164 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3165 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3166 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3167 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3168
3169           if (energy_dec) then
3170               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3171               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3172           endif
3173
3174 C
3175 C Calculate contributions to the Cartesian gradient.
3176 C
3177 #ifdef SPLITELE
3178           facvdw=-6*rrmij*(ev1+evdwij)
3179           facel=-3*rrmij*(el1+eesij)
3180           fac1=fac
3181           erij(1)=xj*rmij
3182           erij(2)=yj*rmij
3183           erij(3)=zj*rmij
3184 *
3185 * Radial derivatives. First process both termini of the fragment (i,j)
3186 *
3187           ggg(1)=facel*xj
3188           ggg(2)=facel*yj
3189           ggg(3)=facel*zj
3190 c          do k=1,3
3191 c            ghalf=0.5D0*ggg(k)
3192 c            gelc(k,i)=gelc(k,i)+ghalf
3193 c            gelc(k,j)=gelc(k,j)+ghalf
3194 c          enddo
3195 c 9/28/08 AL Gradient compotents will be summed only at the end
3196           do k=1,3
3197             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3198             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3199           enddo
3200 *
3201 * Loop over residues i+1 thru j-1.
3202 *
3203 cgrad          do k=i+1,j-1
3204 cgrad            do l=1,3
3205 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3206 cgrad            enddo
3207 cgrad          enddo
3208           ggg(1)=facvdw*xj
3209           ggg(2)=facvdw*yj
3210           ggg(3)=facvdw*zj
3211 c          do k=1,3
3212 c            ghalf=0.5D0*ggg(k)
3213 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3214 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3215 c          enddo
3216 c 9/28/08 AL Gradient compotents will be summed only at the end
3217           do k=1,3
3218             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3219             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3220           enddo
3221 *
3222 * Loop over residues i+1 thru j-1.
3223 *
3224 cgrad          do k=i+1,j-1
3225 cgrad            do l=1,3
3226 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3227 cgrad            enddo
3228 cgrad          enddo
3229 #else
3230           facvdw=ev1+evdwij
3231           facel=el1+eesij
3232           fac1=fac
3233           fac=-3*rrmij*(facvdw+facvdw+facel)
3234           erij(1)=xj*rmij
3235           erij(2)=yj*rmij
3236           erij(3)=zj*rmij
3237 *
3238 * Radial derivatives. First process both termini of the fragment (i,j)
3239 *
3240           ggg(1)=fac*xj
3241           ggg(2)=fac*yj
3242           ggg(3)=fac*zj
3243 c          do k=1,3
3244 c            ghalf=0.5D0*ggg(k)
3245 c            gelc(k,i)=gelc(k,i)+ghalf
3246 c            gelc(k,j)=gelc(k,j)+ghalf
3247 c          enddo
3248 c 9/28/08 AL Gradient compotents will be summed only at the end
3249           do k=1,3
3250             gelc_long(k,j)=gelc(k,j)+ggg(k)
3251             gelc_long(k,i)=gelc(k,i)-ggg(k)
3252           enddo
3253 *
3254 * Loop over residues i+1 thru j-1.
3255 *
3256 cgrad          do k=i+1,j-1
3257 cgrad            do l=1,3
3258 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3259 cgrad            enddo
3260 cgrad          enddo
3261 c 9/28/08 AL Gradient compotents will be summed only at the end
3262           ggg(1)=facvdw*xj
3263           ggg(2)=facvdw*yj
3264           ggg(3)=facvdw*zj
3265           do k=1,3
3266             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3267             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3268           enddo
3269 #endif
3270 *
3271 * Angular part
3272 *
3273           ecosa=2.0D0*fac3*fac1+fac4
3274           fac4=-3.0D0*fac4
3275           fac3=-6.0D0*fac3
3276           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3277           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3278           do k=1,3
3279             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3280             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3281           enddo
3282 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3283 cd   &          (dcosg(k),k=1,3)
3284           do k=1,3
3285             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3286           enddo
3287 c          do k=1,3
3288 c            ghalf=0.5D0*ggg(k)
3289 c            gelc(k,i)=gelc(k,i)+ghalf
3290 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3291 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3292 c            gelc(k,j)=gelc(k,j)+ghalf
3293 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3294 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3295 c          enddo
3296 cgrad          do k=i+1,j-1
3297 cgrad            do l=1,3
3298 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3299 cgrad            enddo
3300 cgrad          enddo
3301           do k=1,3
3302             gelc(k,i)=gelc(k,i)
3303      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3304      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3305             gelc(k,j)=gelc(k,j)
3306      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3307      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3308             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3309             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3310           enddo
3311           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3312      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3313      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3314 C
3315 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3316 C   energy of a peptide unit is assumed in the form of a second-order
3317 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3318 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3319 C   are computed for EVERY pair of non-contiguous peptide groups.
3320 C
3321           if (j.lt.nres-1) then
3322             j1=j+1
3323             j2=j-1
3324           else
3325             j1=j-1
3326             j2=j-2
3327           endif
3328           kkk=0
3329           do k=1,2
3330             do l=1,2
3331               kkk=kkk+1
3332               muij(kkk)=mu(k,i)*mu(l,j)
3333             enddo
3334           enddo
3335 cd         write (iout,*) 'EELEC: i',i,' j',j
3336 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3337 cd          write(iout,*) 'muij',muij
3338           ury=scalar(uy(1,i),erij)
3339           urz=scalar(uz(1,i),erij)
3340           vry=scalar(uy(1,j),erij)
3341           vrz=scalar(uz(1,j),erij)
3342           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3343           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3344           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3345           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3346           fac=dsqrt(-ael6i)*r3ij
3347           a22=a22*fac
3348           a23=a23*fac
3349           a32=a32*fac
3350           a33=a33*fac
3351 cd          write (iout,'(4i5,4f10.5)')
3352 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3353 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3354 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3355 cd     &      uy(:,j),uz(:,j)
3356 cd          write (iout,'(4f10.5)')
3357 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3358 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3359 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3360 cd           write (iout,'(9f10.5/)')
3361 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3362 C Derivatives of the elements of A in virtual-bond vectors
3363           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3364           do k=1,3
3365             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3366             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3367             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3368             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3369             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3370             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3371             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3372             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3373             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3374             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3375             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3376             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3377           enddo
3378 C Compute radial contributions to the gradient
3379           facr=-3.0d0*rrmij
3380           a22der=a22*facr
3381           a23der=a23*facr
3382           a32der=a32*facr
3383           a33der=a33*facr
3384           agg(1,1)=a22der*xj
3385           agg(2,1)=a22der*yj
3386           agg(3,1)=a22der*zj
3387           agg(1,2)=a23der*xj
3388           agg(2,2)=a23der*yj
3389           agg(3,2)=a23der*zj
3390           agg(1,3)=a32der*xj
3391           agg(2,3)=a32der*yj
3392           agg(3,3)=a32der*zj
3393           agg(1,4)=a33der*xj
3394           agg(2,4)=a33der*yj
3395           agg(3,4)=a33der*zj
3396 C Add the contributions coming from er
3397           fac3=-3.0d0*fac
3398           do k=1,3
3399             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3400             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3401             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3402             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3403           enddo
3404           do k=1,3
3405 C Derivatives in DC(i)
3406 cgrad            ghalf1=0.5d0*agg(k,1)
3407 cgrad            ghalf2=0.5d0*agg(k,2)
3408 cgrad            ghalf3=0.5d0*agg(k,3)
3409 cgrad            ghalf4=0.5d0*agg(k,4)
3410             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3411      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3412             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3413      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3414             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3415      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3416             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3417      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3418 C Derivatives in DC(i+1)
3419             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3420      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3421             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3422      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3423             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3424      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3425             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3426      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3427 C Derivatives in DC(j)
3428             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3429      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3430             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3431      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3432             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3433      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3434             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3435      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3436 C Derivatives in DC(j+1) or DC(nres-1)
3437             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3438      &      -3.0d0*vryg(k,3)*ury)
3439             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3440      &      -3.0d0*vrzg(k,3)*ury)
3441             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3442      &      -3.0d0*vryg(k,3)*urz)
3443             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3444      &      -3.0d0*vrzg(k,3)*urz)
3445 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3446 cgrad              do l=1,4
3447 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3448 cgrad              enddo
3449 cgrad            endif
3450           enddo
3451           acipa(1,1)=a22
3452           acipa(1,2)=a23
3453           acipa(2,1)=a32
3454           acipa(2,2)=a33
3455           a22=-a22
3456           a23=-a23
3457           do l=1,2
3458             do k=1,3
3459               agg(k,l)=-agg(k,l)
3460               aggi(k,l)=-aggi(k,l)
3461               aggi1(k,l)=-aggi1(k,l)
3462               aggj(k,l)=-aggj(k,l)
3463               aggj1(k,l)=-aggj1(k,l)
3464             enddo
3465           enddo
3466           if (j.lt.nres-1) then
3467             a22=-a22
3468             a32=-a32
3469             do l=1,3,2
3470               do k=1,3
3471                 agg(k,l)=-agg(k,l)
3472                 aggi(k,l)=-aggi(k,l)
3473                 aggi1(k,l)=-aggi1(k,l)
3474                 aggj(k,l)=-aggj(k,l)
3475                 aggj1(k,l)=-aggj1(k,l)
3476               enddo
3477             enddo
3478           else
3479             a22=-a22
3480             a23=-a23
3481             a32=-a32
3482             a33=-a33
3483             do l=1,4
3484               do k=1,3
3485                 agg(k,l)=-agg(k,l)
3486                 aggi(k,l)=-aggi(k,l)
3487                 aggi1(k,l)=-aggi1(k,l)
3488                 aggj(k,l)=-aggj(k,l)
3489                 aggj1(k,l)=-aggj1(k,l)
3490               enddo
3491             enddo
3492           endif
3493           ENDIF ! WCORR
3494           IF (wel_loc.gt.0.0d0) THEN
3495 C Contribution to the local-electrostatic energy coming from the i-j pair
3496           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3497      &     +a33*muij(4)
3498 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3499
3500           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3501      &            'eelloc',i,j,eel_loc_ij
3502
3503           eel_loc=eel_loc+eel_loc_ij
3504 C Partial derivatives in virtual-bond dihedral angles gamma
3505           if (i.gt.1)
3506      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3507      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3508      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3509           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3510      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3511      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3512 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3513           do l=1,3
3514             ggg(l)=agg(l,1)*muij(1)+
3515      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3516             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3517             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3518 cgrad            ghalf=0.5d0*ggg(l)
3519 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3520 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3521           enddo
3522 cgrad          do k=i+1,j2
3523 cgrad            do l=1,3
3524 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3525 cgrad            enddo
3526 cgrad          enddo
3527 C Remaining derivatives of eello
3528           do l=1,3
3529             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3530      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3531             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3532      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3533             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3534      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3535             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3536      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3537           enddo
3538           ENDIF
3539 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3540 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3541           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3542      &       .and. num_conti.le.maxconts) then
3543 c            write (iout,*) i,j," entered corr"
3544 C
3545 C Calculate the contact function. The ith column of the array JCONT will
3546 C contain the numbers of atoms that make contacts with the atom I (of numbers
3547 C greater than I). The arrays FACONT and GACONT will contain the values of
3548 C the contact function and its derivative.
3549 c           r0ij=1.02D0*rpp(iteli,itelj)
3550 c           r0ij=1.11D0*rpp(iteli,itelj)
3551             r0ij=2.20D0*rpp(iteli,itelj)
3552 c           r0ij=1.55D0*rpp(iteli,itelj)
3553             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3554             if (fcont.gt.0.0D0) then
3555               num_conti=num_conti+1
3556               if (num_conti.gt.maxconts) then
3557                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3558      &                         ' will skip next contacts for this conf.'
3559               else
3560                 jcont_hb(num_conti,i)=j
3561 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3562 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3563                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3564      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3565 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3566 C  terms.
3567                 d_cont(num_conti,i)=rij
3568 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3569 C     --- Electrostatic-interaction matrix ---
3570                 a_chuj(1,1,num_conti,i)=a22
3571                 a_chuj(1,2,num_conti,i)=a23
3572                 a_chuj(2,1,num_conti,i)=a32
3573                 a_chuj(2,2,num_conti,i)=a33
3574 C     --- Gradient of rij
3575                 do kkk=1,3
3576                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3577                 enddo
3578                 kkll=0
3579                 do k=1,2
3580                   do l=1,2
3581                     kkll=kkll+1
3582                     do m=1,3
3583                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3584                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3585                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3586                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3587                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3588                     enddo
3589                   enddo
3590                 enddo
3591                 ENDIF
3592                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3593 C Calculate contact energies
3594                 cosa4=4.0D0*cosa
3595                 wij=cosa-3.0D0*cosb*cosg
3596                 cosbg1=cosb+cosg
3597                 cosbg2=cosb-cosg
3598 c               fac3=dsqrt(-ael6i)/r0ij**3
3599                 fac3=dsqrt(-ael6i)*r3ij
3600 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3601                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3602                 if (ees0tmp.gt.0) then
3603                   ees0pij=dsqrt(ees0tmp)
3604                 else
3605                   ees0pij=0
3606                 endif
3607 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3608                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3609                 if (ees0tmp.gt.0) then
3610                   ees0mij=dsqrt(ees0tmp)
3611                 else
3612                   ees0mij=0
3613                 endif
3614 c               ees0mij=0.0D0
3615                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3616                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3617 C Diagnostics. Comment out or remove after debugging!
3618 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3619 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3620 c               ees0m(num_conti,i)=0.0D0
3621 C End diagnostics.
3622 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3623 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3624 C Angular derivatives of the contact function
3625                 ees0pij1=fac3/ees0pij
3626                 ees0mij1=fac3/ees0mij
3627                 fac3p=-3.0D0*fac3*rrmij
3628                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3629                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3630 c               ees0mij1=0.0D0
3631                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3632                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3633                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3634                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3635                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3636                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3637                 ecosap=ecosa1+ecosa2
3638                 ecosbp=ecosb1+ecosb2
3639                 ecosgp=ecosg1+ecosg2
3640                 ecosam=ecosa1-ecosa2
3641                 ecosbm=ecosb1-ecosb2
3642                 ecosgm=ecosg1-ecosg2
3643 C Diagnostics
3644 c               ecosap=ecosa1
3645 c               ecosbp=ecosb1
3646 c               ecosgp=ecosg1
3647 c               ecosam=0.0D0
3648 c               ecosbm=0.0D0
3649 c               ecosgm=0.0D0
3650 C End diagnostics
3651                 facont_hb(num_conti,i)=fcont
3652                 fprimcont=fprimcont/rij
3653 cd              facont_hb(num_conti,i)=1.0D0
3654 C Following line is for diagnostics.
3655 cd              fprimcont=0.0D0
3656                 do k=1,3
3657                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3658                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3659                 enddo
3660                 do k=1,3
3661                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3662                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3663                 enddo
3664                 gggp(1)=gggp(1)+ees0pijp*xj
3665                 gggp(2)=gggp(2)+ees0pijp*yj
3666                 gggp(3)=gggp(3)+ees0pijp*zj
3667                 gggm(1)=gggm(1)+ees0mijp*xj
3668                 gggm(2)=gggm(2)+ees0mijp*yj
3669                 gggm(3)=gggm(3)+ees0mijp*zj
3670 C Derivatives due to the contact function
3671                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3672                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3673                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3674                 do k=1,3
3675 c
3676 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3677 c          following the change of gradient-summation algorithm.
3678 c
3679 cgrad                  ghalfp=0.5D0*gggp(k)
3680 cgrad                  ghalfm=0.5D0*gggm(k)
3681                   gacontp_hb1(k,num_conti,i)=!ghalfp
3682      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3683      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3684                   gacontp_hb2(k,num_conti,i)=!ghalfp
3685      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3686      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3687                   gacontp_hb3(k,num_conti,i)=gggp(k)
3688                   gacontm_hb1(k,num_conti,i)=!ghalfm
3689      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3690      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3691                   gacontm_hb2(k,num_conti,i)=!ghalfm
3692      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3693      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3694                   gacontm_hb3(k,num_conti,i)=gggm(k)
3695                 enddo
3696 C Diagnostics. Comment out or remove after debugging!
3697 cdiag           do k=1,3
3698 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3699 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3700 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3701 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3702 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3703 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3704 cdiag           enddo
3705               ENDIF ! wcorr
3706               endif  ! num_conti.le.maxconts
3707             endif  ! fcont.gt.0
3708           endif    ! j.gt.i+1
3709           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3710             do k=1,4
3711               do l=1,3
3712                 ghalf=0.5d0*agg(l,k)
3713                 aggi(l,k)=aggi(l,k)+ghalf
3714                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3715                 aggj(l,k)=aggj(l,k)+ghalf
3716               enddo
3717             enddo
3718             if (j.eq.nres-1 .and. i.lt.j-2) then
3719               do k=1,4
3720                 do l=1,3
3721                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3722                 enddo
3723               enddo
3724             endif
3725           endif
3726 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3727       return
3728       end
3729 C-----------------------------------------------------------------------------
3730       subroutine eturn3(i,eello_turn3)
3731 C Third- and fourth-order contributions from turns
3732       implicit real*8 (a-h,o-z)
3733       include 'DIMENSIONS'
3734       include 'COMMON.IOUNITS'
3735       include 'COMMON.GEO'
3736       include 'COMMON.VAR'
3737       include 'COMMON.LOCAL'
3738       include 'COMMON.CHAIN'
3739       include 'COMMON.DERIV'
3740       include 'COMMON.INTERACT'
3741       include 'COMMON.CONTACTS'
3742       include 'COMMON.TORSION'
3743       include 'COMMON.VECTORS'
3744       include 'COMMON.FFIELD'
3745       include 'COMMON.CONTROL'
3746       dimension ggg(3)
3747       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3748      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3749      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3750       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3751      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3752       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3753      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3754      &    num_conti,j1,j2
3755       j=i+2
3756 c      write (iout,*) "eturn3",i,j,j1,j2
3757       a_temp(1,1)=a22
3758       a_temp(1,2)=a23
3759       a_temp(2,1)=a32
3760       a_temp(2,2)=a33
3761 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3762 C
3763 C               Third-order contributions
3764 C
3765 C                 (i+2)o----(i+3)
3766 C                      | |
3767 C                      | |
3768 C                 (i+1)o----i
3769 C
3770 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3771 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3772         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3773         call transpose2(auxmat(1,1),auxmat1(1,1))
3774         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3775         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3776         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3777      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3778 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3779 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3780 cd     &    ' eello_turn3_num',4*eello_turn3_num
3781 C Derivatives in gamma(i)
3782         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3783         call transpose2(auxmat2(1,1),auxmat3(1,1))
3784         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3785         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3786 C Derivatives in gamma(i+1)
3787         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3788         call transpose2(auxmat2(1,1),auxmat3(1,1))
3789         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3790         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3791      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3792 C Cartesian derivatives
3793         do l=1,3
3794 c            ghalf1=0.5d0*agg(l,1)
3795 c            ghalf2=0.5d0*agg(l,2)
3796 c            ghalf3=0.5d0*agg(l,3)
3797 c            ghalf4=0.5d0*agg(l,4)
3798           a_temp(1,1)=aggi(l,1)!+ghalf1
3799           a_temp(1,2)=aggi(l,2)!+ghalf2
3800           a_temp(2,1)=aggi(l,3)!+ghalf3
3801           a_temp(2,2)=aggi(l,4)!+ghalf4
3802           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3803           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3804      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3805           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3806           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3807           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3808           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3809           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3810           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3811      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3812           a_temp(1,1)=aggj(l,1)!+ghalf1
3813           a_temp(1,2)=aggj(l,2)!+ghalf2
3814           a_temp(2,1)=aggj(l,3)!+ghalf3
3815           a_temp(2,2)=aggj(l,4)!+ghalf4
3816           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3817           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3818      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3819           a_temp(1,1)=aggj1(l,1)
3820           a_temp(1,2)=aggj1(l,2)
3821           a_temp(2,1)=aggj1(l,3)
3822           a_temp(2,2)=aggj1(l,4)
3823           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3824           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3825      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3826         enddo
3827       return
3828       end
3829 C-------------------------------------------------------------------------------
3830       subroutine eturn4(i,eello_turn4)
3831 C Third- and fourth-order contributions from turns
3832       implicit real*8 (a-h,o-z)
3833       include 'DIMENSIONS'
3834       include 'COMMON.IOUNITS'
3835       include 'COMMON.GEO'
3836       include 'COMMON.VAR'
3837       include 'COMMON.LOCAL'
3838       include 'COMMON.CHAIN'
3839       include 'COMMON.DERIV'
3840       include 'COMMON.INTERACT'
3841       include 'COMMON.CONTACTS'
3842       include 'COMMON.TORSION'
3843       include 'COMMON.VECTORS'
3844       include 'COMMON.FFIELD'
3845       include 'COMMON.CONTROL'
3846       dimension ggg(3)
3847       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3848      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3849      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3850       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3851      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3852       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3853      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3854      &    num_conti,j1,j2
3855       j=i+3
3856 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3857 C
3858 C               Fourth-order contributions
3859 C
3860 C                 (i+3)o----(i+4)
3861 C                     /  |
3862 C               (i+2)o   |
3863 C                     \  |
3864 C                 (i+1)o----i
3865 C
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3867 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3868 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3869         a_temp(1,1)=a22
3870         a_temp(1,2)=a23
3871         a_temp(2,1)=a32
3872         a_temp(2,2)=a33
3873         iti1=itortyp(itype(i+1))
3874         iti2=itortyp(itype(i+2))
3875         iti3=itortyp(itype(i+3))
3876 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3877         call transpose2(EUg(1,1,i+1),e1t(1,1))
3878         call transpose2(Eug(1,1,i+2),e2t(1,1))
3879         call transpose2(Eug(1,1,i+3),e3t(1,1))
3880         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3881         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3882         s1=scalar2(b1(1,iti2),auxvec(1))
3883         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3884         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3885         s2=scalar2(b1(1,iti1),auxvec(1))
3886         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3887         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3888         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3889         eello_turn4=eello_turn4-(s1+s2+s3)
3890         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3891      &      'eturn4',i,j,-(s1+s2+s3)
3892 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3893 cd     &    ' eello_turn4_num',8*eello_turn4_num
3894 C Derivatives in gamma(i)
3895         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3896         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3897         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3898         s1=scalar2(b1(1,iti2),auxvec(1))
3899         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3902 C Derivatives in gamma(i+1)
3903         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3904         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3905         s2=scalar2(b1(1,iti1),auxvec(1))
3906         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3907         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3908         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3909         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3910 C Derivatives in gamma(i+2)
3911         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3912         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3913         s1=scalar2(b1(1,iti2),auxvec(1))
3914         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3915         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3916         s2=scalar2(b1(1,iti1),auxvec(1))
3917         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3918         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3919         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3920         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3921 C Cartesian derivatives
3922 C Derivatives of this turn contributions in DC(i+2)
3923         if (j.lt.nres-1) then
3924           do l=1,3
3925             a_temp(1,1)=agg(l,1)
3926             a_temp(1,2)=agg(l,2)
3927             a_temp(2,1)=agg(l,3)
3928             a_temp(2,2)=agg(l,4)
3929             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3930             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3931             s1=scalar2(b1(1,iti2),auxvec(1))
3932             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3933             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3934             s2=scalar2(b1(1,iti1),auxvec(1))
3935             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3936             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3937             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3938             ggg(l)=-(s1+s2+s3)
3939             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3940           enddo
3941         endif
3942 C Remaining derivatives of this turn contribution
3943         do l=1,3
3944           a_temp(1,1)=aggi(l,1)
3945           a_temp(1,2)=aggi(l,2)
3946           a_temp(2,1)=aggi(l,3)
3947           a_temp(2,2)=aggi(l,4)
3948           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3949           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3950           s1=scalar2(b1(1,iti2),auxvec(1))
3951           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3952           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3953           s2=scalar2(b1(1,iti1),auxvec(1))
3954           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3955           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3956           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3957           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3958           a_temp(1,1)=aggi1(l,1)
3959           a_temp(1,2)=aggi1(l,2)
3960           a_temp(2,1)=aggi1(l,3)
3961           a_temp(2,2)=aggi1(l,4)
3962           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3963           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3964           s1=scalar2(b1(1,iti2),auxvec(1))
3965           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3966           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3967           s2=scalar2(b1(1,iti1),auxvec(1))
3968           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3969           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3970           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3971           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3972           a_temp(1,1)=aggj(l,1)
3973           a_temp(1,2)=aggj(l,2)
3974           a_temp(2,1)=aggj(l,3)
3975           a_temp(2,2)=aggj(l,4)
3976           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3977           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3978           s1=scalar2(b1(1,iti2),auxvec(1))
3979           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3980           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3981           s2=scalar2(b1(1,iti1),auxvec(1))
3982           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3983           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3984           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3985           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3986           a_temp(1,1)=aggj1(l,1)
3987           a_temp(1,2)=aggj1(l,2)
3988           a_temp(2,1)=aggj1(l,3)
3989           a_temp(2,2)=aggj1(l,4)
3990           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3991           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3992           s1=scalar2(b1(1,iti2),auxvec(1))
3993           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3994           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3995           s2=scalar2(b1(1,iti1),auxvec(1))
3996           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3997           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3998           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3999 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4000           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4001         enddo
4002       return
4003       end
4004 C-----------------------------------------------------------------------------
4005       subroutine vecpr(u,v,w)
4006       implicit real*8(a-h,o-z)
4007       dimension u(3),v(3),w(3)
4008       w(1)=u(2)*v(3)-u(3)*v(2)
4009       w(2)=-u(1)*v(3)+u(3)*v(1)
4010       w(3)=u(1)*v(2)-u(2)*v(1)
4011       return
4012       end
4013 C-----------------------------------------------------------------------------
4014       subroutine unormderiv(u,ugrad,unorm,ungrad)
4015 C This subroutine computes the derivatives of a normalized vector u, given
4016 C the derivatives computed without normalization conditions, ugrad. Returns
4017 C ungrad.
4018       implicit none
4019       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4020       double precision vec(3)
4021       double precision scalar
4022       integer i,j
4023 c      write (2,*) 'ugrad',ugrad
4024 c      write (2,*) 'u',u
4025       do i=1,3
4026         vec(i)=scalar(ugrad(1,i),u(1))
4027       enddo
4028 c      write (2,*) 'vec',vec
4029       do i=1,3
4030         do j=1,3
4031           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4032         enddo
4033       enddo
4034 c      write (2,*) 'ungrad',ungrad
4035       return
4036       end
4037 C-----------------------------------------------------------------------------
4038       subroutine escp_soft_sphere(evdw2,evdw2_14)
4039 C
4040 C This subroutine calculates the excluded-volume interaction energy between
4041 C peptide-group centers and side chains and its gradient in virtual-bond and
4042 C side-chain vectors.
4043 C
4044       implicit real*8 (a-h,o-z)
4045       include 'DIMENSIONS'
4046       include 'COMMON.GEO'
4047       include 'COMMON.VAR'
4048       include 'COMMON.LOCAL'
4049       include 'COMMON.CHAIN'
4050       include 'COMMON.DERIV'
4051       include 'COMMON.INTERACT'
4052       include 'COMMON.FFIELD'
4053       include 'COMMON.IOUNITS'
4054       include 'COMMON.CONTROL'
4055       dimension ggg(3)
4056       evdw2=0.0D0
4057       evdw2_14=0.0d0
4058       r0_scp=4.5d0
4059 cd    print '(a)','Enter ESCP'
4060 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4061       do i=iatscp_s,iatscp_e
4062         iteli=itel(i)
4063         xi=0.5D0*(c(1,i)+c(1,i+1))
4064         yi=0.5D0*(c(2,i)+c(2,i+1))
4065         zi=0.5D0*(c(3,i)+c(3,i+1))
4066
4067         do iint=1,nscp_gr(i)
4068
4069         do j=iscpstart(i,iint),iscpend(i,iint)
4070           itypj=itype(j)
4071 C Uncomment following three lines for SC-p interactions
4072 c         xj=c(1,nres+j)-xi
4073 c         yj=c(2,nres+j)-yi
4074 c         zj=c(3,nres+j)-zi
4075 C Uncomment following three lines for Ca-p interactions
4076           xj=c(1,j)-xi
4077           yj=c(2,j)-yi
4078           zj=c(3,j)-zi
4079           rij=xj*xj+yj*yj+zj*zj
4080           r0ij=r0_scp
4081           r0ijsq=r0ij*r0ij
4082           if (rij.lt.r0ijsq) then
4083             evdwij=0.25d0*(rij-r0ijsq)**2
4084             fac=rij-r0ijsq
4085           else
4086             evdwij=0.0d0
4087             fac=0.0d0
4088           endif
4089           evdw2=evdw2+evdwij
4090 C
4091 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4092 C
4093           ggg(1)=xj*fac
4094           ggg(2)=yj*fac
4095           ggg(3)=zj*fac
4096 cgrad          if (j.lt.i) then
4097 cd          write (iout,*) 'j<i'
4098 C Uncomment following three lines for SC-p interactions
4099 c           do k=1,3
4100 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4101 c           enddo
4102 cgrad          else
4103 cd          write (iout,*) 'j>i'
4104 cgrad            do k=1,3
4105 cgrad              ggg(k)=-ggg(k)
4106 C Uncomment following line for SC-p interactions
4107 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4108 cgrad            enddo
4109 cgrad          endif
4110 cgrad          do k=1,3
4111 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4112 cgrad          enddo
4113 cgrad          kstart=min0(i+1,j)
4114 cgrad          kend=max0(i-1,j-1)
4115 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4116 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4117 cgrad          do k=kstart,kend
4118 cgrad            do l=1,3
4119 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4120 cgrad            enddo
4121 cgrad          enddo
4122           do k=1,3
4123             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4124             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4125           enddo
4126         enddo
4127
4128         enddo ! iint
4129       enddo ! i
4130       return
4131       end
4132 C-----------------------------------------------------------------------------
4133       subroutine escp(evdw2,evdw2_14)
4134 C
4135 C This subroutine calculates the excluded-volume interaction energy between
4136 C peptide-group centers and side chains and its gradient in virtual-bond and
4137 C side-chain vectors.
4138 C
4139       implicit real*8 (a-h,o-z)
4140       include 'DIMENSIONS'
4141       include 'COMMON.GEO'
4142       include 'COMMON.VAR'
4143       include 'COMMON.LOCAL'
4144       include 'COMMON.CHAIN'
4145       include 'COMMON.DERIV'
4146       include 'COMMON.INTERACT'
4147       include 'COMMON.FFIELD'
4148       include 'COMMON.IOUNITS'
4149       include 'COMMON.CONTROL'
4150       dimension ggg(3)
4151       evdw2=0.0D0
4152       evdw2_14=0.0d0
4153 cd    print '(a)','Enter ESCP'
4154 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4155       do i=iatscp_s,iatscp_e
4156         iteli=itel(i)
4157         xi=0.5D0*(c(1,i)+c(1,i+1))
4158         yi=0.5D0*(c(2,i)+c(2,i+1))
4159         zi=0.5D0*(c(3,i)+c(3,i+1))
4160
4161         do iint=1,nscp_gr(i)
4162
4163         do j=iscpstart(i,iint),iscpend(i,iint)
4164           itypj=itype(j)
4165 C Uncomment following three lines for SC-p interactions
4166 c         xj=c(1,nres+j)-xi
4167 c         yj=c(2,nres+j)-yi
4168 c         zj=c(3,nres+j)-zi
4169 C Uncomment following three lines for Ca-p interactions
4170           xj=c(1,j)-xi
4171           yj=c(2,j)-yi
4172           zj=c(3,j)-zi
4173           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4174           fac=rrij**expon2
4175           e1=fac*fac*aad(itypj,iteli)
4176           e2=fac*bad(itypj,iteli)
4177           if (iabs(j-i) .le. 2) then
4178             e1=scal14*e1
4179             e2=scal14*e2
4180             evdw2_14=evdw2_14+e1+e2
4181           endif
4182           evdwij=e1+e2
4183           evdw2=evdw2+evdwij
4184           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4185      &        'evdw2',i,j,evdwij
4186 C
4187 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4188 C
4189           fac=-(evdwij+e1)*rrij
4190           ggg(1)=xj*fac
4191           ggg(2)=yj*fac
4192           ggg(3)=zj*fac
4193 cgrad          if (j.lt.i) then
4194 cd          write (iout,*) 'j<i'
4195 C Uncomment following three lines for SC-p interactions
4196 c           do k=1,3
4197 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4198 c           enddo
4199 cgrad          else
4200 cd          write (iout,*) 'j>i'
4201 cgrad            do k=1,3
4202 cgrad              ggg(k)=-ggg(k)
4203 C Uncomment following line for SC-p interactions
4204 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4205 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4206 cgrad            enddo
4207 cgrad          endif
4208 cgrad          do k=1,3
4209 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4210 cgrad          enddo
4211 cgrad          kstart=min0(i+1,j)
4212 cgrad          kend=max0(i-1,j-1)
4213 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4214 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4215 cgrad          do k=kstart,kend
4216 cgrad            do l=1,3
4217 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4218 cgrad            enddo
4219 cgrad          enddo
4220           do k=1,3
4221             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4222             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4223           enddo
4224         enddo
4225
4226         enddo ! iint
4227       enddo ! i
4228       do i=1,nct
4229         do j=1,3
4230           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4231           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4232           gradx_scp(j,i)=expon*gradx_scp(j,i)
4233         enddo
4234       enddo
4235 C******************************************************************************
4236 C
4237 C                              N O T E !!!
4238 C
4239 C To save time the factor EXPON has been extracted from ALL components
4240 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4241 C use!
4242 C
4243 C******************************************************************************
4244       return
4245       end
4246 C--------------------------------------------------------------------------
4247       subroutine edis(ehpb)
4248 C
4249 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4250 C
4251       implicit real*8 (a-h,o-z)
4252       include 'DIMENSIONS'
4253       include 'COMMON.SBRIDGE'
4254       include 'COMMON.CHAIN'
4255       include 'COMMON.DERIV'
4256       include 'COMMON.VAR'
4257       include 'COMMON.INTERACT'
4258       include 'COMMON.IOUNITS'
4259       dimension ggg(3)
4260       ehpb=0.0D0
4261 c      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4262 c      write(iout,*)'link_start=',link_start,' link_end=',link_end
4263       if (link_end.eq.0) return
4264       do i=link_start,link_end
4265 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4266 C CA-CA distance used in regularization of structure.
4267         ii=ihpb(i)
4268         jj=jhpb(i)
4269 C iii and jjj point to the residues for which the distance is assigned.
4270         if (ii.gt.nres) then
4271           iii=ii-nres
4272           jjj=jj-nres
4273         else
4274           iii=ii
4275           jjj=jj
4276         endif
4277 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4278 c     &    dhpb(i),dhpb1(i),forcon(i)
4279 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4280 C    distance and angle dependent SS bond potential.
4281 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4282 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4283 c          if (.not.dyn_ss .and. i.le.nss) then
4284 C 15/02/13 CC dynamic SSbond
4285         if (.not.dyn_ss.and.
4286      &   ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4287           call ssbond_ene(iii,jjj,eij)
4288           ehpb=ehpb+2*eij
4289 c          write (iout,*) "eij",eij
4290         else if (ii.gt.nres .and. jj.gt.nres) then
4291 c Restraints from contact prediction
4292           dd=dist(ii,jj)
4293           if (dhpb1(i).gt.0.0d0) then
4294             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4295             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4296 c            write (iout,*) "beta nmr",
4297 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4298           else
4299             dd=dist(ii,jj)
4300             rdis=dd-dhpb(i)
4301 C Get the force constant corresponding to this distance.
4302             waga=forcon(i)
4303 C Calculate the contribution to energy.
4304             ehpb=ehpb+waga*rdis*rdis
4305 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4306 C
4307 C Evaluate gradient.
4308 C
4309             fac=waga*rdis/dd
4310           endif
4311           do j=1,3
4312             ggg(j)=fac*(c(j,jj)-c(j,ii))
4313           enddo
4314           do j=1,3
4315             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4316             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4317           enddo
4318           do k=1,3
4319             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4320             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4321           enddo
4322         else
4323 C Calculate the distance between the two points and its difference from the
4324 C target distance.
4325           dd=dist(ii,jj)
4326           if (dhpb1(i).gt.0.0d0) then
4327             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4328             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4329 c            write (iout,*) "alph nmr",
4330 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4331           else
4332             rdis=dd-dhpb(i)
4333 C Get the force constant corresponding to this distance.
4334             waga=forcon(i)
4335 C Calculate the contribution to energy.
4336             ehpb=ehpb+waga*rdis*rdis
4337 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4338 C
4339 C Evaluate gradient.
4340 C
4341             fac=waga*rdis/dd
4342           endif
4343 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4344 cd   &   ' waga=',waga,' fac=',fac
4345             do j=1,3
4346               ggg(j)=fac*(c(j,jj)-c(j,ii))
4347             enddo
4348 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4349 C If this is a SC-SC distance, we need to calculate the contributions to the
4350 C Cartesian gradient in the SC vectors (ghpbx).
4351           if (iii.lt.ii) then
4352           do j=1,3
4353             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4354             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4355           enddo
4356           endif
4357 cgrad        do j=iii,jjj-1
4358 cgrad          do k=1,3
4359 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4360 cgrad          enddo
4361 cgrad        enddo
4362           do k=1,3
4363             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4364             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4365           enddo
4366         endif
4367       enddo
4368       ehpb=0.5D0*ehpb
4369       return
4370       end
4371 C--------------------------------------------------------------------------
4372       subroutine ssbond_ene(i,j,eij)
4373 C
4374 C Calculate the distance and angle dependent SS-bond potential energy
4375 C using a free-energy function derived based on RHF/6-31G** ab initio
4376 C calculations of diethyl disulfide.
4377 C
4378 C A. Liwo and U. Kozlowska, 11/24/03
4379 C
4380       implicit real*8 (a-h,o-z)
4381       include 'DIMENSIONS'
4382       include 'COMMON.SBRIDGE'
4383       include 'COMMON.CHAIN'
4384       include 'COMMON.DERIV'
4385       include 'COMMON.LOCAL'
4386       include 'COMMON.INTERACT'
4387       include 'COMMON.VAR'
4388       include 'COMMON.IOUNITS'
4389       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4390       itypi=itype(i)
4391       xi=c(1,nres+i)
4392       yi=c(2,nres+i)
4393       zi=c(3,nres+i)
4394       dxi=dc_norm(1,nres+i)
4395       dyi=dc_norm(2,nres+i)
4396       dzi=dc_norm(3,nres+i)
4397 c      dsci_inv=dsc_inv(itypi)
4398       dsci_inv=vbld_inv(nres+i)
4399       itypj=itype(j)
4400 c      dscj_inv=dsc_inv(itypj)
4401       dscj_inv=vbld_inv(nres+j)
4402       xj=c(1,nres+j)-xi
4403       yj=c(2,nres+j)-yi
4404       zj=c(3,nres+j)-zi
4405       dxj=dc_norm(1,nres+j)
4406       dyj=dc_norm(2,nres+j)
4407       dzj=dc_norm(3,nres+j)
4408       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4409       rij=dsqrt(rrij)
4410       erij(1)=xj*rij
4411       erij(2)=yj*rij
4412       erij(3)=zj*rij
4413       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4414       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4415       om12=dxi*dxj+dyi*dyj+dzi*dzj
4416       do k=1,3
4417         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4418         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4419       enddo
4420       rij=1.0d0/rij
4421       deltad=rij-d0cm
4422       deltat1=1.0d0-om1
4423       deltat2=1.0d0+om2
4424       deltat12=om2-om1+2.0d0
4425       cosphi=om12-om1*om2
4426       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4427      &  +akct*deltad*deltat12+ebr
4428      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4429      &  +ss_depth
4430 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4431 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4432 c     &  " deltat12",deltat12," eij",eij
4433       ed=2*akcm*deltad+akct*deltat12
4434       pom1=akct*deltad
4435       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4436       eom1=-2*akth*deltat1-pom1-om2*pom2
4437       eom2= 2*akth*deltat2+pom1-om1*pom2
4438       eom12=pom2
4439       do k=1,3
4440         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4441         ghpbx(k,i)=ghpbx(k,i)-ggk
4442      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4443      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4444         ghpbx(k,j)=ghpbx(k,j)+ggk
4445      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4446      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4447         ghpbc(k,i)=ghpbc(k,i)-ggk
4448         ghpbc(k,j)=ghpbc(k,j)+ggk
4449       enddo
4450 C
4451 C Calculate the components of the gradient in DC and X
4452 C
4453 cgrad      do k=i,j-1
4454 cgrad        do l=1,3
4455 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4456 cgrad        enddo
4457 cgrad      enddo
4458       return
4459       end
4460 C--------------------------------------------------------------------------
4461       subroutine ebond(estr)
4462 c
4463 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4464 c
4465       implicit real*8 (a-h,o-z)
4466       include 'DIMENSIONS'
4467       include 'COMMON.LOCAL'
4468       include 'COMMON.GEO'
4469       include 'COMMON.INTERACT'
4470       include 'COMMON.DERIV'
4471       include 'COMMON.VAR'
4472       include 'COMMON.CHAIN'
4473       include 'COMMON.IOUNITS'
4474       include 'COMMON.NAMES'
4475       include 'COMMON.FFIELD'
4476       include 'COMMON.CONTROL'
4477       include 'COMMON.SETUP'
4478       double precision u(3),ud(3)
4479       estr=0.0d0
4480       do i=ibondp_start,ibondp_end
4481         diff = vbld(i)-vbldp0
4482 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4483         estr=estr+diff*diff
4484         do j=1,3
4485           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4486         enddo
4487 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4488       enddo
4489       estr=0.5d0*AKP*estr
4490 c
4491 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4492 c
4493       do i=ibond_start,ibond_end
4494         iti=itype(i)
4495         if (iti.ne.10) then
4496           nbi=nbondterm(iti)
4497           if (nbi.eq.1) then
4498             diff=vbld(i+nres)-vbldsc0(1,iti)
4499 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4500 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4501             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4502             do j=1,3
4503               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4504             enddo
4505           else
4506             do j=1,nbi
4507               diff=vbld(i+nres)-vbldsc0(j,iti)
4508               ud(j)=aksc(j,iti)*diff
4509               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4510             enddo
4511             uprod=u(1)
4512             do j=2,nbi
4513               uprod=uprod*u(j)
4514             enddo
4515             usum=0.0d0
4516             usumsqder=0.0d0
4517             do j=1,nbi
4518               uprod1=1.0d0
4519               uprod2=1.0d0
4520               do k=1,nbi
4521                 if (k.ne.j) then
4522                   uprod1=uprod1*u(k)
4523                   uprod2=uprod2*u(k)*u(k)
4524                 endif
4525               enddo
4526               usum=usum+uprod1
4527               usumsqder=usumsqder+ud(j)*uprod2
4528             enddo
4529             estr=estr+uprod/usum
4530             do j=1,3
4531              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4532             enddo
4533           endif
4534         endif
4535       enddo
4536       return
4537       end
4538 #ifdef CRYST_THETA
4539 C--------------------------------------------------------------------------
4540       subroutine ebend(etheta)
4541 C
4542 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4543 C angles gamma and its derivatives in consecutive thetas and gammas.
4544 C
4545       implicit real*8 (a-h,o-z)
4546       include 'DIMENSIONS'
4547       include 'COMMON.LOCAL'
4548       include 'COMMON.GEO'
4549       include 'COMMON.INTERACT'
4550       include 'COMMON.DERIV'
4551       include 'COMMON.VAR'
4552       include 'COMMON.CHAIN'
4553       include 'COMMON.IOUNITS'
4554       include 'COMMON.NAMES'
4555       include 'COMMON.FFIELD'
4556       include 'COMMON.CONTROL'
4557       common /calcthet/ term1,term2,termm,diffak,ratak,
4558      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4559      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4560       double precision y(2),z(2)
4561       delta=0.02d0*pi
4562 c      time11=dexp(-2*time)
4563 c      time12=1.0d0
4564       etheta=0.0D0
4565 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4566       do i=ithet_start,ithet_end
4567 C Zero the energy function and its derivative at 0 or pi.
4568         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4569         it=itype(i-1)
4570         if (i.gt.3) then
4571 #ifdef OSF
4572           phii=phi(i)
4573           if (phii.ne.phii) phii=150.0
4574 #else
4575           phii=phi(i)
4576 #endif
4577           y(1)=dcos(phii)
4578           y(2)=dsin(phii)
4579         else
4580           y(1)=0.0D0
4581           y(2)=0.0D0
4582         endif
4583         if (i.lt.nres) then
4584 #ifdef OSF
4585           phii1=phi(i+1)
4586           if (phii1.ne.phii1) phii1=150.0
4587           phii1=pinorm(phii1)
4588           z(1)=cos(phii1)
4589 #else
4590           phii1=phi(i+1)
4591           z(1)=dcos(phii1)
4592 #endif
4593           z(2)=dsin(phii1)
4594         else
4595           z(1)=0.0D0
4596           z(2)=0.0D0
4597         endif
4598 C Calculate the "mean" value of theta from the part of the distribution
4599 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4600 C In following comments this theta will be referred to as t_c.
4601         thet_pred_mean=0.0d0
4602         do k=1,2
4603           athetk=athet(k,it)
4604           bthetk=bthet(k,it)
4605           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4606         enddo
4607         dthett=thet_pred_mean*ssd
4608         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4609 C Derivatives of the "mean" values in gamma1 and gamma2.
4610         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4611         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4612         if (theta(i).gt.pi-delta) then
4613           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4614      &         E_tc0)
4615           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4616           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4617           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4618      &        E_theta)
4619           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4620      &        E_tc)
4621         else if (theta(i).lt.delta) then
4622           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4623           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4624           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4625      &        E_theta)
4626           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4627           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4628      &        E_tc)
4629         else
4630           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4631      &        E_theta,E_tc)
4632         endif
4633         etheta=etheta+ethetai
4634         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4635      &      'ebend',i,ethetai
4636         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4637         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4638         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4639       enddo
4640 C Ufff.... We've done all this!!!
4641       return
4642       end
4643 C---------------------------------------------------------------------------
4644       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4645      &     E_tc)
4646       implicit real*8 (a-h,o-z)
4647       include 'DIMENSIONS'
4648       include 'COMMON.LOCAL'
4649       include 'COMMON.IOUNITS'
4650       common /calcthet/ term1,term2,termm,diffak,ratak,
4651      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4652      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4653 C Calculate the contributions to both Gaussian lobes.
4654 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4655 C The "polynomial part" of the "standard deviation" of this part of
4656 C the distribution.
4657         sig=polthet(3,it)
4658         do j=2,0,-1
4659           sig=sig*thet_pred_mean+polthet(j,it)
4660         enddo
4661 C Derivative of the "interior part" of the "standard deviation of the"
4662 C gamma-dependent Gaussian lobe in t_c.
4663         sigtc=3*polthet(3,it)
4664         do j=2,1,-1
4665           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4666         enddo
4667         sigtc=sig*sigtc
4668 C Set the parameters of both Gaussian lobes of the distribution.
4669 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4670         fac=sig*sig+sigc0(it)
4671         sigcsq=fac+fac
4672         sigc=1.0D0/sigcsq
4673 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4674         sigsqtc=-4.0D0*sigcsq*sigtc
4675 c       print *,i,sig,sigtc,sigsqtc
4676 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4677         sigtc=-sigtc/(fac*fac)
4678 C Following variable is sigma(t_c)**(-2)
4679         sigcsq=sigcsq*sigcsq
4680         sig0i=sig0(it)
4681         sig0inv=1.0D0/sig0i**2
4682         delthec=thetai-thet_pred_mean
4683         delthe0=thetai-theta0i
4684         term1=-0.5D0*sigcsq*delthec*delthec
4685         term2=-0.5D0*sig0inv*delthe0*delthe0
4686 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4687 C NaNs in taking the logarithm. We extract the largest exponent which is added
4688 C to the energy (this being the log of the distribution) at the end of energy
4689 C term evaluation for this virtual-bond angle.
4690         if (term1.gt.term2) then
4691           termm=term1
4692           term2=dexp(term2-termm)
4693           term1=1.0d0
4694         else
4695           termm=term2
4696           term1=dexp(term1-termm)
4697           term2=1.0d0
4698         endif
4699 C The ratio between the gamma-independent and gamma-dependent lobes of
4700 C the distribution is a Gaussian function of thet_pred_mean too.
4701         diffak=gthet(2,it)-thet_pred_mean
4702         ratak=diffak/gthet(3,it)**2
4703         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4704 C Let's differentiate it in thet_pred_mean NOW.
4705         aktc=ak*ratak
4706 C Now put together the distribution terms to make complete distribution.
4707         termexp=term1+ak*term2
4708         termpre=sigc+ak*sig0i
4709 C Contribution of the bending energy from this theta is just the -log of
4710 C the sum of the contributions from the two lobes and the pre-exponential
4711 C factor. Simple enough, isn't it?
4712         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4713 C NOW the derivatives!!!
4714 C 6/6/97 Take into account the deformation.
4715         E_theta=(delthec*sigcsq*term1
4716      &       +ak*delthe0*sig0inv*term2)/termexp
4717         E_tc=((sigtc+aktc*sig0i)/termpre
4718      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4719      &       aktc*term2)/termexp)
4720       return
4721       end
4722 c-----------------------------------------------------------------------------
4723       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4724       implicit real*8 (a-h,o-z)
4725       include 'DIMENSIONS'
4726       include 'COMMON.LOCAL'
4727       include 'COMMON.IOUNITS'
4728       common /calcthet/ term1,term2,termm,diffak,ratak,
4729      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4730      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4731       delthec=thetai-thet_pred_mean
4732       delthe0=thetai-theta0i
4733 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4734       t3 = thetai-thet_pred_mean
4735       t6 = t3**2
4736       t9 = term1
4737       t12 = t3*sigcsq
4738       t14 = t12+t6*sigsqtc
4739       t16 = 1.0d0
4740       t21 = thetai-theta0i
4741       t23 = t21**2
4742       t26 = term2
4743       t27 = t21*t26
4744       t32 = termexp
4745       t40 = t32**2
4746       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4747      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4748      & *(-t12*t9-ak*sig0inv*t27)
4749       return
4750       end
4751 #else
4752 C--------------------------------------------------------------------------
4753       subroutine ebend(etheta)
4754 C
4755 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4756 C angles gamma and its derivatives in consecutive thetas and gammas.
4757 C ab initio-derived potentials from
4758 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4759 C
4760       implicit real*8 (a-h,o-z)
4761       include 'DIMENSIONS'
4762       include 'COMMON.LOCAL'
4763       include 'COMMON.GEO'
4764       include 'COMMON.INTERACT'
4765       include 'COMMON.DERIV'
4766       include 'COMMON.VAR'
4767       include 'COMMON.CHAIN'
4768       include 'COMMON.IOUNITS'
4769       include 'COMMON.NAMES'
4770       include 'COMMON.FFIELD'
4771       include 'COMMON.CONTROL'
4772       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4773      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4774      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4775      & sinph1ph2(maxdouble,maxdouble)
4776       logical lprn /.false./, lprn1 /.false./
4777       etheta=0.0D0
4778       do i=ithet_start,ithet_end
4779         dethetai=0.0d0
4780         dephii=0.0d0
4781         dephii1=0.0d0
4782         theti2=0.5d0*theta(i)
4783         ityp2=ithetyp(itype(i-1))
4784         do k=1,nntheterm
4785           coskt(k)=dcos(k*theti2)
4786           sinkt(k)=dsin(k*theti2)
4787         enddo
4788         if (i.gt.3) then
4789 #ifdef OSF
4790           phii=phi(i)
4791           if (phii.ne.phii) phii=150.0
4792 #else
4793           phii=phi(i)
4794 #endif
4795           ityp1=ithetyp(itype(i-2))
4796           do k=1,nsingle
4797             cosph1(k)=dcos(k*phii)
4798             sinph1(k)=dsin(k*phii)
4799           enddo
4800         else
4801           phii=0.0d0
4802           ityp1=nthetyp+1
4803           do k=1,nsingle
4804             cosph1(k)=0.0d0
4805             sinph1(k)=0.0d0
4806           enddo
4807         endif
4808         if (i.lt.nres) then
4809 #ifdef OSF
4810           phii1=phi(i+1)
4811           if (phii1.ne.phii1) phii1=150.0
4812           phii1=pinorm(phii1)
4813 #else
4814           phii1=phi(i+1)
4815 #endif
4816           ityp3=ithetyp(itype(i))
4817           do k=1,nsingle
4818             cosph2(k)=dcos(k*phii1)
4819             sinph2(k)=dsin(k*phii1)
4820           enddo
4821         else
4822           phii1=0.0d0
4823           ityp3=nthetyp+1
4824           do k=1,nsingle
4825             cosph2(k)=0.0d0
4826             sinph2(k)=0.0d0
4827           enddo
4828         endif
4829         ethetai=aa0thet(ityp1,ityp2,ityp3)
4830         do k=1,ndouble
4831           do l=1,k-1
4832             ccl=cosph1(l)*cosph2(k-l)
4833             ssl=sinph1(l)*sinph2(k-l)
4834             scl=sinph1(l)*cosph2(k-l)
4835             csl=cosph1(l)*sinph2(k-l)
4836             cosph1ph2(l,k)=ccl-ssl
4837             cosph1ph2(k,l)=ccl+ssl
4838             sinph1ph2(l,k)=scl+csl
4839             sinph1ph2(k,l)=scl-csl
4840           enddo
4841         enddo
4842         if (lprn) then
4843         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4844      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4845         write (iout,*) "coskt and sinkt"
4846         do k=1,nntheterm
4847           write (iout,*) k,coskt(k),sinkt(k)
4848         enddo
4849         endif
4850         do k=1,ntheterm
4851           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4852           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4853      &      *coskt(k)
4854           if (lprn)
4855      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4856      &     " ethetai",ethetai
4857         enddo
4858         if (lprn) then
4859         write (iout,*) "cosph and sinph"
4860         do k=1,nsingle
4861           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4862         enddo
4863         write (iout,*) "cosph1ph2 and sinph2ph2"
4864         do k=2,ndouble
4865           do l=1,k-1
4866             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4867      &         sinph1ph2(l,k),sinph1ph2(k,l)
4868           enddo
4869         enddo
4870         write(iout,*) "ethetai",ethetai
4871         endif
4872         do m=1,ntheterm2
4873           do k=1,nsingle
4874             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4875      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4876      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4877      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4878             ethetai=ethetai+sinkt(m)*aux
4879             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4880             dephii=dephii+k*sinkt(m)*(
4881      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4882      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4883             dephii1=dephii1+k*sinkt(m)*(
4884      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4885      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4886             if (lprn)
4887      &      write (iout,*) "m",m," k",k," bbthet",
4888      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4889      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4890      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4891      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4892           enddo
4893         enddo
4894         if (lprn)
4895      &  write(iout,*) "ethetai",ethetai
4896         do m=1,ntheterm3
4897           do k=2,ndouble
4898             do l=1,k-1
4899               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4900      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4901      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4902      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4903               ethetai=ethetai+sinkt(m)*aux
4904               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4905               dephii=dephii+l*sinkt(m)*(
4906      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4907      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4908      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4909      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4910               dephii1=dephii1+(k-l)*sinkt(m)*(
4911      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4912      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4913      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4914      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4915               if (lprn) then
4916               write (iout,*) "m",m," k",k," l",l," ffthet",
4917      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4918      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4919      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4920      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4921               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4922      &            cosph1ph2(k,l)*sinkt(m),
4923      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4924               endif
4925             enddo
4926           enddo
4927         enddo
4928 10      continue
4929         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4930      &   i,theta(i)*rad2deg,phii*rad2deg,
4931      &   phii1*rad2deg,ethetai
4932         etheta=etheta+ethetai
4933         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4934         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4935         gloc(nphi+i-2,icg)=wang*dethetai
4936       enddo
4937       return
4938       end
4939 #endif
4940 #ifdef CRYST_SC
4941 c-----------------------------------------------------------------------------
4942       subroutine esc(escloc)
4943 C Calculate the local energy of a side chain and its derivatives in the
4944 C corresponding virtual-bond valence angles THETA and the spherical angles
4945 C ALPHA and OMEGA.
4946       implicit real*8 (a-h,o-z)
4947       include 'DIMENSIONS'
4948       include 'COMMON.GEO'
4949       include 'COMMON.LOCAL'
4950       include 'COMMON.VAR'
4951       include 'COMMON.INTERACT'
4952       include 'COMMON.DERIV'
4953       include 'COMMON.CHAIN'
4954       include 'COMMON.IOUNITS'
4955       include 'COMMON.NAMES'
4956       include 'COMMON.FFIELD'
4957       include 'COMMON.CONTROL'
4958       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4959      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4960       common /sccalc/ time11,time12,time112,theti,it,nlobit
4961       delta=0.02d0*pi
4962       escloc=0.0D0
4963 c     write (iout,'(a)') 'ESC'
4964       do i=loc_start,loc_end
4965         it=itype(i)
4966         if (it.eq.10) goto 1
4967         nlobit=nlob(it)
4968 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4969 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4970         theti=theta(i+1)-pipol
4971         x(1)=dtan(theti)
4972         x(2)=alph(i)
4973         x(3)=omeg(i)
4974
4975         if (x(2).gt.pi-delta) then
4976           xtemp(1)=x(1)
4977           xtemp(2)=pi-delta
4978           xtemp(3)=x(3)
4979           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4980           xtemp(2)=pi
4981           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4982           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4983      &        escloci,dersc(2))
4984           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4985      &        ddersc0(1),dersc(1))
4986           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4987      &        ddersc0(3),dersc(3))
4988           xtemp(2)=pi-delta
4989           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4990           xtemp(2)=pi
4991           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4992           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4993      &            dersc0(2),esclocbi,dersc02)
4994           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4995      &            dersc12,dersc01)
4996           call splinthet(x(2),0.5d0*delta,ss,ssd)
4997           dersc0(1)=dersc01
4998           dersc0(2)=dersc02
4999           dersc0(3)=0.0d0
5000           do k=1,3
5001             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5002           enddo
5003           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5004 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5005 c    &             esclocbi,ss,ssd
5006           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5007 c         escloci=esclocbi
5008 c         write (iout,*) escloci
5009         else if (x(2).lt.delta) then
5010           xtemp(1)=x(1)
5011           xtemp(2)=delta
5012           xtemp(3)=x(3)
5013           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5014           xtemp(2)=0.0d0
5015           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5016           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5017      &        escloci,dersc(2))
5018           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5019      &        ddersc0(1),dersc(1))
5020           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5021      &        ddersc0(3),dersc(3))
5022           xtemp(2)=delta
5023           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5024           xtemp(2)=0.0d0
5025           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5026           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5027      &            dersc0(2),esclocbi,dersc02)
5028           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5029      &            dersc12,dersc01)
5030           dersc0(1)=dersc01
5031           dersc0(2)=dersc02
5032           dersc0(3)=0.0d0
5033           call splinthet(x(2),0.5d0*delta,ss,ssd)
5034           do k=1,3
5035             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5036           enddo
5037           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5038 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5039 c    &             esclocbi,ss,ssd
5040           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5041 c         write (iout,*) escloci
5042         else
5043           call enesc(x,escloci,dersc,ddummy,.false.)
5044         endif
5045
5046         escloc=escloc+escloci
5047         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5048      &     'escloc',i,escloci
5049 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5050
5051         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5052      &   wscloc*dersc(1)
5053         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5054         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5055     1   continue
5056       enddo
5057       return
5058       end
5059 C---------------------------------------------------------------------------
5060       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5061       implicit real*8 (a-h,o-z)
5062       include 'DIMENSIONS'
5063       include 'COMMON.GEO'
5064       include 'COMMON.LOCAL'
5065       include 'COMMON.IOUNITS'
5066       common /sccalc/ time11,time12,time112,theti,it,nlobit
5067       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5068       double precision contr(maxlob,-1:1)
5069       logical mixed
5070 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5071         escloc_i=0.0D0
5072         do j=1,3
5073           dersc(j)=0.0D0
5074           if (mixed) ddersc(j)=0.0d0
5075         enddo
5076         x3=x(3)
5077
5078 C Because of periodicity of the dependence of the SC energy in omega we have
5079 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5080 C To avoid underflows, first compute & store the exponents.
5081
5082         do iii=-1,1
5083
5084           x(3)=x3+iii*dwapi
5085
5086           do j=1,nlobit
5087             do k=1,3
5088               z(k)=x(k)-censc(k,j,it)
5089             enddo
5090             do k=1,3
5091               Axk=0.0D0
5092               do l=1,3
5093                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5094               enddo
5095               Ax(k,j,iii)=Axk
5096             enddo
5097             expfac=0.0D0
5098             do k=1,3
5099               expfac=expfac+Ax(k,j,iii)*z(k)
5100             enddo
5101             contr(j,iii)=expfac
5102           enddo ! j
5103
5104         enddo ! iii
5105
5106         x(3)=x3
5107 C As in the case of ebend, we want to avoid underflows in exponentiation and
5108 C subsequent NaNs and INFs in energy calculation.
5109 C Find the largest exponent
5110         emin=contr(1,-1)
5111         do iii=-1,1
5112           do j=1,nlobit
5113             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5114           enddo
5115         enddo
5116         emin=0.5D0*emin
5117 cd      print *,'it=',it,' emin=',emin
5118
5119 C Compute the contribution to SC energy and derivatives
5120         do iii=-1,1
5121
5122           do j=1,nlobit
5123 #ifdef OSF
5124             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5125             if(adexp.ne.adexp) adexp=1.0
5126             expfac=dexp(adexp)
5127 #else
5128             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5129 #endif
5130 cd          print *,'j=',j,' expfac=',expfac
5131             escloc_i=escloc_i+expfac
5132             do k=1,3
5133               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5134             enddo
5135             if (mixed) then
5136               do k=1,3,2
5137                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5138      &            +gaussc(k,2,j,it))*expfac
5139               enddo
5140             endif
5141           enddo
5142
5143         enddo ! iii
5144
5145         dersc(1)=dersc(1)/cos(theti)**2
5146         ddersc(1)=ddersc(1)/cos(theti)**2
5147         ddersc(3)=ddersc(3)
5148
5149         escloci=-(dlog(escloc_i)-emin)
5150         do j=1,3
5151           dersc(j)=dersc(j)/escloc_i
5152         enddo
5153         if (mixed) then
5154           do j=1,3,2
5155             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5156           enddo
5157         endif
5158       return
5159       end
5160 C------------------------------------------------------------------------------
5161       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5162       implicit real*8 (a-h,o-z)
5163       include 'DIMENSIONS'
5164       include 'COMMON.GEO'
5165       include 'COMMON.LOCAL'
5166       include 'COMMON.IOUNITS'
5167       common /sccalc/ time11,time12,time112,theti,it,nlobit
5168       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5169       double precision contr(maxlob)
5170       logical mixed
5171
5172       escloc_i=0.0D0
5173
5174       do j=1,3
5175         dersc(j)=0.0D0
5176       enddo
5177
5178       do j=1,nlobit
5179         do k=1,2
5180           z(k)=x(k)-censc(k,j,it)
5181         enddo
5182         z(3)=dwapi
5183         do k=1,3
5184           Axk=0.0D0
5185           do l=1,3
5186             Axk=Axk+gaussc(l,k,j,it)*z(l)
5187           enddo
5188           Ax(k,j)=Axk
5189         enddo
5190         expfac=0.0D0
5191         do k=1,3
5192           expfac=expfac+Ax(k,j)*z(k)
5193         enddo
5194         contr(j)=expfac
5195       enddo ! j
5196
5197 C As in the case of ebend, we want to avoid underflows in exponentiation and
5198 C subsequent NaNs and INFs in energy calculation.
5199 C Find the largest exponent
5200       emin=contr(1)
5201       do j=1,nlobit
5202         if (emin.gt.contr(j)) emin=contr(j)
5203       enddo
5204       emin=0.5D0*emin
5205
5206 C Compute the contribution to SC energy and derivatives
5207
5208       dersc12=0.0d0
5209       do j=1,nlobit
5210         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5211         escloc_i=escloc_i+expfac
5212         do k=1,2
5213           dersc(k)=dersc(k)+Ax(k,j)*expfac
5214         enddo
5215         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5216      &            +gaussc(1,2,j,it))*expfac
5217         dersc(3)=0.0d0
5218       enddo
5219
5220       dersc(1)=dersc(1)/cos(theti)**2
5221       dersc12=dersc12/cos(theti)**2
5222       escloci=-(dlog(escloc_i)-emin)
5223       do j=1,2
5224         dersc(j)=dersc(j)/escloc_i
5225       enddo
5226       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5227       return
5228       end
5229 #else
5230 c----------------------------------------------------------------------------------
5231       subroutine esc(escloc)
5232 C Calculate the local energy of a side chain and its derivatives in the
5233 C corresponding virtual-bond valence angles THETA and the spherical angles
5234 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5235 C added by Urszula Kozlowska. 07/11/2007
5236 C
5237       implicit real*8 (a-h,o-z)
5238       include 'DIMENSIONS'
5239       include 'COMMON.GEO'
5240       include 'COMMON.LOCAL'
5241       include 'COMMON.VAR'
5242       include 'COMMON.SCROT'
5243       include 'COMMON.INTERACT'
5244       include 'COMMON.DERIV'
5245       include 'COMMON.CHAIN'
5246       include 'COMMON.IOUNITS'
5247       include 'COMMON.NAMES'
5248       include 'COMMON.FFIELD'
5249       include 'COMMON.CONTROL'
5250       include 'COMMON.VECTORS'
5251       double precision x_prime(3),y_prime(3),z_prime(3)
5252      &    , sumene,dsc_i,dp2_i,x(65),
5253      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5254      &    de_dxx,de_dyy,de_dzz,de_dt
5255       double precision s1_t,s1_6_t,s2_t,s2_6_t
5256       double precision
5257      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5258      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5259      & dt_dCi(3),dt_dCi1(3)
5260       common /sccalc/ time11,time12,time112,theti,it,nlobit
5261       delta=0.02d0*pi
5262       escloc=0.0D0
5263       do i=loc_start,loc_end
5264         costtab(i+1) =dcos(theta(i+1))
5265         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5266         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5267         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5268         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5269         cosfac=dsqrt(cosfac2)
5270         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5271         sinfac=dsqrt(sinfac2)
5272         it=itype(i)
5273         if (it.eq.10) goto 1
5274 c
5275 C  Compute the axes of tghe local cartesian coordinates system; store in
5276 c   x_prime, y_prime and z_prime
5277 c
5278         do j=1,3
5279           x_prime(j) = 0.00
5280           y_prime(j) = 0.00
5281           z_prime(j) = 0.00
5282         enddo
5283 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5284 C     &   dc_norm(3,i+nres)
5285         do j = 1,3
5286           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5287           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5288         enddo
5289         do j = 1,3
5290           z_prime(j) = -uz(j,i-1)
5291         enddo
5292 c       write (2,*) "i",i
5293 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5294 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5295 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5296 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5297 c      & " xy",scalar(x_prime(1),y_prime(1)),
5298 c      & " xz",scalar(x_prime(1),z_prime(1)),
5299 c      & " yy",scalar(y_prime(1),y_prime(1)),
5300 c      & " yz",scalar(y_prime(1),z_prime(1)),
5301 c      & " zz",scalar(z_prime(1),z_prime(1))
5302 c
5303 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5304 C to local coordinate system. Store in xx, yy, zz.
5305 c
5306         xx=0.0d0
5307         yy=0.0d0
5308         zz=0.0d0
5309         do j = 1,3
5310           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5311           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5312           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5313         enddo
5314
5315         xxtab(i)=xx
5316         yytab(i)=yy
5317         zztab(i)=zz
5318 C
5319 C Compute the energy of the ith side cbain
5320 C
5321 c        write (2,*) "xx",xx," yy",yy," zz",zz
5322         it=itype(i)
5323         do j = 1,65
5324           x(j) = sc_parmin(j,it)
5325         enddo
5326 #ifdef CHECK_COORD
5327 Cc diagnostics - remove later
5328         xx1 = dcos(alph(2))
5329         yy1 = dsin(alph(2))*dcos(omeg(2))
5330         zz1 = -dsin(alph(2))*dsin(omeg(2))
5331         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5332      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5333      &    xx1,yy1,zz1
5334 C,"  --- ", xx_w,yy_w,zz_w
5335 c end diagnostics
5336 #endif
5337         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5338      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5339      &   + x(10)*yy*zz
5340         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5341      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5342      & + x(20)*yy*zz
5343         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5344      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5345      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5346      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5347      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5348      &  +x(40)*xx*yy*zz
5349         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5350      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5351      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5352      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5353      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5354      &  +x(60)*xx*yy*zz
5355         dsc_i   = 0.743d0+x(61)
5356         dp2_i   = 1.9d0+x(62)
5357         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5358      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5359         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5360      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5361         s1=(1+x(63))/(0.1d0 + dscp1)
5362         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5363         s2=(1+x(65))/(0.1d0 + dscp2)
5364         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5365         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5366      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5367 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5368 c     &   sumene4,
5369 c     &   dscp1,dscp2,sumene
5370 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5371         escloc = escloc + sumene
5372 c        write (2,*) "i",i," escloc",sumene,escloc
5373 #ifdef DEBUG
5374 C
5375 C This section to check the numerical derivatives of the energy of ith side
5376 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5377 C #define DEBUG in the code to turn it on.
5378 C
5379         write (2,*) "sumene               =",sumene
5380         aincr=1.0d-7
5381         xxsave=xx
5382         xx=xx+aincr
5383         write (2,*) xx,yy,zz
5384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5385         de_dxx_num=(sumenep-sumene)/aincr
5386         xx=xxsave
5387         write (2,*) "xx+ sumene from enesc=",sumenep
5388         yysave=yy
5389         yy=yy+aincr
5390         write (2,*) xx,yy,zz
5391         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5392         de_dyy_num=(sumenep-sumene)/aincr
5393         yy=yysave
5394         write (2,*) "yy+ sumene from enesc=",sumenep
5395         zzsave=zz
5396         zz=zz+aincr
5397         write (2,*) xx,yy,zz
5398         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5399         de_dzz_num=(sumenep-sumene)/aincr
5400         zz=zzsave
5401         write (2,*) "zz+ sumene from enesc=",sumenep
5402         costsave=cost2tab(i+1)
5403         sintsave=sint2tab(i+1)
5404         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5405         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5406         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5407         de_dt_num=(sumenep-sumene)/aincr
5408         write (2,*) " t+ sumene from enesc=",sumenep
5409         cost2tab(i+1)=costsave
5410         sint2tab(i+1)=sintsave
5411 C End of diagnostics section.
5412 #endif
5413 C
5414 C Compute the gradient of esc
5415 C
5416         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5417         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5418         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5419         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5420         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5421         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5422         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5423         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5424         pom1=(sumene3*sint2tab(i+1)+sumene1)
5425      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5426         pom2=(sumene4*cost2tab(i+1)+sumene2)
5427      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5428         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5429         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5430      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5431      &  +x(40)*yy*zz
5432         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5433         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5434      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5435      &  +x(60)*yy*zz
5436         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5437      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5438      &        +(pom1+pom2)*pom_dx
5439 #ifdef DEBUG
5440         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5441 #endif
5442 C
5443         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5444         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5445      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5446      &  +x(40)*xx*zz
5447         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5448         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5449      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5450      &  +x(59)*zz**2 +x(60)*xx*zz
5451         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5452      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5453      &        +(pom1-pom2)*pom_dy
5454 #ifdef DEBUG
5455         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5456 #endif
5457 C
5458         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5459      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5460      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5461      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5462      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5463      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5464      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5465      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5466 #ifdef DEBUG
5467         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5468 #endif
5469 C
5470         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5471      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5472      &  +pom1*pom_dt1+pom2*pom_dt2
5473 #ifdef DEBUG
5474         write(2,*), "de_dt = ", de_dt,de_dt_num
5475 #endif
5476 c
5477 C
5478        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5479        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5480        cosfac2xx=cosfac2*xx
5481        sinfac2yy=sinfac2*yy
5482        do k = 1,3
5483          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5484      &      vbld_inv(i+1)
5485          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5486      &      vbld_inv(i)
5487          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5488          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5489 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5490 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5491 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5492 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5493          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5494          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5495          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5496          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5497          dZZ_Ci1(k)=0.0d0
5498          dZZ_Ci(k)=0.0d0
5499          do j=1,3
5500            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5501            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5502          enddo
5503
5504          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5505          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5506          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5507 c
5508          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5509          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5510        enddo
5511
5512        do k=1,3
5513          dXX_Ctab(k,i)=dXX_Ci(k)
5514          dXX_C1tab(k,i)=dXX_Ci1(k)
5515          dYY_Ctab(k,i)=dYY_Ci(k)
5516          dYY_C1tab(k,i)=dYY_Ci1(k)
5517          dZZ_Ctab(k,i)=dZZ_Ci(k)
5518          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5519          dXX_XYZtab(k,i)=dXX_XYZ(k)
5520          dYY_XYZtab(k,i)=dYY_XYZ(k)
5521          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5522        enddo
5523
5524        do k = 1,3
5525 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5526 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5527 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5528 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5529 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5530 c     &    dt_dci(k)
5531 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5532 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5533          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5534      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5535          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5536      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5537          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5538      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5539        enddo
5540 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5541 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5542
5543 C to check gradient call subroutine check_grad
5544
5545     1 continue
5546       enddo
5547       return
5548       end
5549 c------------------------------------------------------------------------------
5550       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5551       implicit none
5552       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5553      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5554       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5555      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5556      &   + x(10)*yy*zz
5557       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5558      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5559      & + x(20)*yy*zz
5560       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5561      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5562      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5563      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5564      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5565      &  +x(40)*xx*yy*zz
5566       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5567      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5568      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5569      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5570      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5571      &  +x(60)*xx*yy*zz
5572       dsc_i   = 0.743d0+x(61)
5573       dp2_i   = 1.9d0+x(62)
5574       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5575      &          *(xx*cost2+yy*sint2))
5576       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5577      &          *(xx*cost2-yy*sint2))
5578       s1=(1+x(63))/(0.1d0 + dscp1)
5579       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5580       s2=(1+x(65))/(0.1d0 + dscp2)
5581       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5582       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5583      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5584       enesc=sumene
5585       return
5586       end
5587 #endif
5588 c------------------------------------------------------------------------------
5589       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5590 C
5591 C This procedure calculates two-body contact function g(rij) and its derivative:
5592 C
5593 C           eps0ij                                     !       x < -1
5594 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5595 C            0                                         !       x > 1
5596 C
5597 C where x=(rij-r0ij)/delta
5598 C
5599 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5600 C
5601       implicit none
5602       double precision rij,r0ij,eps0ij,fcont,fprimcont
5603       double precision x,x2,x4,delta
5604 c     delta=0.02D0*r0ij
5605 c      delta=0.2D0*r0ij
5606       x=(rij-r0ij)/delta
5607       if (x.lt.-1.0D0) then
5608         fcont=eps0ij
5609         fprimcont=0.0D0
5610       else if (x.le.1.0D0) then
5611         x2=x*x
5612         x4=x2*x2
5613         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5614         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5615       else
5616         fcont=0.0D0
5617         fprimcont=0.0D0
5618       endif
5619       return
5620       end
5621 c------------------------------------------------------------------------------
5622       subroutine splinthet(theti,delta,ss,ssder)
5623       implicit real*8 (a-h,o-z)
5624       include 'DIMENSIONS'
5625       include 'COMMON.VAR'
5626       include 'COMMON.GEO'
5627       thetup=pi-delta
5628       thetlow=delta
5629       if (theti.gt.pipol) then
5630         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5631       else
5632         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5633         ssder=-ssder
5634       endif
5635       return
5636       end
5637 c------------------------------------------------------------------------------
5638       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5639       implicit none
5640       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5641       double precision ksi,ksi2,ksi3,a1,a2,a3
5642       a1=fprim0*delta/(f1-f0)
5643       a2=3.0d0-2.0d0*a1
5644       a3=a1-2.0d0
5645       ksi=(x-x0)/delta
5646       ksi2=ksi*ksi
5647       ksi3=ksi2*ksi
5648       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5649       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5650       return
5651       end
5652 c------------------------------------------------------------------------------
5653       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5654       implicit none
5655       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5656       double precision ksi,ksi2,ksi3,a1,a2,a3
5657       ksi=(x-x0)/delta
5658       ksi2=ksi*ksi
5659       ksi3=ksi2*ksi
5660       a1=fprim0x*delta
5661       a2=3*(f1x-f0x)-2*fprim0x*delta
5662       a3=fprim0x*delta-2*(f1x-f0x)
5663       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5664       return
5665       end
5666 C-----------------------------------------------------------------------------
5667 #ifdef CRYST_TOR
5668 C-----------------------------------------------------------------------------
5669       subroutine etor(etors,edihcnstr)
5670       implicit real*8 (a-h,o-z)
5671       include 'DIMENSIONS'
5672       include 'COMMON.VAR'
5673       include 'COMMON.GEO'
5674       include 'COMMON.LOCAL'
5675       include 'COMMON.TORSION'
5676       include 'COMMON.INTERACT'
5677       include 'COMMON.DERIV'
5678       include 'COMMON.CHAIN'
5679       include 'COMMON.NAMES'
5680       include 'COMMON.IOUNITS'
5681       include 'COMMON.FFIELD'
5682       include 'COMMON.TORCNSTR'
5683       include 'COMMON.CONTROL'
5684       logical lprn
5685 C Set lprn=.true. for debugging
5686       lprn=.false.
5687 c      lprn=.true.
5688       etors=0.0D0
5689       do i=iphi_start,iphi_end
5690       etors_ii=0.0D0
5691         itori=itortyp(itype(i-2))
5692         itori1=itortyp(itype(i-1))
5693         phii=phi(i)
5694         gloci=0.0D0
5695 C Proline-Proline pair is a special case...
5696         if (itori.eq.3 .and. itori1.eq.3) then
5697           if (phii.gt.-dwapi3) then
5698             cosphi=dcos(3*phii)
5699             fac=1.0D0/(1.0D0-cosphi)
5700             etorsi=v1(1,3,3)*fac
5701             etorsi=etorsi+etorsi
5702             etors=etors+etorsi-v1(1,3,3)
5703             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5704             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5705           endif
5706           do j=1,3
5707             v1ij=v1(j+1,itori,itori1)
5708             v2ij=v2(j+1,itori,itori1)
5709             cosphi=dcos(j*phii)
5710             sinphi=dsin(j*phii)
5711             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5712             if (energy_dec) etors_ii=etors_ii+
5713      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5714             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5715           enddo
5716         else
5717           do j=1,nterm_old
5718             v1ij=v1(j,itori,itori1)
5719             v2ij=v2(j,itori,itori1)
5720             cosphi=dcos(j*phii)
5721             sinphi=dsin(j*phii)
5722             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5723             if (energy_dec) etors_ii=etors_ii+
5724      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5725             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5726           enddo
5727         endif
5728         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5729      &        'etor',i,etors_ii
5730         if (lprn)
5731      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5732      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5733      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5734         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5735         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5736       enddo
5737 ! 6/20/98 - dihedral angle constraints
5738       edihcnstr=0.0d0
5739       do i=1,ndih_constr
5740         itori=idih_constr(i)
5741         phii=phi(itori)
5742         difi=phii-phi0(i)
5743         if (difi.gt.drange(i)) then
5744           difi=difi-drange(i)
5745           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5746           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5747         else if (difi.lt.-drange(i)) then
5748           difi=difi+drange(i)
5749           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5750           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5751         endif
5752 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5753 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5754       enddo
5755 !      write (iout,*) 'edihcnstr',edihcnstr
5756       return
5757       end
5758 c------------------------------------------------------------------------------
5759       subroutine etor_d(etors_d)
5760       etors_d=0.0d0
5761       return
5762       end
5763 c----------------------------------------------------------------------------
5764 #else
5765       subroutine etor(etors,edihcnstr)
5766       implicit real*8 (a-h,o-z)
5767       include 'DIMENSIONS'
5768       include 'COMMON.VAR'
5769       include 'COMMON.GEO'
5770       include 'COMMON.LOCAL'
5771       include 'COMMON.TORSION'
5772       include 'COMMON.INTERACT'
5773       include 'COMMON.DERIV'
5774       include 'COMMON.CHAIN'
5775       include 'COMMON.NAMES'
5776       include 'COMMON.IOUNITS'
5777       include 'COMMON.FFIELD'
5778       include 'COMMON.TORCNSTR'
5779       include 'COMMON.CONTROL'
5780       logical lprn
5781 C Set lprn=.true. for debugging
5782       lprn=.false.
5783 c     lprn=.true.
5784       etors=0.0D0
5785       do i=iphi_start,iphi_end
5786       etors_ii=0.0D0
5787         itori=itortyp(itype(i-2))
5788         itori1=itortyp(itype(i-1))
5789         phii=phi(i)
5790         gloci=0.0D0
5791 C Regular cosine and sine terms
5792         do j=1,nterm(itori,itori1)
5793           v1ij=v1(j,itori,itori1)
5794           v2ij=v2(j,itori,itori1)
5795           cosphi=dcos(j*phii)
5796           sinphi=dsin(j*phii)
5797           etors=etors+v1ij*cosphi+v2ij*sinphi
5798           if (energy_dec) etors_ii=etors_ii+
5799      &                v1ij*cosphi+v2ij*sinphi
5800           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5801         enddo
5802 C Lorentz terms
5803 C                         v1
5804 C  E = SUM ----------------------------------- - v1
5805 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5806 C
5807         cosphi=dcos(0.5d0*phii)
5808         sinphi=dsin(0.5d0*phii)
5809         do j=1,nlor(itori,itori1)
5810           vl1ij=vlor1(j,itori,itori1)
5811           vl2ij=vlor2(j,itori,itori1)
5812           vl3ij=vlor3(j,itori,itori1)
5813           pom=vl2ij*cosphi+vl3ij*sinphi
5814           pom1=1.0d0/(pom*pom+1.0d0)
5815           etors=etors+vl1ij*pom1
5816           if (energy_dec) etors_ii=etors_ii+
5817      &                vl1ij*pom1
5818           pom=-pom*pom1*pom1
5819           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5820         enddo
5821 C Subtract the constant term
5822         etors=etors-v0(itori,itori1)
5823           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5824      &         'etor',i,etors_ii-v0(itori,itori1)
5825         if (lprn)
5826      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5827      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5828      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5829         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5830 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5831       enddo
5832 ! 6/20/98 - dihedral angle constraints
5833       edihcnstr=0.0d0
5834 c      do i=1,ndih_constr
5835       do i=idihconstr_start,idihconstr_end
5836         itori=idih_constr(i)
5837         phii=phi(itori)
5838         difi=pinorm(phii-phi0(i))
5839         if (difi.gt.drange(i)) then
5840           difi=difi-drange(i)
5841           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5842           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5843         else if (difi.lt.-drange(i)) then
5844           difi=difi+drange(i)
5845           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5846           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5847         else
5848           difi=0.0
5849         endif
5850 c        write (iout,*) "gloci", gloc(i-3,icg)
5851 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5852 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5853 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5854       enddo
5855 cd       write (iout,*) 'edihcnstr',edihcnstr
5856       return
5857       end
5858 c----------------------------------------------------------------------------
5859       subroutine etor_d(etors_d)
5860 C 6/23/01 Compute double torsional energy
5861       implicit real*8 (a-h,o-z)
5862       include 'DIMENSIONS'
5863       include 'COMMON.VAR'
5864       include 'COMMON.GEO'
5865       include 'COMMON.LOCAL'
5866       include 'COMMON.TORSION'
5867       include 'COMMON.INTERACT'
5868       include 'COMMON.DERIV'
5869       include 'COMMON.CHAIN'
5870       include 'COMMON.NAMES'
5871       include 'COMMON.IOUNITS'
5872       include 'COMMON.FFIELD'
5873       include 'COMMON.TORCNSTR'
5874       logical lprn
5875 C Set lprn=.true. for debugging
5876       lprn=.false.
5877 c     lprn=.true.
5878       etors_d=0.0D0
5879       do i=iphid_start,iphid_end
5880         itori=itortyp(itype(i-2))
5881         itori1=itortyp(itype(i-1))
5882         itori2=itortyp(itype(i))
5883         phii=phi(i)
5884         phii1=phi(i+1)
5885         gloci1=0.0D0
5886         gloci2=0.0D0
5887         do j=1,ntermd_1(itori,itori1,itori2)
5888           v1cij=v1c(1,j,itori,itori1,itori2)
5889           v1sij=v1s(1,j,itori,itori1,itori2)
5890           v2cij=v1c(2,j,itori,itori1,itori2)
5891           v2sij=v1s(2,j,itori,itori1,itori2)
5892           cosphi1=dcos(j*phii)
5893           sinphi1=dsin(j*phii)
5894           cosphi2=dcos(j*phii1)
5895           sinphi2=dsin(j*phii1)
5896           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5897      &     v2cij*cosphi2+v2sij*sinphi2
5898           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5899           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5900         enddo
5901         do k=2,ntermd_2(itori,itori1,itori2)
5902           do l=1,k-1
5903             v1cdij = v2c(k,l,itori,itori1,itori2)
5904             v2cdij = v2c(l,k,itori,itori1,itori2)
5905             v1sdij = v2s(k,l,itori,itori1,itori2)
5906             v2sdij = v2s(l,k,itori,itori1,itori2)
5907             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5908             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5909             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5910             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5911             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5912      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5913             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5914      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5915             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5916      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5917           enddo
5918         enddo
5919         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5920         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5921 c        write (iout,*) "gloci", gloc(i-3,icg)
5922       enddo
5923       return
5924       end
5925 #endif
5926 c------------------------------------------------------------------------------
5927       subroutine eback_sc_corr(esccor)
5928 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5929 c        conformational states; temporarily implemented as differences
5930 c        between UNRES torsional potentials (dependent on three types of
5931 c        residues) and the torsional potentials dependent on all 20 types
5932 c        of residues computed from AM1  energy surfaces of terminally-blocked
5933 c        amino-acid residues.
5934       implicit real*8 (a-h,o-z)
5935       include 'DIMENSIONS'
5936       include 'COMMON.VAR'
5937       include 'COMMON.GEO'
5938       include 'COMMON.LOCAL'
5939       include 'COMMON.TORSION'
5940       include 'COMMON.SCCOR'
5941       include 'COMMON.INTERACT'
5942       include 'COMMON.DERIV'
5943       include 'COMMON.CHAIN'
5944       include 'COMMON.NAMES'
5945       include 'COMMON.IOUNITS'
5946       include 'COMMON.FFIELD'
5947       include 'COMMON.CONTROL'
5948       logical lprn
5949 C Set lprn=.true. for debugging
5950       lprn=.false.
5951 c      lprn=.true.
5952 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5953       esccor=0.0D0
5954       do i=itau_start,itau_end
5955         esccor_ii=0.0D0
5956         isccori=isccortyp(itype(i-2))
5957         isccori1=isccortyp(itype(i-1))
5958         phii=phi(i)
5959 cccc  Added 9 May 2012
5960 cc Tauangle is torsional engle depending on the value of first digit
5961 c(see comment below)
5962 cc Omicron is flat angle depending on the value of first digit
5963 c(see comment below)
5964
5965
5966         do intertyp=1,3 !intertyp
5967 cc Added 09 May 2012 (Adasko)
5968 cc  Intertyp means interaction type of backbone mainchain correlation:
5969 c   1 = SC...Ca...Ca...Ca
5970 c   2 = Ca...Ca...Ca...SC
5971 c   3 = SC...Ca...Ca...SCi
5972         gloci=0.0D0
5973         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5974      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5975      &      (itype(i-1).eq.21)))
5976      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5977      &     .or.(itype(i-2).eq.21)))
5978      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5979      &      (itype(i-1).eq.21)))) cycle
5980         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5981         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5982      & cycle
5983         do j=1,nterm_sccor(isccori,isccori1)
5984           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5985           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5986           cosphi=dcos(j*tauangle(intertyp,i))
5987           sinphi=dsin(j*tauangle(intertyp,i))
5988           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5989           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5990         enddo
5991         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5992 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5993 c     &gloc_sc(intertyp,i-3,icg)
5994         if (lprn)
5995      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5996      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5997      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5998      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5999         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6000        enddo !intertyp
6001       enddo
6002 c        do i=1,nres
6003 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6004 c        enddo
6005       return
6006       end
6007 c----------------------------------------------------------------------------
6008       subroutine multibody(ecorr)
6009 C This subroutine calculates multi-body contributions to energy following
6010 C the idea of Skolnick et al. If side chains I and J make a contact and
6011 C at the same time side chains I+1 and J+1 make a contact, an extra
6012 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6013       implicit real*8 (a-h,o-z)
6014       include 'DIMENSIONS'
6015       include 'COMMON.IOUNITS'
6016       include 'COMMON.DERIV'
6017       include 'COMMON.INTERACT'
6018       include 'COMMON.CONTACTS'
6019       double precision gx(3),gx1(3)
6020       logical lprn
6021
6022 C Set lprn=.true. for debugging
6023       lprn=.false.
6024
6025       if (lprn) then
6026         write (iout,'(a)') 'Contact function values:'
6027         do i=nnt,nct-2
6028           write (iout,'(i2,20(1x,i2,f10.5))')
6029      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6030         enddo
6031       endif
6032       ecorr=0.0D0
6033       do i=nnt,nct
6034         do j=1,3
6035           gradcorr(j,i)=0.0D0
6036           gradxorr(j,i)=0.0D0
6037         enddo
6038       enddo
6039       do i=nnt,nct-2
6040
6041         DO ISHIFT = 3,4
6042
6043         i1=i+ishift
6044         num_conti=num_cont(i)
6045         num_conti1=num_cont(i1)
6046         do jj=1,num_conti
6047           j=jcont(jj,i)
6048           do kk=1,num_conti1
6049             j1=jcont(kk,i1)
6050             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6051 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6052 cd   &                   ' ishift=',ishift
6053 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6054 C The system gains extra energy.
6055               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6056             endif   ! j1==j+-ishift
6057           enddo     ! kk
6058         enddo       ! jj
6059
6060         ENDDO ! ISHIFT
6061
6062       enddo         ! i
6063       return
6064       end
6065 c------------------------------------------------------------------------------
6066       double precision function esccorr(i,j,k,l,jj,kk)
6067       implicit real*8 (a-h,o-z)
6068       include 'DIMENSIONS'
6069       include 'COMMON.IOUNITS'
6070       include 'COMMON.DERIV'
6071       include 'COMMON.INTERACT'
6072       include 'COMMON.CONTACTS'
6073       double precision gx(3),gx1(3)
6074       logical lprn
6075       lprn=.false.
6076       eij=facont(jj,i)
6077       ekl=facont(kk,k)
6078 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6079 C Calculate the multi-body contribution to energy.
6080 C Calculate multi-body contributions to the gradient.
6081 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6082 cd   & k,l,(gacont(m,kk,k),m=1,3)
6083       do m=1,3
6084         gx(m) =ekl*gacont(m,jj,i)
6085         gx1(m)=eij*gacont(m,kk,k)
6086         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6087         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6088         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6089         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6090       enddo
6091       do m=i,j-1
6092         do ll=1,3
6093           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6094         enddo
6095       enddo
6096       do m=k,l-1
6097         do ll=1,3
6098           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6099         enddo
6100       enddo
6101       esccorr=-eij*ekl
6102       return
6103       end
6104 c------------------------------------------------------------------------------
6105       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6106 C This subroutine calculates multi-body contributions to hydrogen-bonding
6107       implicit real*8 (a-h,o-z)
6108       include 'DIMENSIONS'
6109       include 'COMMON.IOUNITS'
6110 #ifdef MPI
6111       include "mpif.h"
6112       parameter (max_cont=maxconts)
6113       parameter (max_dim=26)
6114       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6115       double precision zapas(max_dim,maxconts,max_fg_procs),
6116      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6117       common /przechowalnia/ zapas
6118       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6119      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6120 #endif
6121       include 'COMMON.SETUP'
6122       include 'COMMON.FFIELD'
6123       include 'COMMON.DERIV'
6124       include 'COMMON.INTERACT'
6125       include 'COMMON.CONTACTS'
6126       include 'COMMON.CONTROL'
6127       include 'COMMON.LOCAL'
6128       double precision gx(3),gx1(3),time00
6129       logical lprn,ldone
6130
6131 C Set lprn=.true. for debugging
6132       lprn=.false.
6133 #ifdef MPI
6134       n_corr=0
6135       n_corr1=0
6136       if (nfgtasks.le.1) goto 30
6137       if (lprn) then
6138         write (iout,'(a)') 'Contact function values before RECEIVE:'
6139         do i=nnt,nct-2
6140           write (iout,'(2i3,50(1x,i2,f5.2))')
6141      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6142      &    j=1,num_cont_hb(i))
6143         enddo
6144       endif
6145       call flush(iout)
6146       do i=1,ntask_cont_from
6147         ncont_recv(i)=0
6148       enddo
6149       do i=1,ntask_cont_to
6150         ncont_sent(i)=0
6151       enddo
6152 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6153 c     & ntask_cont_to
6154 C Make the list of contacts to send to send to other procesors
6155 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6156 c      call flush(iout)
6157       do i=iturn3_start,iturn3_end
6158 c        write (iout,*) "make contact list turn3",i," num_cont",
6159 c     &    num_cont_hb(i)
6160         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6161       enddo
6162       do i=iturn4_start,iturn4_end
6163 c        write (iout,*) "make contact list turn4",i," num_cont",
6164 c     &   num_cont_hb(i)
6165         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6166       enddo
6167       do ii=1,nat_sent
6168         i=iat_sent(ii)
6169 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6170 c     &    num_cont_hb(i)
6171         do j=1,num_cont_hb(i)
6172         do k=1,4
6173           jjc=jcont_hb(j,i)
6174           iproc=iint_sent_local(k,jjc,ii)
6175 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6176           if (iproc.gt.0) then
6177             ncont_sent(iproc)=ncont_sent(iproc)+1
6178             nn=ncont_sent(iproc)
6179             zapas(1,nn,iproc)=i
6180             zapas(2,nn,iproc)=jjc
6181             zapas(3,nn,iproc)=facont_hb(j,i)
6182             zapas(4,nn,iproc)=ees0p(j,i)
6183             zapas(5,nn,iproc)=ees0m(j,i)
6184             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6185             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6186             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6187             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6188             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6189             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6190             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6191             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6192             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6193             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6194             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6195             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6196             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6197             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6198             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6199             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6200             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6201             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6202             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6203             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6204             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6205           endif
6206         enddo
6207         enddo
6208       enddo
6209       if (lprn) then
6210       write (iout,*)
6211      &  "Numbers of contacts to be sent to other processors",
6212      &  (ncont_sent(i),i=1,ntask_cont_to)
6213       write (iout,*) "Contacts sent"
6214       do ii=1,ntask_cont_to
6215         nn=ncont_sent(ii)
6216         iproc=itask_cont_to(ii)
6217         write (iout,*) nn," contacts to processor",iproc,
6218      &   " of CONT_TO_COMM group"
6219         do i=1,nn
6220           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6221         enddo
6222       enddo
6223       call flush(iout)
6224       endif
6225       CorrelType=477
6226       CorrelID=fg_rank+1
6227       CorrelType1=478
6228       CorrelID1=nfgtasks+fg_rank+1
6229       ireq=0
6230 C Receive the numbers of needed contacts from other processors
6231       do ii=1,ntask_cont_from
6232         iproc=itask_cont_from(ii)
6233         ireq=ireq+1
6234         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6235      &    FG_COMM,req(ireq),IERR)
6236       enddo
6237 c      write (iout,*) "IRECV ended"
6238 c      call flush(iout)
6239 C Send the number of contacts needed by other processors
6240       do ii=1,ntask_cont_to
6241         iproc=itask_cont_to(ii)
6242         ireq=ireq+1
6243         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6244      &    FG_COMM,req(ireq),IERR)
6245       enddo
6246 c      write (iout,*) "ISEND ended"
6247 c      write (iout,*) "number of requests (nn)",ireq
6248       call flush(iout)
6249       if (ireq.gt.0)
6250      &  call MPI_Waitall(ireq,req,status_array,ierr)
6251 c      write (iout,*)
6252 c     &  "Numbers of contacts to be received from other processors",
6253 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6254 c      call flush(iout)
6255 C Receive contacts
6256       ireq=0
6257       do ii=1,ntask_cont_from
6258         iproc=itask_cont_from(ii)
6259         nn=ncont_recv(ii)
6260 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6261 c     &   " of CONT_TO_COMM group"
6262         call flush(iout)
6263         if (nn.gt.0) then
6264           ireq=ireq+1
6265           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6266      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6267 c          write (iout,*) "ireq,req",ireq,req(ireq)
6268         endif
6269       enddo
6270 C Send the contacts to processors that need them
6271       do ii=1,ntask_cont_to
6272         iproc=itask_cont_to(ii)
6273         nn=ncont_sent(ii)
6274 c        write (iout,*) nn," contacts to processor",iproc,
6275 c     &   " of CONT_TO_COMM group"
6276         if (nn.gt.0) then
6277           ireq=ireq+1
6278           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6279      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6280 c          write (iout,*) "ireq,req",ireq,req(ireq)
6281 c          do i=1,nn
6282 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6283 c          enddo
6284         endif
6285       enddo
6286 c      write (iout,*) "number of requests (contacts)",ireq
6287 c      write (iout,*) "req",(req(i),i=1,4)
6288 c      call flush(iout)
6289       if (ireq.gt.0)
6290      & call MPI_Waitall(ireq,req,status_array,ierr)
6291       do iii=1,ntask_cont_from
6292         iproc=itask_cont_from(iii)
6293         nn=ncont_recv(iii)
6294         if (lprn) then
6295         write (iout,*) "Received",nn," contacts from processor",iproc,
6296      &   " of CONT_FROM_COMM group"
6297         call flush(iout)
6298         do i=1,nn
6299           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6300         enddo
6301         call flush(iout)
6302         endif
6303         do i=1,nn
6304           ii=zapas_recv(1,i,iii)
6305 c Flag the received contacts to prevent double-counting
6306           jj=-zapas_recv(2,i,iii)
6307 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6308 c          call flush(iout)
6309           nnn=num_cont_hb(ii)+1
6310           num_cont_hb(ii)=nnn
6311           jcont_hb(nnn,ii)=jj
6312           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6313           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6314           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6315           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6316           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6317           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6318           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6319           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6320           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6321           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6322           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6323           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6324           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6325           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6326           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6327           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6328           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6329           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6330           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6331           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6332           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6333           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6334           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6335           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6336         enddo
6337       enddo
6338       call flush(iout)
6339       if (lprn) then
6340         write (iout,'(a)') 'Contact function values after receive:'
6341         do i=nnt,nct-2
6342           write (iout,'(2i3,50(1x,i3,f5.2))')
6343      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6344      &    j=1,num_cont_hb(i))
6345         enddo
6346         call flush(iout)
6347       endif
6348    30 continue
6349 #endif
6350       if (lprn) then
6351         write (iout,'(a)') 'Contact function values:'
6352         do i=nnt,nct-2
6353           write (iout,'(2i3,50(1x,i3,f5.2))')
6354      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6355      &    j=1,num_cont_hb(i))
6356         enddo
6357       endif
6358       ecorr=0.0D0
6359 C Remove the loop below after debugging !!!
6360       do i=nnt,nct
6361         do j=1,3
6362           gradcorr(j,i)=0.0D0
6363           gradxorr(j,i)=0.0D0
6364         enddo
6365       enddo
6366 C Calculate the local-electrostatic correlation terms
6367       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6368         i1=i+1
6369         num_conti=num_cont_hb(i)
6370         num_conti1=num_cont_hb(i+1)
6371         do jj=1,num_conti
6372           j=jcont_hb(jj,i)
6373           jp=iabs(j)
6374           do kk=1,num_conti1
6375             j1=jcont_hb(kk,i1)
6376             jp1=iabs(j1)
6377 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6378 c     &         ' jj=',jj,' kk=',kk
6379             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6380      &          .or. j.lt.0 .and. j1.gt.0) .and.
6381      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6382 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6383 C The system gains extra energy.
6384               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6385               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6386      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6387               n_corr=n_corr+1
6388             else if (j1.eq.j) then
6389 C Contacts I-J and I-(J+1) occur simultaneously.
6390 C The system loses extra energy.
6391 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6392             endif
6393           enddo ! kk
6394           do kk=1,num_conti
6395             j1=jcont_hb(kk,i)
6396 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6397 c    &         ' jj=',jj,' kk=',kk
6398             if (j1.eq.j+1) then
6399 C Contacts I-J and (I+1)-J occur simultaneously.
6400 C The system loses extra energy.
6401 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6402             endif ! j1==j+1
6403           enddo ! kk
6404         enddo ! jj
6405       enddo ! i
6406       return
6407       end
6408 c------------------------------------------------------------------------------
6409       subroutine add_hb_contact(ii,jj,itask)
6410       implicit real*8 (a-h,o-z)
6411       include "DIMENSIONS"
6412       include "COMMON.IOUNITS"
6413       integer max_cont
6414       integer max_dim
6415       parameter (max_cont=maxconts)
6416       parameter (max_dim=26)
6417       include "COMMON.CONTACTS"
6418       double precision zapas(max_dim,maxconts,max_fg_procs),
6419      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6420       common /przechowalnia/ zapas
6421       integer i,j,ii,jj,iproc,itask(4),nn
6422 c      write (iout,*) "itask",itask
6423       do i=1,2
6424         iproc=itask(i)
6425         if (iproc.gt.0) then
6426           do j=1,num_cont_hb(ii)
6427             jjc=jcont_hb(j,ii)
6428 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6429             if (jjc.eq.jj) then
6430               ncont_sent(iproc)=ncont_sent(iproc)+1
6431               nn=ncont_sent(iproc)
6432               zapas(1,nn,iproc)=ii
6433               zapas(2,nn,iproc)=jjc
6434               zapas(3,nn,iproc)=facont_hb(j,ii)
6435               zapas(4,nn,iproc)=ees0p(j,ii)
6436               zapas(5,nn,iproc)=ees0m(j,ii)
6437               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6438               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6439               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6440               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6441               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6442               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6443               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6444               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6445               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6446               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6447               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6448               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6449               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6450               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6451               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6452               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6453               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6454               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6455               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6456               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6457               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6458               exit
6459             endif
6460           enddo
6461         endif
6462       enddo
6463       return
6464       end
6465 c------------------------------------------------------------------------------
6466       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6467      &  n_corr1)
6468 C This subroutine calculates multi-body contributions to hydrogen-bonding
6469       implicit real*8 (a-h,o-z)
6470       include 'DIMENSIONS'
6471       include 'COMMON.IOUNITS'
6472 #ifdef MPI
6473       include "mpif.h"
6474       parameter (max_cont=maxconts)
6475       parameter (max_dim=70)
6476       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6477       double precision zapas(max_dim,maxconts,max_fg_procs),
6478      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6479       common /przechowalnia/ zapas
6480       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6481      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6482 #endif
6483       include 'COMMON.SETUP'
6484       include 'COMMON.FFIELD'
6485       include 'COMMON.DERIV'
6486       include 'COMMON.LOCAL'
6487       include 'COMMON.INTERACT'
6488       include 'COMMON.CONTACTS'
6489       include 'COMMON.CHAIN'
6490       include 'COMMON.CONTROL'
6491       double precision gx(3),gx1(3)
6492       integer num_cont_hb_old(maxres)
6493       logical lprn,ldone
6494       double precision eello4,eello5,eelo6,eello_turn6
6495       external eello4,eello5,eello6,eello_turn6
6496 C Set lprn=.true. for debugging
6497       lprn=.false.
6498       eturn6=0.0d0
6499 #ifdef MPI
6500       do i=1,nres
6501         num_cont_hb_old(i)=num_cont_hb(i)
6502       enddo
6503       n_corr=0
6504       n_corr1=0
6505       if (nfgtasks.le.1) goto 30
6506       if (lprn) then
6507         write (iout,'(a)') 'Contact function values before RECEIVE:'
6508         do i=nnt,nct-2
6509           write (iout,'(2i3,50(1x,i2,f5.2))')
6510      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6511      &    j=1,num_cont_hb(i))
6512         enddo
6513       endif
6514       call flush(iout)
6515       do i=1,ntask_cont_from
6516         ncont_recv(i)=0
6517       enddo
6518       do i=1,ntask_cont_to
6519         ncont_sent(i)=0
6520       enddo
6521 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6522 c     & ntask_cont_to
6523 C Make the list of contacts to send to send to other procesors
6524       do i=iturn3_start,iturn3_end
6525 c        write (iout,*) "make contact list turn3",i," num_cont",
6526 c     &    num_cont_hb(i)
6527         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6528       enddo
6529       do i=iturn4_start,iturn4_end
6530 c        write (iout,*) "make contact list turn4",i," num_cont",
6531 c     &   num_cont_hb(i)
6532         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6533       enddo
6534       do ii=1,nat_sent
6535         i=iat_sent(ii)
6536 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6537 c     &    num_cont_hb(i)
6538         do j=1,num_cont_hb(i)
6539         do k=1,4
6540           jjc=jcont_hb(j,i)
6541           iproc=iint_sent_local(k,jjc,ii)
6542 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6543           if (iproc.ne.0) then
6544             ncont_sent(iproc)=ncont_sent(iproc)+1
6545             nn=ncont_sent(iproc)
6546             zapas(1,nn,iproc)=i
6547             zapas(2,nn,iproc)=jjc
6548             zapas(3,nn,iproc)=d_cont(j,i)
6549             ind=3
6550             do kk=1,3
6551               ind=ind+1
6552               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6553             enddo
6554             do kk=1,2
6555               do ll=1,2
6556                 ind=ind+1
6557                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6558               enddo
6559             enddo
6560             do jj=1,5
6561               do kk=1,3
6562                 do ll=1,2
6563                   do mm=1,2
6564                     ind=ind+1
6565                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6566                   enddo
6567                 enddo
6568               enddo
6569             enddo
6570           endif
6571         enddo
6572         enddo
6573       enddo
6574       if (lprn) then
6575       write (iout,*)
6576      &  "Numbers of contacts to be sent to other processors",
6577      &  (ncont_sent(i),i=1,ntask_cont_to)
6578       write (iout,*) "Contacts sent"
6579       do ii=1,ntask_cont_to
6580         nn=ncont_sent(ii)
6581         iproc=itask_cont_to(ii)
6582         write (iout,*) nn," contacts to processor",iproc,
6583      &   " of CONT_TO_COMM group"
6584         do i=1,nn
6585           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6586         enddo
6587       enddo
6588       call flush(iout)
6589       endif
6590       CorrelType=477
6591       CorrelID=fg_rank+1
6592       CorrelType1=478
6593       CorrelID1=nfgtasks+fg_rank+1
6594       ireq=0
6595 C Receive the numbers of needed contacts from other processors
6596       do ii=1,ntask_cont_from
6597         iproc=itask_cont_from(ii)
6598         ireq=ireq+1
6599         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6600      &    FG_COMM,req(ireq),IERR)
6601       enddo
6602 c      write (iout,*) "IRECV ended"
6603 c      call flush(iout)
6604 C Send the number of contacts needed by other processors
6605       do ii=1,ntask_cont_to
6606         iproc=itask_cont_to(ii)
6607         ireq=ireq+1
6608         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6609      &    FG_COMM,req(ireq),IERR)
6610       enddo
6611 c      write (iout,*) "ISEND ended"
6612 c      write (iout,*) "number of requests (nn)",ireq
6613       call flush(iout)
6614       if (ireq.gt.0)
6615      &  call MPI_Waitall(ireq,req,status_array,ierr)
6616 c      write (iout,*)
6617 c     &  "Numbers of contacts to be received from other processors",
6618 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6619 c      call flush(iout)
6620 C Receive contacts
6621       ireq=0
6622       do ii=1,ntask_cont_from
6623         iproc=itask_cont_from(ii)
6624         nn=ncont_recv(ii)
6625 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6626 c     &   " of CONT_TO_COMM group"
6627         call flush(iout)
6628         if (nn.gt.0) then
6629           ireq=ireq+1
6630           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6631      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6632 c          write (iout,*) "ireq,req",ireq,req(ireq)
6633         endif
6634       enddo
6635 C Send the contacts to processors that need them
6636       do ii=1,ntask_cont_to
6637         iproc=itask_cont_to(ii)
6638         nn=ncont_sent(ii)
6639 c        write (iout,*) nn," contacts to processor",iproc,
6640 c     &   " of CONT_TO_COMM group"
6641         if (nn.gt.0) then
6642           ireq=ireq+1
6643           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6644      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6645 c          write (iout,*) "ireq,req",ireq,req(ireq)
6646 c          do i=1,nn
6647 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6648 c          enddo
6649         endif
6650       enddo
6651 c      write (iout,*) "number of requests (contacts)",ireq
6652 c      write (iout,*) "req",(req(i),i=1,4)
6653 c      call flush(iout)
6654       if (ireq.gt.0)
6655      & call MPI_Waitall(ireq,req,status_array,ierr)
6656       do iii=1,ntask_cont_from
6657         iproc=itask_cont_from(iii)
6658         nn=ncont_recv(iii)
6659         if (lprn) then
6660         write (iout,*) "Received",nn," contacts from processor",iproc,
6661      &   " of CONT_FROM_COMM group"
6662         call flush(iout)
6663         do i=1,nn
6664           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6665         enddo
6666         call flush(iout)
6667         endif
6668         do i=1,nn
6669           ii=zapas_recv(1,i,iii)
6670 c Flag the received contacts to prevent double-counting
6671           jj=-zapas_recv(2,i,iii)
6672 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6673 c          call flush(iout)
6674           nnn=num_cont_hb(ii)+1
6675           num_cont_hb(ii)=nnn
6676           jcont_hb(nnn,ii)=jj
6677           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6678           ind=3
6679           do kk=1,3
6680             ind=ind+1
6681             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6682           enddo
6683           do kk=1,2
6684             do ll=1,2
6685               ind=ind+1
6686               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6687             enddo
6688           enddo
6689           do jj=1,5
6690             do kk=1,3
6691               do ll=1,2
6692                 do mm=1,2
6693                   ind=ind+1
6694                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6695                 enddo
6696               enddo
6697             enddo
6698           enddo
6699         enddo
6700       enddo
6701       call flush(iout)
6702       if (lprn) then
6703         write (iout,'(a)') 'Contact function values after receive:'
6704         do i=nnt,nct-2
6705           write (iout,'(2i3,50(1x,i3,5f6.3))')
6706      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6707      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6708         enddo
6709         call flush(iout)
6710       endif
6711    30 continue
6712 #endif
6713       if (lprn) then
6714         write (iout,'(a)') 'Contact function values:'
6715         do i=nnt,nct-2
6716           write (iout,'(2i3,50(1x,i2,5f6.3))')
6717      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6718      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6719         enddo
6720       endif
6721       ecorr=0.0D0
6722       ecorr5=0.0d0
6723       ecorr6=0.0d0
6724 C Remove the loop below after debugging !!!
6725       do i=nnt,nct
6726         do j=1,3
6727           gradcorr(j,i)=0.0D0
6728           gradxorr(j,i)=0.0D0
6729         enddo
6730       enddo
6731 C Calculate the dipole-dipole interaction energies
6732       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6733       do i=iatel_s,iatel_e+1
6734         num_conti=num_cont_hb(i)
6735         do jj=1,num_conti
6736           j=jcont_hb(jj,i)
6737 #ifdef MOMENT
6738           call dipole(i,j,jj)
6739 #endif
6740         enddo
6741       enddo
6742       endif
6743 C Calculate the local-electrostatic correlation terms
6744 c                write (iout,*) "gradcorr5 in eello5 before loop"
6745 c                do iii=1,nres
6746 c                  write (iout,'(i5,3f10.5)')
6747 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6748 c                enddo
6749       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6750 c        write (iout,*) "corr loop i",i
6751         i1=i+1
6752         num_conti=num_cont_hb(i)
6753         num_conti1=num_cont_hb(i+1)
6754         do jj=1,num_conti
6755           j=jcont_hb(jj,i)
6756           jp=iabs(j)
6757           do kk=1,num_conti1
6758             j1=jcont_hb(kk,i1)
6759             jp1=iabs(j1)
6760 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6761 c     &         ' jj=',jj,' kk=',kk
6762 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6763             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6764      &          .or. j.lt.0 .and. j1.gt.0) .and.
6765      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6766 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6767 C The system gains extra energy.
6768               n_corr=n_corr+1
6769               sqd1=dsqrt(d_cont(jj,i))
6770               sqd2=dsqrt(d_cont(kk,i1))
6771               sred_geom = sqd1*sqd2
6772               IF (sred_geom.lt.cutoff_corr) THEN
6773                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6774      &            ekont,fprimcont)
6775 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6776 cd     &         ' jj=',jj,' kk=',kk
6777                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6778                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6779                 do l=1,3
6780                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6781                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6782                 enddo
6783                 n_corr1=n_corr1+1
6784 cd               write (iout,*) 'sred_geom=',sred_geom,
6785 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6786 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6787 cd               write (iout,*) "g_contij",g_contij
6788 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6789 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6790                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6791                 if (wcorr4.gt.0.0d0)
6792      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6793                   if (energy_dec.and.wcorr4.gt.0.0d0)
6794      1                 write (iout,'(a6,4i5,0pf7.3)')
6795      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6796 c                write (iout,*) "gradcorr5 before eello5"
6797 c                do iii=1,nres
6798 c                  write (iout,'(i5,3f10.5)')
6799 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6800 c                enddo
6801                 if (wcorr5.gt.0.0d0)
6802      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6803 c                write (iout,*) "gradcorr5 after eello5"
6804 c                do iii=1,nres
6805 c                  write (iout,'(i5,3f10.5)')
6806 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6807 c                enddo
6808                   if (energy_dec.and.wcorr5.gt.0.0d0)
6809      1                 write (iout,'(a6,4i5,0pf7.3)')
6810      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6811 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6812 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6813                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6814      &               .or. wturn6.eq.0.0d0))then
6815 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6816                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6817                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6818      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6819 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6820 cd     &            'ecorr6=',ecorr6
6821 cd                write (iout,'(4e15.5)') sred_geom,
6822 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6823 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6824 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6825                 else if (wturn6.gt.0.0d0
6826      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6827 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6828                   eturn6=eturn6+eello_turn6(i,jj,kk)
6829                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6830      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6831 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6832                 endif
6833               ENDIF
6834 1111          continue
6835             endif
6836           enddo ! kk
6837         enddo ! jj
6838       enddo ! i
6839       do i=1,nres
6840         num_cont_hb(i)=num_cont_hb_old(i)
6841       enddo
6842 c                write (iout,*) "gradcorr5 in eello5"
6843 c                do iii=1,nres
6844 c                  write (iout,'(i5,3f10.5)')
6845 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6846 c                enddo
6847       return
6848       end
6849 c------------------------------------------------------------------------------
6850       subroutine add_hb_contact_eello(ii,jj,itask)
6851       implicit real*8 (a-h,o-z)
6852       include "DIMENSIONS"
6853       include "COMMON.IOUNITS"
6854       integer max_cont
6855       integer max_dim
6856       parameter (max_cont=maxconts)
6857       parameter (max_dim=70)
6858       include "COMMON.CONTACTS"
6859       double precision zapas(max_dim,maxconts,max_fg_procs),
6860      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6861       common /przechowalnia/ zapas
6862       integer i,j,ii,jj,iproc,itask(4),nn
6863 c      write (iout,*) "itask",itask
6864       do i=1,2
6865         iproc=itask(i)
6866         if (iproc.gt.0) then
6867           do j=1,num_cont_hb(ii)
6868             jjc=jcont_hb(j,ii)
6869 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6870             if (jjc.eq.jj) then
6871               ncont_sent(iproc)=ncont_sent(iproc)+1
6872               nn=ncont_sent(iproc)
6873               zapas(1,nn,iproc)=ii
6874               zapas(2,nn,iproc)=jjc
6875               zapas(3,nn,iproc)=d_cont(j,ii)
6876               ind=3
6877               do kk=1,3
6878                 ind=ind+1
6879                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6880               enddo
6881               do kk=1,2
6882                 do ll=1,2
6883                   ind=ind+1
6884                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6885                 enddo
6886               enddo
6887               do jj=1,5
6888                 do kk=1,3
6889                   do ll=1,2
6890                     do mm=1,2
6891                       ind=ind+1
6892                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6893                     enddo
6894                   enddo
6895                 enddo
6896               enddo
6897               exit
6898             endif
6899           enddo
6900         endif
6901       enddo
6902       return
6903       end
6904 c------------------------------------------------------------------------------
6905       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6906       implicit real*8 (a-h,o-z)
6907       include 'DIMENSIONS'
6908       include 'COMMON.IOUNITS'
6909       include 'COMMON.DERIV'
6910       include 'COMMON.INTERACT'
6911       include 'COMMON.CONTACTS'
6912       double precision gx(3),gx1(3)
6913       logical lprn
6914       lprn=.false.
6915       eij=facont_hb(jj,i)
6916       ekl=facont_hb(kk,k)
6917       ees0pij=ees0p(jj,i)
6918       ees0pkl=ees0p(kk,k)
6919       ees0mij=ees0m(jj,i)
6920       ees0mkl=ees0m(kk,k)
6921       ekont=eij*ekl
6922       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6923 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6924 C Following 4 lines for diagnostics.
6925 cd    ees0pkl=0.0D0
6926 cd    ees0pij=1.0D0
6927 cd    ees0mkl=0.0D0
6928 cd    ees0mij=1.0D0
6929 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6930 c     & 'Contacts ',i,j,
6931 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6932 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6933 c     & 'gradcorr_long'
6934 C Calculate the multi-body contribution to energy.
6935 c      ecorr=ecorr+ekont*ees
6936 C Calculate multi-body contributions to the gradient.
6937       coeffpees0pij=coeffp*ees0pij
6938       coeffmees0mij=coeffm*ees0mij
6939       coeffpees0pkl=coeffp*ees0pkl
6940       coeffmees0mkl=coeffm*ees0mkl
6941       do ll=1,3
6942 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6943         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6944      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6945      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6946         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6947      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6948      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6949 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6950         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6951      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6952      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6953         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6954      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6955      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6956         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6957      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6958      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6959         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6960         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6961         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6962      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6963      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6964         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6965         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6966 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6967       enddo
6968 c      write (iout,*)
6969 cgrad      do m=i+1,j-1
6970 cgrad        do ll=1,3
6971 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6972 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6973 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6974 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6975 cgrad        enddo
6976 cgrad      enddo
6977 cgrad      do m=k+1,l-1
6978 cgrad        do ll=1,3
6979 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6980 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6981 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6982 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6983 cgrad        enddo
6984 cgrad      enddo
6985 c      write (iout,*) "ehbcorr",ekont*ees
6986       ehbcorr=ekont*ees
6987       return
6988       end
6989 #ifdef MOMENT
6990 C---------------------------------------------------------------------------
6991       subroutine dipole(i,j,jj)
6992       implicit real*8 (a-h,o-z)
6993       include 'DIMENSIONS'
6994       include 'COMMON.IOUNITS'
6995       include 'COMMON.CHAIN'
6996       include 'COMMON.FFIELD'
6997       include 'COMMON.DERIV'
6998       include 'COMMON.INTERACT'
6999       include 'COMMON.CONTACTS'
7000       include 'COMMON.TORSION'
7001       include 'COMMON.VAR'
7002       include 'COMMON.GEO'
7003       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7004      &  auxmat(2,2)
7005       iti1 = itortyp(itype(i+1))
7006       if (j.lt.nres-1) then
7007         itj1 = itortyp(itype(j+1))
7008       else
7009         itj1=ntortyp+1
7010       endif
7011       do iii=1,2
7012         dipi(iii,1)=Ub2(iii,i)
7013         dipderi(iii)=Ub2der(iii,i)
7014         dipi(iii,2)=b1(iii,iti1)
7015         dipj(iii,1)=Ub2(iii,j)
7016         dipderj(iii)=Ub2der(iii,j)
7017         dipj(iii,2)=b1(iii,itj1)
7018       enddo
7019       kkk=0
7020       do iii=1,2
7021         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7022         do jjj=1,2
7023           kkk=kkk+1
7024           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7025         enddo
7026       enddo
7027       do kkk=1,5
7028         do lll=1,3
7029           mmm=0
7030           do iii=1,2
7031             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7032      &        auxvec(1))
7033             do jjj=1,2
7034               mmm=mmm+1
7035               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7036             enddo
7037           enddo
7038         enddo
7039       enddo
7040       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7041       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7042       do iii=1,2
7043         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7044       enddo
7045       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7046       do iii=1,2
7047         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7048       enddo
7049       return
7050       end
7051 #endif
7052 C---------------------------------------------------------------------------
7053       subroutine calc_eello(i,j,k,l,jj,kk)
7054 C
7055 C This subroutine computes matrices and vectors needed to calculate
7056 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7057 C
7058       implicit real*8 (a-h,o-z)
7059       include 'DIMENSIONS'
7060       include 'COMMON.IOUNITS'
7061       include 'COMMON.CHAIN'
7062       include 'COMMON.DERIV'
7063       include 'COMMON.INTERACT'
7064       include 'COMMON.CONTACTS'
7065       include 'COMMON.TORSION'
7066       include 'COMMON.VAR'
7067       include 'COMMON.GEO'
7068       include 'COMMON.FFIELD'
7069       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7070      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7071       logical lprn
7072       common /kutas/ lprn
7073 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7074 cd     & ' jj=',jj,' kk=',kk
7075 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7076 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7077 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7078       do iii=1,2
7079         do jjj=1,2
7080           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7081           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7082         enddo
7083       enddo
7084       call transpose2(aa1(1,1),aa1t(1,1))
7085       call transpose2(aa2(1,1),aa2t(1,1))
7086       do kkk=1,5
7087         do lll=1,3
7088           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7089      &      aa1tder(1,1,lll,kkk))
7090           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7091      &      aa2tder(1,1,lll,kkk))
7092         enddo
7093       enddo
7094       if (l.eq.j+1) then
7095 C parallel orientation of the two CA-CA-CA frames.
7096         if (i.gt.1) then
7097           iti=itortyp(itype(i))
7098         else
7099           iti=ntortyp+1
7100         endif
7101         itk1=itortyp(itype(k+1))
7102         itj=itortyp(itype(j))
7103         if (l.lt.nres-1) then
7104           itl1=itortyp(itype(l+1))
7105         else
7106           itl1=ntortyp+1
7107         endif
7108 C A1 kernel(j+1) A2T
7109 cd        do iii=1,2
7110 cd          write (iout,'(3f10.5,5x,3f10.5)')
7111 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7112 cd        enddo
7113         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7114      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7115      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7116 C Following matrices are needed only for 6-th order cumulants
7117         IF (wcorr6.gt.0.0d0) THEN
7118         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7119      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7120      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7121         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7122      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7123      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7124      &   ADtEAderx(1,1,1,1,1,1))
7125         lprn=.false.
7126         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7127      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7128      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7129      &   ADtEA1derx(1,1,1,1,1,1))
7130         ENDIF
7131 C End 6-th order cumulants
7132 cd        lprn=.false.
7133 cd        if (lprn) then
7134 cd        write (2,*) 'In calc_eello6'
7135 cd        do iii=1,2
7136 cd          write (2,*) 'iii=',iii
7137 cd          do kkk=1,5
7138 cd            write (2,*) 'kkk=',kkk
7139 cd            do jjj=1,2
7140 cd              write (2,'(3(2f10.5),5x)')
7141 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7142 cd            enddo
7143 cd          enddo
7144 cd        enddo
7145 cd        endif
7146         call transpose2(EUgder(1,1,k),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7148         call transpose2(EUg(1,1,k),auxmat(1,1))
7149         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7150         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7151         do iii=1,2
7152           do kkk=1,5
7153             do lll=1,3
7154               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7155      &          EAEAderx(1,1,lll,kkk,iii,1))
7156             enddo
7157           enddo
7158         enddo
7159 C A1T kernel(i+1) A2
7160         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7161      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7162      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7163 C Following matrices are needed only for 6-th order cumulants
7164         IF (wcorr6.gt.0.0d0) THEN
7165         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7166      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7167      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7168         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7169      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7170      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7171      &   ADtEAderx(1,1,1,1,1,2))
7172         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7173      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7174      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7175      &   ADtEA1derx(1,1,1,1,1,2))
7176         ENDIF
7177 C End 6-th order cumulants
7178         call transpose2(EUgder(1,1,l),auxmat(1,1))
7179         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7180         call transpose2(EUg(1,1,l),auxmat(1,1))
7181         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7182         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7183         do iii=1,2
7184           do kkk=1,5
7185             do lll=1,3
7186               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7187      &          EAEAderx(1,1,lll,kkk,iii,2))
7188             enddo
7189           enddo
7190         enddo
7191 C AEAb1 and AEAb2
7192 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7193 C They are needed only when the fifth- or the sixth-order cumulants are
7194 C indluded.
7195         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7196         call transpose2(AEA(1,1,1),auxmat(1,1))
7197         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7198         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7200         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7202         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7203         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7204         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7205         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7206         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7207         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7208         call transpose2(AEA(1,1,2),auxmat(1,1))
7209         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7210         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7212         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7214         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7215         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7216         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7217         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7218         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7219         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7220 C Calculate the Cartesian derivatives of the vectors.
7221         do iii=1,2
7222           do kkk=1,5
7223             do lll=1,3
7224               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7225               call matvec2(auxmat(1,1),b1(1,iti),
7226      &          AEAb1derx(1,lll,kkk,iii,1,1))
7227               call matvec2(auxmat(1,1),Ub2(1,i),
7228      &          AEAb2derx(1,lll,kkk,iii,1,1))
7229               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7230      &          AEAb1derx(1,lll,kkk,iii,2,1))
7231               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7232      &          AEAb2derx(1,lll,kkk,iii,2,1))
7233               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7234               call matvec2(auxmat(1,1),b1(1,itj),
7235      &          AEAb1derx(1,lll,kkk,iii,1,2))
7236               call matvec2(auxmat(1,1),Ub2(1,j),
7237      &          AEAb2derx(1,lll,kkk,iii,1,2))
7238               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7239      &          AEAb1derx(1,lll,kkk,iii,2,2))
7240               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7241      &          AEAb2derx(1,lll,kkk,iii,2,2))
7242             enddo
7243           enddo
7244         enddo
7245         ENDIF
7246 C End vectors
7247       else
7248 C Antiparallel orientation of the two CA-CA-CA frames.
7249         if (i.gt.1) then
7250           iti=itortyp(itype(i))
7251         else
7252           iti=ntortyp+1
7253         endif
7254         itk1=itortyp(itype(k+1))
7255         itl=itortyp(itype(l))
7256         itj=itortyp(itype(j))
7257         if (j.lt.nres-1) then
7258           itj1=itortyp(itype(j+1))
7259         else
7260           itj1=ntortyp+1
7261         endif
7262 C A2 kernel(j-1)T A1T
7263         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7264      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7265      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7266 C Following matrices are needed only for 6-th order cumulants
7267         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7268      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7269         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7270      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7271      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7272         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7273      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7274      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7275      &   ADtEAderx(1,1,1,1,1,1))
7276         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7277      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7278      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7279      &   ADtEA1derx(1,1,1,1,1,1))
7280         ENDIF
7281 C End 6-th order cumulants
7282         call transpose2(EUgder(1,1,k),auxmat(1,1))
7283         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7284         call transpose2(EUg(1,1,k),auxmat(1,1))
7285         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7286         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7287         do iii=1,2
7288           do kkk=1,5
7289             do lll=1,3
7290               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7291      &          EAEAderx(1,1,lll,kkk,iii,1))
7292             enddo
7293           enddo
7294         enddo
7295 C A2T kernel(i+1)T A1
7296         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7297      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7298      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7299 C Following matrices are needed only for 6-th order cumulants
7300         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7301      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7302         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7303      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7304      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7305         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7306      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7307      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7308      &   ADtEAderx(1,1,1,1,1,2))
7309         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7310      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7311      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7312      &   ADtEA1derx(1,1,1,1,1,2))
7313         ENDIF
7314 C End 6-th order cumulants
7315         call transpose2(EUgder(1,1,j),auxmat(1,1))
7316         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7317         call transpose2(EUg(1,1,j),auxmat(1,1))
7318         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7319         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7320         do iii=1,2
7321           do kkk=1,5
7322             do lll=1,3
7323               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7324      &          EAEAderx(1,1,lll,kkk,iii,2))
7325             enddo
7326           enddo
7327         enddo
7328 C AEAb1 and AEAb2
7329 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7330 C They are needed only when the fifth- or the sixth-order cumulants are
7331 C indluded.
7332         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7333      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7334         call transpose2(AEA(1,1,1),auxmat(1,1))
7335         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7336         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7337         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7338         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7339         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7340         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7341         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7342         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7343         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7344         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7345         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7346         call transpose2(AEA(1,1,2),auxmat(1,1))
7347         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7348         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7349         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7350         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7351         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7352         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7353         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7354         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7355         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7356         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7357         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7358 C Calculate the Cartesian derivatives of the vectors.
7359         do iii=1,2
7360           do kkk=1,5
7361             do lll=1,3
7362               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7363               call matvec2(auxmat(1,1),b1(1,iti),
7364      &          AEAb1derx(1,lll,kkk,iii,1,1))
7365               call matvec2(auxmat(1,1),Ub2(1,i),
7366      &          AEAb2derx(1,lll,kkk,iii,1,1))
7367               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7368      &          AEAb1derx(1,lll,kkk,iii,2,1))
7369               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7370      &          AEAb2derx(1,lll,kkk,iii,2,1))
7371               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7372               call matvec2(auxmat(1,1),b1(1,itl),
7373      &          AEAb1derx(1,lll,kkk,iii,1,2))
7374               call matvec2(auxmat(1,1),Ub2(1,l),
7375      &          AEAb2derx(1,lll,kkk,iii,1,2))
7376               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7377      &          AEAb1derx(1,lll,kkk,iii,2,2))
7378               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7379      &          AEAb2derx(1,lll,kkk,iii,2,2))
7380             enddo
7381           enddo
7382         enddo
7383         ENDIF
7384 C End vectors
7385       endif
7386       return
7387       end
7388 C---------------------------------------------------------------------------
7389       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7390      &  KK,KKderg,AKA,AKAderg,AKAderx)
7391       implicit none
7392       integer nderg
7393       logical transp
7394       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7395      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7396      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7397       integer iii,kkk,lll
7398       integer jjj,mmm
7399       logical lprn
7400       common /kutas/ lprn
7401       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7402       do iii=1,nderg
7403         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7404      &    AKAderg(1,1,iii))
7405       enddo
7406 cd      if (lprn) write (2,*) 'In kernel'
7407       do kkk=1,5
7408 cd        if (lprn) write (2,*) 'kkk=',kkk
7409         do lll=1,3
7410           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7411      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7412 cd          if (lprn) then
7413 cd            write (2,*) 'lll=',lll
7414 cd            write (2,*) 'iii=1'
7415 cd            do jjj=1,2
7416 cd              write (2,'(3(2f10.5),5x)')
7417 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7418 cd            enddo
7419 cd          endif
7420           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7421      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7422 cd          if (lprn) then
7423 cd            write (2,*) 'lll=',lll
7424 cd            write (2,*) 'iii=2'
7425 cd            do jjj=1,2
7426 cd              write (2,'(3(2f10.5),5x)')
7427 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7428 cd            enddo
7429 cd          endif
7430         enddo
7431       enddo
7432       return
7433       end
7434 C---------------------------------------------------------------------------
7435       double precision function eello4(i,j,k,l,jj,kk)
7436       implicit real*8 (a-h,o-z)
7437       include 'DIMENSIONS'
7438       include 'COMMON.IOUNITS'
7439       include 'COMMON.CHAIN'
7440       include 'COMMON.DERIV'
7441       include 'COMMON.INTERACT'
7442       include 'COMMON.CONTACTS'
7443       include 'COMMON.TORSION'
7444       include 'COMMON.VAR'
7445       include 'COMMON.GEO'
7446       double precision pizda(2,2),ggg1(3),ggg2(3)
7447 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7448 cd        eello4=0.0d0
7449 cd        return
7450 cd      endif
7451 cd      print *,'eello4:',i,j,k,l,jj,kk
7452 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7453 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7454 cold      eij=facont_hb(jj,i)
7455 cold      ekl=facont_hb(kk,k)
7456 cold      ekont=eij*ekl
7457       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7458 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7459       gcorr_loc(k-1)=gcorr_loc(k-1)
7460      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7461       if (l.eq.j+1) then
7462         gcorr_loc(l-1)=gcorr_loc(l-1)
7463      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7464       else
7465         gcorr_loc(j-1)=gcorr_loc(j-1)
7466      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7467       endif
7468       do iii=1,2
7469         do kkk=1,5
7470           do lll=1,3
7471             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7472      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7473 cd            derx(lll,kkk,iii)=0.0d0
7474           enddo
7475         enddo
7476       enddo
7477 cd      gcorr_loc(l-1)=0.0d0
7478 cd      gcorr_loc(j-1)=0.0d0
7479 cd      gcorr_loc(k-1)=0.0d0
7480 cd      eel4=1.0d0
7481 cd      write (iout,*)'Contacts have occurred for peptide groups',
7482 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7483 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7484       if (j.lt.nres-1) then
7485         j1=j+1
7486         j2=j-1
7487       else
7488         j1=j-1
7489         j2=j-2
7490       endif
7491       if (l.lt.nres-1) then
7492         l1=l+1
7493         l2=l-1
7494       else
7495         l1=l-1
7496         l2=l-2
7497       endif
7498       do ll=1,3
7499 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7500 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7501         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7502         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7503 cgrad        ghalf=0.5d0*ggg1(ll)
7504         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7505         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7506         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7507         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7508         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7509         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7510 cgrad        ghalf=0.5d0*ggg2(ll)
7511         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7512         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7513         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7514         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7515         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7516         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7517       enddo
7518 cgrad      do m=i+1,j-1
7519 cgrad        do ll=1,3
7520 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7521 cgrad        enddo
7522 cgrad      enddo
7523 cgrad      do m=k+1,l-1
7524 cgrad        do ll=1,3
7525 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7526 cgrad        enddo
7527 cgrad      enddo
7528 cgrad      do m=i+2,j2
7529 cgrad        do ll=1,3
7530 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7531 cgrad        enddo
7532 cgrad      enddo
7533 cgrad      do m=k+2,l2
7534 cgrad        do ll=1,3
7535 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7536 cgrad        enddo
7537 cgrad      enddo
7538 cd      do iii=1,nres-3
7539 cd        write (2,*) iii,gcorr_loc(iii)
7540 cd      enddo
7541       eello4=ekont*eel4
7542 cd      write (2,*) 'ekont',ekont
7543 cd      write (iout,*) 'eello4',ekont*eel4
7544       return
7545       end
7546 C---------------------------------------------------------------------------
7547       double precision function eello5(i,j,k,l,jj,kk)
7548       implicit real*8 (a-h,o-z)
7549       include 'DIMENSIONS'
7550       include 'COMMON.IOUNITS'
7551       include 'COMMON.CHAIN'
7552       include 'COMMON.DERIV'
7553       include 'COMMON.INTERACT'
7554       include 'COMMON.CONTACTS'
7555       include 'COMMON.TORSION'
7556       include 'COMMON.VAR'
7557       include 'COMMON.GEO'
7558       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7559       double precision ggg1(3),ggg2(3)
7560 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7561 C                                                                              C
7562 C                            Parallel chains                                   C
7563 C                                                                              C
7564 C          o             o                   o             o                   C
7565 C         /l\           / \             \   / \           / \   /              C
7566 C        /   \         /   \             \ /   \         /   \ /               C
7567 C       j| o |l1       | o |              o| o |         | o |o                C
7568 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7569 C      \i/   \         /   \ /             /   \         /   \                 C
7570 C       o    k1             o                                                  C
7571 C         (I)          (II)                (III)          (IV)                 C
7572 C                                                                              C
7573 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7574 C                                                                              C
7575 C                            Antiparallel chains                               C
7576 C                                                                              C
7577 C          o             o                   o             o                   C
7578 C         /j\           / \             \   / \           / \   /              C
7579 C        /   \         /   \             \ /   \         /   \ /               C
7580 C      j1| o |l        | o |              o| o |         | o |o                C
7581 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7582 C      \i/   \         /   \ /             /   \         /   \                 C
7583 C       o     k1            o                                                  C
7584 C         (I)          (II)                (III)          (IV)                 C
7585 C                                                                              C
7586 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7587 C                                                                              C
7588 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7589 C                                                                              C
7590 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7591 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7592 cd        eello5=0.0d0
7593 cd        return
7594 cd      endif
7595 cd      write (iout,*)
7596 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7597 cd     &   ' and',k,l
7598       itk=itortyp(itype(k))
7599       itl=itortyp(itype(l))
7600       itj=itortyp(itype(j))
7601       eello5_1=0.0d0
7602       eello5_2=0.0d0
7603       eello5_3=0.0d0
7604       eello5_4=0.0d0
7605 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7606 cd     &   eel5_3_num,eel5_4_num)
7607       do iii=1,2
7608         do kkk=1,5
7609           do lll=1,3
7610             derx(lll,kkk,iii)=0.0d0
7611           enddo
7612         enddo
7613       enddo
7614 cd      eij=facont_hb(jj,i)
7615 cd      ekl=facont_hb(kk,k)
7616 cd      ekont=eij*ekl
7617 cd      write (iout,*)'Contacts have occurred for peptide groups',
7618 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7619 cd      goto 1111
7620 C Contribution from the graph I.
7621 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7622 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7623       call transpose2(EUg(1,1,k),auxmat(1,1))
7624       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7625       vv(1)=pizda(1,1)-pizda(2,2)
7626       vv(2)=pizda(1,2)+pizda(2,1)
7627       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7628      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7629 C Explicit gradient in virtual-dihedral angles.
7630       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7631      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7632      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7633       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7634       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7635       vv(1)=pizda(1,1)-pizda(2,2)
7636       vv(2)=pizda(1,2)+pizda(2,1)
7637       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7638      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7639      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7640       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7641       vv(1)=pizda(1,1)-pizda(2,2)
7642       vv(2)=pizda(1,2)+pizda(2,1)
7643       if (l.eq.j+1) then
7644         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7645      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7646      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7647       else
7648         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7649      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7651       endif
7652 C Cartesian gradient
7653       do iii=1,2
7654         do kkk=1,5
7655           do lll=1,3
7656             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7657      &        pizda(1,1))
7658             vv(1)=pizda(1,1)-pizda(2,2)
7659             vv(2)=pizda(1,2)+pizda(2,1)
7660             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7661      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7662      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7663           enddo
7664         enddo
7665       enddo
7666 c      goto 1112
7667 c1111  continue
7668 C Contribution from graph II
7669       call transpose2(EE(1,1,itk),auxmat(1,1))
7670       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7671       vv(1)=pizda(1,1)+pizda(2,2)
7672       vv(2)=pizda(2,1)-pizda(1,2)
7673       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7674      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7675 C Explicit gradient in virtual-dihedral angles.
7676       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7677      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7678       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7679       vv(1)=pizda(1,1)+pizda(2,2)
7680       vv(2)=pizda(2,1)-pizda(1,2)
7681       if (l.eq.j+1) then
7682         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7683      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7684      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7685       else
7686         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7687      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7688      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7689       endif
7690 C Cartesian gradient
7691       do iii=1,2
7692         do kkk=1,5
7693           do lll=1,3
7694             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7695      &        pizda(1,1))
7696             vv(1)=pizda(1,1)+pizda(2,2)
7697             vv(2)=pizda(2,1)-pizda(1,2)
7698             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7699      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7700      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7701           enddo
7702         enddo
7703       enddo
7704 cd      goto 1112
7705 cd1111  continue
7706       if (l.eq.j+1) then
7707 cd        goto 1110
7708 C Parallel orientation
7709 C Contribution from graph III
7710         call transpose2(EUg(1,1,l),auxmat(1,1))
7711         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7712         vv(1)=pizda(1,1)-pizda(2,2)
7713         vv(2)=pizda(1,2)+pizda(2,1)
7714         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7715      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7716 C Explicit gradient in virtual-dihedral angles.
7717         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7718      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7720         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7721         vv(1)=pizda(1,1)-pizda(2,2)
7722         vv(2)=pizda(1,2)+pizda(2,1)
7723         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7724      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7726         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7727         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7728         vv(1)=pizda(1,1)-pizda(2,2)
7729         vv(2)=pizda(1,2)+pizda(2,1)
7730         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7731      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7732      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7733 C Cartesian gradient
7734         do iii=1,2
7735           do kkk=1,5
7736             do lll=1,3
7737               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7738      &          pizda(1,1))
7739               vv(1)=pizda(1,1)-pizda(2,2)
7740               vv(2)=pizda(1,2)+pizda(2,1)
7741               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7742      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7743      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7744             enddo
7745           enddo
7746         enddo
7747 cd        goto 1112
7748 C Contribution from graph IV
7749 cd1110    continue
7750         call transpose2(EE(1,1,itl),auxmat(1,1))
7751         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7752         vv(1)=pizda(1,1)+pizda(2,2)
7753         vv(2)=pizda(2,1)-pizda(1,2)
7754         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7755      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7756 C Explicit gradient in virtual-dihedral angles.
7757         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7758      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7759         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7760         vv(1)=pizda(1,1)+pizda(2,2)
7761         vv(2)=pizda(2,1)-pizda(1,2)
7762         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7763      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7764      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7765 C Cartesian gradient
7766         do iii=1,2
7767           do kkk=1,5
7768             do lll=1,3
7769               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7770      &          pizda(1,1))
7771               vv(1)=pizda(1,1)+pizda(2,2)
7772               vv(2)=pizda(2,1)-pizda(1,2)
7773               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7774      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7775      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7776             enddo
7777           enddo
7778         enddo
7779       else
7780 C Antiparallel orientation
7781 C Contribution from graph III
7782 c        goto 1110
7783         call transpose2(EUg(1,1,j),auxmat(1,1))
7784         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7785         vv(1)=pizda(1,1)-pizda(2,2)
7786         vv(2)=pizda(1,2)+pizda(2,1)
7787         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7788      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7789 C Explicit gradient in virtual-dihedral angles.
7790         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7791      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7792      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7793         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7794         vv(1)=pizda(1,1)-pizda(2,2)
7795         vv(2)=pizda(1,2)+pizda(2,1)
7796         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7797      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7798      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7799         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7800         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7801         vv(1)=pizda(1,1)-pizda(2,2)
7802         vv(2)=pizda(1,2)+pizda(2,1)
7803         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7804      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7805      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7806 C Cartesian gradient
7807         do iii=1,2
7808           do kkk=1,5
7809             do lll=1,3
7810               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7811      &          pizda(1,1))
7812               vv(1)=pizda(1,1)-pizda(2,2)
7813               vv(2)=pizda(1,2)+pizda(2,1)
7814               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7815      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7816      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7817             enddo
7818           enddo
7819         enddo
7820 cd        goto 1112
7821 C Contribution from graph IV
7822 1110    continue
7823         call transpose2(EE(1,1,itj),auxmat(1,1))
7824         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7825         vv(1)=pizda(1,1)+pizda(2,2)
7826         vv(2)=pizda(2,1)-pizda(1,2)
7827         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7828      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7829 C Explicit gradient in virtual-dihedral angles.
7830         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7831      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7832         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7833         vv(1)=pizda(1,1)+pizda(2,2)
7834         vv(2)=pizda(2,1)-pizda(1,2)
7835         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7836      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7837      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7838 C Cartesian gradient
7839         do iii=1,2
7840           do kkk=1,5
7841             do lll=1,3
7842               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7843      &          pizda(1,1))
7844               vv(1)=pizda(1,1)+pizda(2,2)
7845               vv(2)=pizda(2,1)-pizda(1,2)
7846               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7847      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7848      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7849             enddo
7850           enddo
7851         enddo
7852       endif
7853 1112  continue
7854       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7855 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7856 cd        write (2,*) 'ijkl',i,j,k,l
7857 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7858 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7859 cd      endif
7860 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7861 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7862 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7863 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7864       if (j.lt.nres-1) then
7865         j1=j+1
7866         j2=j-1
7867       else
7868         j1=j-1
7869         j2=j-2
7870       endif
7871       if (l.lt.nres-1) then
7872         l1=l+1
7873         l2=l-1
7874       else
7875         l1=l-1
7876         l2=l-2
7877       endif
7878 cd      eij=1.0d0
7879 cd      ekl=1.0d0
7880 cd      ekont=1.0d0
7881 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7882 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7883 C        summed up outside the subrouine as for the other subroutines
7884 C        handling long-range interactions. The old code is commented out
7885 C        with "cgrad" to keep track of changes.
7886       do ll=1,3
7887 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7888 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7889         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7890         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7891 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7892 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7893 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7894 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7895 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7896 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7897 c     &   gradcorr5ij,
7898 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7899 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7900 cgrad        ghalf=0.5d0*ggg1(ll)
7901 cd        ghalf=0.0d0
7902         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7903         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7904         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7905         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7906         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7907         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7908 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7909 cgrad        ghalf=0.5d0*ggg2(ll)
7910 cd        ghalf=0.0d0
7911         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7912         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7913         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7914         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7915         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7916         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7917       enddo
7918 cd      goto 1112
7919 cgrad      do m=i+1,j-1
7920 cgrad        do ll=1,3
7921 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7922 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7923 cgrad        enddo
7924 cgrad      enddo
7925 cgrad      do m=k+1,l-1
7926 cgrad        do ll=1,3
7927 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7928 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7929 cgrad        enddo
7930 cgrad      enddo
7931 c1112  continue
7932 cgrad      do m=i+2,j2
7933 cgrad        do ll=1,3
7934 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7935 cgrad        enddo
7936 cgrad      enddo
7937 cgrad      do m=k+2,l2
7938 cgrad        do ll=1,3
7939 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7940 cgrad        enddo
7941 cgrad      enddo
7942 cd      do iii=1,nres-3
7943 cd        write (2,*) iii,g_corr5_loc(iii)
7944 cd      enddo
7945       eello5=ekont*eel5
7946 cd      write (2,*) 'ekont',ekont
7947 cd      write (iout,*) 'eello5',ekont*eel5
7948       return
7949       end
7950 c--------------------------------------------------------------------------
7951       double precision function eello6(i,j,k,l,jj,kk)
7952       implicit real*8 (a-h,o-z)
7953       include 'DIMENSIONS'
7954       include 'COMMON.IOUNITS'
7955       include 'COMMON.CHAIN'
7956       include 'COMMON.DERIV'
7957       include 'COMMON.INTERACT'
7958       include 'COMMON.CONTACTS'
7959       include 'COMMON.TORSION'
7960       include 'COMMON.VAR'
7961       include 'COMMON.GEO'
7962       include 'COMMON.FFIELD'
7963       double precision ggg1(3),ggg2(3)
7964 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7965 cd        eello6=0.0d0
7966 cd        return
7967 cd      endif
7968 cd      write (iout,*)
7969 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7970 cd     &   ' and',k,l
7971       eello6_1=0.0d0
7972       eello6_2=0.0d0
7973       eello6_3=0.0d0
7974       eello6_4=0.0d0
7975       eello6_5=0.0d0
7976       eello6_6=0.0d0
7977 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7978 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7979       do iii=1,2
7980         do kkk=1,5
7981           do lll=1,3
7982             derx(lll,kkk,iii)=0.0d0
7983           enddo
7984         enddo
7985       enddo
7986 cd      eij=facont_hb(jj,i)
7987 cd      ekl=facont_hb(kk,k)
7988 cd      ekont=eij*ekl
7989 cd      eij=1.0d0
7990 cd      ekl=1.0d0
7991 cd      ekont=1.0d0
7992       if (l.eq.j+1) then
7993         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7994         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7995         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7996         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7997         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7998         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7999       else
8000         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8001         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8002         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8003         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8004         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8005           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8006         else
8007           eello6_5=0.0d0
8008         endif
8009         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8010       endif
8011 C If turn contributions are considered, they will be handled separately.
8012       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8013 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8014 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8015 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8016 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8017 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8018 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8019 cd      goto 1112
8020       if (j.lt.nres-1) then
8021         j1=j+1
8022         j2=j-1
8023       else
8024         j1=j-1
8025         j2=j-2
8026       endif
8027       if (l.lt.nres-1) then
8028         l1=l+1
8029         l2=l-1
8030       else
8031         l1=l-1
8032         l2=l-2
8033       endif
8034       do ll=1,3
8035 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8036 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8037 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8038 cgrad        ghalf=0.5d0*ggg1(ll)
8039 cd        ghalf=0.0d0
8040         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8041         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8042         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8043         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8044         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8045         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8046         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8047         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8048 cgrad        ghalf=0.5d0*ggg2(ll)
8049 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8050 cd        ghalf=0.0d0
8051         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8052         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8053         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8054         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8055         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8056         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8057       enddo
8058 cd      goto 1112
8059 cgrad      do m=i+1,j-1
8060 cgrad        do ll=1,3
8061 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8062 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8063 cgrad        enddo
8064 cgrad      enddo
8065 cgrad      do m=k+1,l-1
8066 cgrad        do ll=1,3
8067 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8068 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8069 cgrad        enddo
8070 cgrad      enddo
8071 cgrad1112  continue
8072 cgrad      do m=i+2,j2
8073 cgrad        do ll=1,3
8074 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8075 cgrad        enddo
8076 cgrad      enddo
8077 cgrad      do m=k+2,l2
8078 cgrad        do ll=1,3
8079 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8080 cgrad        enddo
8081 cgrad      enddo
8082 cd      do iii=1,nres-3
8083 cd        write (2,*) iii,g_corr6_loc(iii)
8084 cd      enddo
8085       eello6=ekont*eel6
8086 cd      write (2,*) 'ekont',ekont
8087 cd      write (iout,*) 'eello6',ekont*eel6
8088       return
8089       end
8090 c--------------------------------------------------------------------------
8091       double precision function eello6_graph1(i,j,k,l,imat,swap)
8092       implicit real*8 (a-h,o-z)
8093       include 'DIMENSIONS'
8094       include 'COMMON.IOUNITS'
8095       include 'COMMON.CHAIN'
8096       include 'COMMON.DERIV'
8097       include 'COMMON.INTERACT'
8098       include 'COMMON.CONTACTS'
8099       include 'COMMON.TORSION'
8100       include 'COMMON.VAR'
8101       include 'COMMON.GEO'
8102       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8103       logical swap
8104       logical lprn
8105       common /kutas/ lprn
8106 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8107 C
8108 C      Parallel       Antiparallel
8109 C
8110 C          o             o
8111 C         /l\           /j\
8112 C        /   \         /   \
8113 C       /| o |         | o |\
8114 C     \ j|/k\|  /   \  |/k\|l /
8115 C      \ /   \ /     \ /   \ /
8116 C       o     o       o     o
8117 C       i             i
8118 C
8119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8120       itk=itortyp(itype(k))
8121       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8122       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8123       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8124       call transpose2(EUgC(1,1,k),auxmat(1,1))
8125       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8126       vv1(1)=pizda1(1,1)-pizda1(2,2)
8127       vv1(2)=pizda1(1,2)+pizda1(2,1)
8128       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8129       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8130       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8131       s5=scalar2(vv(1),Dtobr2(1,i))
8132 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8133       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8134       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8135      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8136      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8137      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8138      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8139      & +scalar2(vv(1),Dtobr2der(1,i)))
8140       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8141       vv1(1)=pizda1(1,1)-pizda1(2,2)
8142       vv1(2)=pizda1(1,2)+pizda1(2,1)
8143       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8144       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8145       if (l.eq.j+1) then
8146         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8147      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8148      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8149      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8150      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8151       else
8152         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8153      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8154      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8155      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8156      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8157       endif
8158       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8159       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8160       vv1(1)=pizda1(1,1)-pizda1(2,2)
8161       vv1(2)=pizda1(1,2)+pizda1(2,1)
8162       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8163      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8164      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8165      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8166       do iii=1,2
8167         if (swap) then
8168           ind=3-iii
8169         else
8170           ind=iii
8171         endif
8172         do kkk=1,5
8173           do lll=1,3
8174             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8175             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8176             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8177             call transpose2(EUgC(1,1,k),auxmat(1,1))
8178             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8179      &        pizda1(1,1))
8180             vv1(1)=pizda1(1,1)-pizda1(2,2)
8181             vv1(2)=pizda1(1,2)+pizda1(2,1)
8182             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8183             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8184      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8185             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8186      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8187             s5=scalar2(vv(1),Dtobr2(1,i))
8188             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8189           enddo
8190         enddo
8191       enddo
8192       return
8193       end
8194 c----------------------------------------------------------------------------
8195       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8196       implicit real*8 (a-h,o-z)
8197       include 'DIMENSIONS'
8198       include 'COMMON.IOUNITS'
8199       include 'COMMON.CHAIN'
8200       include 'COMMON.DERIV'
8201       include 'COMMON.INTERACT'
8202       include 'COMMON.CONTACTS'
8203       include 'COMMON.TORSION'
8204       include 'COMMON.VAR'
8205       include 'COMMON.GEO'
8206       logical swap
8207       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8208      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8209       logical lprn
8210       common /kutas/ lprn
8211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8212 C                                                                              C
8213 C      Parallel       Antiparallel                                             C
8214 C                                                                              C
8215 C          o             o                                                     C
8216 C     \   /l\           /j\   /                                                C
8217 C      \ /   \         /   \ /                                                 C
8218 C       o| o |         | o |o                                                  C
8219 C     \ j|/k\|      \  |/k\|l                                                  C
8220 C      \ /   \       \ /   \                                                   C
8221 C       o             o                                                        C
8222 C       i             i                                                        C
8223 C                                                                              C
8224 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8225 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8226 C AL 7/4/01 s1 would occur in the sixth-order moment,
8227 C           but not in a cluster cumulant
8228 #ifdef MOMENT
8229       s1=dip(1,jj,i)*dip(1,kk,k)
8230 #endif
8231       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8232       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8233       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8234       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8235       call transpose2(EUg(1,1,k),auxmat(1,1))
8236       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8237       vv(1)=pizda(1,1)-pizda(2,2)
8238       vv(2)=pizda(1,2)+pizda(2,1)
8239       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8240 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8241 #ifdef MOMENT
8242       eello6_graph2=-(s1+s2+s3+s4)
8243 #else
8244       eello6_graph2=-(s2+s3+s4)
8245 #endif
8246 c      eello6_graph2=-s3
8247 C Derivatives in gamma(i-1)
8248       if (i.gt.1) then
8249 #ifdef MOMENT
8250         s1=dipderg(1,jj,i)*dip(1,kk,k)
8251 #endif
8252         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8253         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8254         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8255         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8256 #ifdef MOMENT
8257         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8258 #else
8259         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8260 #endif
8261 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8262       endif
8263 C Derivatives in gamma(k-1)
8264 #ifdef MOMENT
8265       s1=dip(1,jj,i)*dipderg(1,kk,k)
8266 #endif
8267       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8268       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8269       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8270       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8271       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8272       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8273       vv(1)=pizda(1,1)-pizda(2,2)
8274       vv(2)=pizda(1,2)+pizda(2,1)
8275       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8276 #ifdef MOMENT
8277       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8278 #else
8279       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8280 #endif
8281 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8282 C Derivatives in gamma(j-1) or gamma(l-1)
8283       if (j.gt.1) then
8284 #ifdef MOMENT
8285         s1=dipderg(3,jj,i)*dip(1,kk,k)
8286 #endif
8287         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8288         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8289         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8290         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8291         vv(1)=pizda(1,1)-pizda(2,2)
8292         vv(2)=pizda(1,2)+pizda(2,1)
8293         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8294 #ifdef MOMENT
8295         if (swap) then
8296           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8297         else
8298           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8299         endif
8300 #endif
8301         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8302 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8303       endif
8304 C Derivatives in gamma(l-1) or gamma(j-1)
8305       if (l.gt.1) then
8306 #ifdef MOMENT
8307         s1=dip(1,jj,i)*dipderg(3,kk,k)
8308 #endif
8309         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8310         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8311         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8312         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8313         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8314         vv(1)=pizda(1,1)-pizda(2,2)
8315         vv(2)=pizda(1,2)+pizda(2,1)
8316         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8317 #ifdef MOMENT
8318         if (swap) then
8319           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8320         else
8321           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8322         endif
8323 #endif
8324         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8325 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8326       endif
8327 C Cartesian derivatives.
8328       if (lprn) then
8329         write (2,*) 'In eello6_graph2'
8330         do iii=1,2
8331           write (2,*) 'iii=',iii
8332           do kkk=1,5
8333             write (2,*) 'kkk=',kkk
8334             do jjj=1,2
8335               write (2,'(3(2f10.5),5x)')
8336      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8337             enddo
8338           enddo
8339         enddo
8340       endif
8341       do iii=1,2
8342         do kkk=1,5
8343           do lll=1,3
8344 #ifdef MOMENT
8345             if (iii.eq.1) then
8346               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8347             else
8348               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8349             endif
8350 #endif
8351             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8352      &        auxvec(1))
8353             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8354             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8355      &        auxvec(1))
8356             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8357             call transpose2(EUg(1,1,k),auxmat(1,1))
8358             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8359      &        pizda(1,1))
8360             vv(1)=pizda(1,1)-pizda(2,2)
8361             vv(2)=pizda(1,2)+pizda(2,1)
8362             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8363 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8364 #ifdef MOMENT
8365             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8366 #else
8367             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8368 #endif
8369             if (swap) then
8370               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8371             else
8372               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8373             endif
8374           enddo
8375         enddo
8376       enddo
8377       return
8378       end
8379 c----------------------------------------------------------------------------
8380       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8381       implicit real*8 (a-h,o-z)
8382       include 'DIMENSIONS'
8383       include 'COMMON.IOUNITS'
8384       include 'COMMON.CHAIN'
8385       include 'COMMON.DERIV'
8386       include 'COMMON.INTERACT'
8387       include 'COMMON.CONTACTS'
8388       include 'COMMON.TORSION'
8389       include 'COMMON.VAR'
8390       include 'COMMON.GEO'
8391       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8392       logical swap
8393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8394 C                                                                              C
8395 C      Parallel       Antiparallel                                             C
8396 C                                                                              C
8397 C          o             o                                                     C
8398 C         /l\   /   \   /j\                                                    C
8399 C        /   \ /     \ /   \                                                   C
8400 C       /| o |o       o| o |\                                                  C
8401 C       j|/k\|  /      |/k\|l /                                                C
8402 C        /   \ /       /   \ /                                                 C
8403 C       /     o       /     o                                                  C
8404 C       i             i                                                        C
8405 C                                                                              C
8406 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8407 C
8408 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8409 C           energy moment and not to the cluster cumulant.
8410       iti=itortyp(itype(i))
8411       if (j.lt.nres-1) then
8412         itj1=itortyp(itype(j+1))
8413       else
8414         itj1=ntortyp+1
8415       endif
8416       itk=itortyp(itype(k))
8417       itk1=itortyp(itype(k+1))
8418       if (l.lt.nres-1) then
8419         itl1=itortyp(itype(l+1))
8420       else
8421         itl1=ntortyp+1
8422       endif
8423 #ifdef MOMENT
8424       s1=dip(4,jj,i)*dip(4,kk,k)
8425 #endif
8426       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8427       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8428       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8429       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8430       call transpose2(EE(1,1,itk),auxmat(1,1))
8431       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8432       vv(1)=pizda(1,1)+pizda(2,2)
8433       vv(2)=pizda(2,1)-pizda(1,2)
8434       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8435 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8436 cd     & "sum",-(s2+s3+s4)
8437 #ifdef MOMENT
8438       eello6_graph3=-(s1+s2+s3+s4)
8439 #else
8440       eello6_graph3=-(s2+s3+s4)
8441 #endif
8442 c      eello6_graph3=-s4
8443 C Derivatives in gamma(k-1)
8444       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8445       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8446       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8447       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8448 C Derivatives in gamma(l-1)
8449       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8450       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8451       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8452       vv(1)=pizda(1,1)+pizda(2,2)
8453       vv(2)=pizda(2,1)-pizda(1,2)
8454       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8455       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8456 C Cartesian derivatives.
8457       do iii=1,2
8458         do kkk=1,5
8459           do lll=1,3
8460 #ifdef MOMENT
8461             if (iii.eq.1) then
8462               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8463             else
8464               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8465             endif
8466 #endif
8467             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8468      &        auxvec(1))
8469             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8470             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8471      &        auxvec(1))
8472             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8473             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8474      &        pizda(1,1))
8475             vv(1)=pizda(1,1)+pizda(2,2)
8476             vv(2)=pizda(2,1)-pizda(1,2)
8477             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8478 #ifdef MOMENT
8479             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8480 #else
8481             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8482 #endif
8483             if (swap) then
8484               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8485             else
8486               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8487             endif
8488 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8489           enddo
8490         enddo
8491       enddo
8492       return
8493       end
8494 c----------------------------------------------------------------------------
8495       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8496       implicit real*8 (a-h,o-z)
8497       include 'DIMENSIONS'
8498       include 'COMMON.IOUNITS'
8499       include 'COMMON.CHAIN'
8500       include 'COMMON.DERIV'
8501       include 'COMMON.INTERACT'
8502       include 'COMMON.CONTACTS'
8503       include 'COMMON.TORSION'
8504       include 'COMMON.VAR'
8505       include 'COMMON.GEO'
8506       include 'COMMON.FFIELD'
8507       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8508      & auxvec1(2),auxmat1(2,2)
8509       logical swap
8510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8511 C                                                                              C
8512 C      Parallel       Antiparallel                                             C
8513 C                                                                              C
8514 C          o             o                                                     C
8515 C         /l\   /   \   /j\                                                    C
8516 C        /   \ /     \ /   \                                                   C
8517 C       /| o |o       o| o |\                                                  C
8518 C     \ j|/k\|      \  |/k\|l                                                  C
8519 C      \ /   \       \ /   \                                                   C
8520 C       o     \       o     \                                                  C
8521 C       i             i                                                        C
8522 C                                                                              C
8523 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8524 C
8525 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8526 C           energy moment and not to the cluster cumulant.
8527 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8528       iti=itortyp(itype(i))
8529       itj=itortyp(itype(j))
8530       if (j.lt.nres-1) then
8531         itj1=itortyp(itype(j+1))
8532       else
8533         itj1=ntortyp+1
8534       endif
8535       itk=itortyp(itype(k))
8536       if (k.lt.nres-1) then
8537         itk1=itortyp(itype(k+1))
8538       else
8539         itk1=ntortyp+1
8540       endif
8541       itl=itortyp(itype(l))
8542       if (l.lt.nres-1) then
8543         itl1=itortyp(itype(l+1))
8544       else
8545         itl1=ntortyp+1
8546       endif
8547 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8548 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8549 cd     & ' itl',itl,' itl1',itl1
8550 #ifdef MOMENT
8551       if (imat.eq.1) then
8552         s1=dip(3,jj,i)*dip(3,kk,k)
8553       else
8554         s1=dip(2,jj,j)*dip(2,kk,l)
8555       endif
8556 #endif
8557       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8558       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8559       if (j.eq.l+1) then
8560         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8561         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8562       else
8563         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8564         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8565       endif
8566       call transpose2(EUg(1,1,k),auxmat(1,1))
8567       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8568       vv(1)=pizda(1,1)-pizda(2,2)
8569       vv(2)=pizda(2,1)+pizda(1,2)
8570       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8571 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8572 #ifdef MOMENT
8573       eello6_graph4=-(s1+s2+s3+s4)
8574 #else
8575       eello6_graph4=-(s2+s3+s4)
8576 #endif
8577 C Derivatives in gamma(i-1)
8578       if (i.gt.1) then
8579 #ifdef MOMENT
8580         if (imat.eq.1) then
8581           s1=dipderg(2,jj,i)*dip(3,kk,k)
8582         else
8583           s1=dipderg(4,jj,j)*dip(2,kk,l)
8584         endif
8585 #endif
8586         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8587         if (j.eq.l+1) then
8588           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8589           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8590         else
8591           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8592           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8593         endif
8594         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8595         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8596 cd          write (2,*) 'turn6 derivatives'
8597 #ifdef MOMENT
8598           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8599 #else
8600           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8601 #endif
8602         else
8603 #ifdef MOMENT
8604           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8605 #else
8606           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8607 #endif
8608         endif
8609       endif
8610 C Derivatives in gamma(k-1)
8611 #ifdef MOMENT
8612       if (imat.eq.1) then
8613         s1=dip(3,jj,i)*dipderg(2,kk,k)
8614       else
8615         s1=dip(2,jj,j)*dipderg(4,kk,l)
8616       endif
8617 #endif
8618       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8619       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8620       if (j.eq.l+1) then
8621         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8622         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8623       else
8624         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8625         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8626       endif
8627       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8628       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8629       vv(1)=pizda(1,1)-pizda(2,2)
8630       vv(2)=pizda(2,1)+pizda(1,2)
8631       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8632       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8633 #ifdef MOMENT
8634         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8635 #else
8636         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8637 #endif
8638       else
8639 #ifdef MOMENT
8640         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8641 #else
8642         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8643 #endif
8644       endif
8645 C Derivatives in gamma(j-1) or gamma(l-1)
8646       if (l.eq.j+1 .and. l.gt.1) then
8647         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8648         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8649         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8650         vv(1)=pizda(1,1)-pizda(2,2)
8651         vv(2)=pizda(2,1)+pizda(1,2)
8652         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8653         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8654       else if (j.gt.1) then
8655         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8656         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8657         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8658         vv(1)=pizda(1,1)-pizda(2,2)
8659         vv(2)=pizda(2,1)+pizda(1,2)
8660         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8661         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8662           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8663         else
8664           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8665         endif
8666       endif
8667 C Cartesian derivatives.
8668       do iii=1,2
8669         do kkk=1,5
8670           do lll=1,3
8671 #ifdef MOMENT
8672             if (iii.eq.1) then
8673               if (imat.eq.1) then
8674                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8675               else
8676                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8677               endif
8678             else
8679               if (imat.eq.1) then
8680                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8681               else
8682                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8683               endif
8684             endif
8685 #endif
8686             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8687      &        auxvec(1))
8688             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8689             if (j.eq.l+1) then
8690               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8691      &          b1(1,itj1),auxvec(1))
8692               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8693             else
8694               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8695      &          b1(1,itl1),auxvec(1))
8696               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8697             endif
8698             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8699      &        pizda(1,1))
8700             vv(1)=pizda(1,1)-pizda(2,2)
8701             vv(2)=pizda(2,1)+pizda(1,2)
8702             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8703             if (swap) then
8704               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8705 #ifdef MOMENT
8706                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8707      &             -(s1+s2+s4)
8708 #else
8709                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8710      &             -(s2+s4)
8711 #endif
8712                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8713               else
8714 #ifdef MOMENT
8715                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8716 #else
8717                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8718 #endif
8719                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8720               endif
8721             else
8722 #ifdef MOMENT
8723               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8724 #else
8725               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8726 #endif
8727               if (l.eq.j+1) then
8728                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8729               else
8730                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8731               endif
8732             endif
8733           enddo
8734         enddo
8735       enddo
8736       return
8737       end
8738 c----------------------------------------------------------------------------
8739       double precision function eello_turn6(i,jj,kk)
8740       implicit real*8 (a-h,o-z)
8741       include 'DIMENSIONS'
8742       include 'COMMON.IOUNITS'
8743       include 'COMMON.CHAIN'
8744       include 'COMMON.DERIV'
8745       include 'COMMON.INTERACT'
8746       include 'COMMON.CONTACTS'
8747       include 'COMMON.TORSION'
8748       include 'COMMON.VAR'
8749       include 'COMMON.GEO'
8750       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8751      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8752      &  ggg1(3),ggg2(3)
8753       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8754      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8755 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8756 C           the respective energy moment and not to the cluster cumulant.
8757       s1=0.0d0
8758       s8=0.0d0
8759       s13=0.0d0
8760 c
8761       eello_turn6=0.0d0
8762       j=i+4
8763       k=i+1
8764       l=i+3
8765       iti=itortyp(itype(i))
8766       itk=itortyp(itype(k))
8767       itk1=itortyp(itype(k+1))
8768       itl=itortyp(itype(l))
8769       itj=itortyp(itype(j))
8770 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8771 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8772 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8773 cd        eello6=0.0d0
8774 cd        return
8775 cd      endif
8776 cd      write (iout,*)
8777 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8778 cd     &   ' and',k,l
8779 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8780       do iii=1,2
8781         do kkk=1,5
8782           do lll=1,3
8783             derx_turn(lll,kkk,iii)=0.0d0
8784           enddo
8785         enddo
8786       enddo
8787 cd      eij=1.0d0
8788 cd      ekl=1.0d0
8789 cd      ekont=1.0d0
8790       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8791 cd      eello6_5=0.0d0
8792 cd      write (2,*) 'eello6_5',eello6_5
8793 #ifdef MOMENT
8794       call transpose2(AEA(1,1,1),auxmat(1,1))
8795       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8796       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8797       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8798 #endif
8799       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8800       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8801       s2 = scalar2(b1(1,itk),vtemp1(1))
8802 #ifdef MOMENT
8803       call transpose2(AEA(1,1,2),atemp(1,1))
8804       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8805       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8806       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8807 #endif
8808       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8809       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8810       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8811 #ifdef MOMENT
8812       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8813       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8814       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8815       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8816       ss13 = scalar2(b1(1,itk),vtemp4(1))
8817       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8818 #endif
8819 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8820 c      s1=0.0d0
8821 c      s2=0.0d0
8822 c      s8=0.0d0
8823 c      s12=0.0d0
8824 c      s13=0.0d0
8825       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8826 C Derivatives in gamma(i+2)
8827       s1d =0.0d0
8828       s8d =0.0d0
8829 #ifdef MOMENT
8830       call transpose2(AEA(1,1,1),auxmatd(1,1))
8831       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8832       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8833       call transpose2(AEAderg(1,1,2),atempd(1,1))
8834       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8835       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8836 #endif
8837       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8838       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8839       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8840 c      s1d=0.0d0
8841 c      s2d=0.0d0
8842 c      s8d=0.0d0
8843 c      s12d=0.0d0
8844 c      s13d=0.0d0
8845       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8846 C Derivatives in gamma(i+3)
8847 #ifdef MOMENT
8848       call transpose2(AEA(1,1,1),auxmatd(1,1))
8849       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8850       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8851       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8852 #endif
8853       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8854       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8855       s2d = scalar2(b1(1,itk),vtemp1d(1))
8856 #ifdef MOMENT
8857       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8858       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8859 #endif
8860       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8861 #ifdef MOMENT
8862       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8863       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8864       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8865 #endif
8866 c      s1d=0.0d0
8867 c      s2d=0.0d0
8868 c      s8d=0.0d0
8869 c      s12d=0.0d0
8870 c      s13d=0.0d0
8871 #ifdef MOMENT
8872       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8873      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8874 #else
8875       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8876      &               -0.5d0*ekont*(s2d+s12d)
8877 #endif
8878 C Derivatives in gamma(i+4)
8879       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8880       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8881       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8882 #ifdef MOMENT
8883       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8884       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8885       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8886 #endif
8887 c      s1d=0.0d0
8888 c      s2d=0.0d0
8889 c      s8d=0.0d0
8890 C      s12d=0.0d0
8891 c      s13d=0.0d0
8892 #ifdef MOMENT
8893       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8894 #else
8895       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8896 #endif
8897 C Derivatives in gamma(i+5)
8898 #ifdef MOMENT
8899       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8900       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8901       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8902 #endif
8903       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8904       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8905       s2d = scalar2(b1(1,itk),vtemp1d(1))
8906 #ifdef MOMENT
8907       call transpose2(AEA(1,1,2),atempd(1,1))
8908       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8909       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8910 #endif
8911       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8912       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8913 #ifdef MOMENT
8914       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8915       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8916       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8917 #endif
8918 c      s1d=0.0d0
8919 c      s2d=0.0d0
8920 c      s8d=0.0d0
8921 c      s12d=0.0d0
8922 c      s13d=0.0d0
8923 #ifdef MOMENT
8924       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8925      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8926 #else
8927       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8928      &               -0.5d0*ekont*(s2d+s12d)
8929 #endif
8930 C Cartesian derivatives
8931       do iii=1,2
8932         do kkk=1,5
8933           do lll=1,3
8934 #ifdef MOMENT
8935             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8936             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8937             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8938 #endif
8939             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8940             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8941      &          vtemp1d(1))
8942             s2d = scalar2(b1(1,itk),vtemp1d(1))
8943 #ifdef MOMENT
8944             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8945             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8946             s8d = -(atempd(1,1)+atempd(2,2))*
8947      &           scalar2(cc(1,1,itl),vtemp2(1))
8948 #endif
8949             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8950      &           auxmatd(1,1))
8951             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8952             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8953 c      s1d=0.0d0
8954 c      s2d=0.0d0
8955 c      s8d=0.0d0
8956 c      s12d=0.0d0
8957 c      s13d=0.0d0
8958 #ifdef MOMENT
8959             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8960      &        - 0.5d0*(s1d+s2d)
8961 #else
8962             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8963      &        - 0.5d0*s2d
8964 #endif
8965 #ifdef MOMENT
8966             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8967      &        - 0.5d0*(s8d+s12d)
8968 #else
8969             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8970      &        - 0.5d0*s12d
8971 #endif
8972           enddo
8973         enddo
8974       enddo
8975 #ifdef MOMENT
8976       do kkk=1,5
8977         do lll=1,3
8978           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8979      &      achuj_tempd(1,1))
8980           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8981           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8982           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8983           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8984           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8985      &      vtemp4d(1))
8986           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8987           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8988           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8989         enddo
8990       enddo
8991 #endif
8992 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8993 cd     &  16*eel_turn6_num
8994 cd      goto 1112
8995       if (j.lt.nres-1) then
8996         j1=j+1
8997         j2=j-1
8998       else
8999         j1=j-1
9000         j2=j-2
9001       endif
9002       if (l.lt.nres-1) then
9003         l1=l+1
9004         l2=l-1
9005       else
9006         l1=l-1
9007         l2=l-2
9008       endif
9009       do ll=1,3
9010 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9011 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9012 cgrad        ghalf=0.5d0*ggg1(ll)
9013 cd        ghalf=0.0d0
9014         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9015         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9016         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9017      &    +ekont*derx_turn(ll,2,1)
9018         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9019         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9020      &    +ekont*derx_turn(ll,4,1)
9021         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9022         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9023         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9024 cgrad        ghalf=0.5d0*ggg2(ll)
9025 cd        ghalf=0.0d0
9026         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9027      &    +ekont*derx_turn(ll,2,2)
9028         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9029         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9030      &    +ekont*derx_turn(ll,4,2)
9031         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9032         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9033         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9034       enddo
9035 cd      goto 1112
9036 cgrad      do m=i+1,j-1
9037 cgrad        do ll=1,3
9038 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9039 cgrad        enddo
9040 cgrad      enddo
9041 cgrad      do m=k+1,l-1
9042 cgrad        do ll=1,3
9043 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9044 cgrad        enddo
9045 cgrad      enddo
9046 cgrad1112  continue
9047 cgrad      do m=i+2,j2
9048 cgrad        do ll=1,3
9049 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9050 cgrad        enddo
9051 cgrad      enddo
9052 cgrad      do m=k+2,l2
9053 cgrad        do ll=1,3
9054 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9055 cgrad        enddo
9056 cgrad      enddo
9057 cd      do iii=1,nres-3
9058 cd        write (2,*) iii,g_corr6_loc(iii)
9059 cd      enddo
9060       eello_turn6=ekont*eel_turn6
9061 cd      write (2,*) 'ekont',ekont
9062 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9063       return
9064       end
9065
9066 C-----------------------------------------------------------------------------
9067       double precision function scalar(u,v)
9068 !DIR$ INLINEALWAYS scalar
9069 #ifndef OSF
9070 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9071 #endif
9072       implicit none
9073       double precision u(3),v(3)
9074 cd      double precision sc
9075 cd      integer i
9076 cd      sc=0.0d0
9077 cd      do i=1,3
9078 cd        sc=sc+u(i)*v(i)
9079 cd      enddo
9080 cd      scalar=sc
9081
9082       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9083       return
9084       end
9085 crc-------------------------------------------------
9086       SUBROUTINE MATVEC2(A1,V1,V2)
9087 !DIR$ INLINEALWAYS MATVEC2
9088 #ifndef OSF
9089 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9090 #endif
9091       implicit real*8 (a-h,o-z)
9092       include 'DIMENSIONS'
9093       DIMENSION A1(2,2),V1(2),V2(2)
9094 c      DO 1 I=1,2
9095 c        VI=0.0
9096 c        DO 3 K=1,2
9097 c    3     VI=VI+A1(I,K)*V1(K)
9098 c        Vaux(I)=VI
9099 c    1 CONTINUE
9100
9101       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9102       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9103
9104       v2(1)=vaux1
9105       v2(2)=vaux2
9106       END
9107 C---------------------------------------
9108       SUBROUTINE MATMAT2(A1,A2,A3)
9109 #ifndef OSF
9110 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9111 #endif
9112       implicit real*8 (a-h,o-z)
9113       include 'DIMENSIONS'
9114       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9115 c      DIMENSION AI3(2,2)
9116 c        DO  J=1,2
9117 c          A3IJ=0.0
9118 c          DO K=1,2
9119 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9120 c          enddo
9121 c          A3(I,J)=A3IJ
9122 c       enddo
9123 c      enddo
9124
9125       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9126       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9127       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9128       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9129
9130       A3(1,1)=AI3_11
9131       A3(2,1)=AI3_21
9132       A3(1,2)=AI3_12
9133       A3(2,2)=AI3_22
9134       END
9135
9136 c-------------------------------------------------------------------------
9137       double precision function scalar2(u,v)
9138 !DIR$ INLINEALWAYS scalar2
9139       implicit none
9140       double precision u(2),v(2)
9141       double precision sc
9142       integer i
9143       scalar2=u(1)*v(1)+u(2)*v(2)
9144       return
9145       end
9146
9147 C-----------------------------------------------------------------------------
9148
9149       subroutine transpose2(a,at)
9150 !DIR$ INLINEALWAYS transpose2
9151 #ifndef OSF
9152 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9153 #endif
9154       implicit none
9155       double precision a(2,2),at(2,2)
9156       at(1,1)=a(1,1)
9157       at(1,2)=a(2,1)
9158       at(2,1)=a(1,2)
9159       at(2,2)=a(2,2)
9160       return
9161       end
9162 c--------------------------------------------------------------------------
9163       subroutine transpose(n,a,at)
9164       implicit none
9165       integer n,i,j
9166       double precision a(n,n),at(n,n)
9167       do i=1,n
9168         do j=1,n
9169           at(j,i)=a(i,j)
9170         enddo
9171       enddo
9172       return
9173       end
9174 C---------------------------------------------------------------------------
9175       subroutine prodmat3(a1,a2,kk,transp,prod)
9176 !DIR$ INLINEALWAYS prodmat3
9177 #ifndef OSF
9178 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9179 #endif
9180       implicit none
9181       integer i,j
9182       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9183       logical transp
9184 crc      double precision auxmat(2,2),prod_(2,2)
9185
9186       if (transp) then
9187 crc        call transpose2(kk(1,1),auxmat(1,1))
9188 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9189 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9190
9191            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9192      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9193            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9194      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9195            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9196      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9197            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9198      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9199
9200       else
9201 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9202 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9203
9204            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9205      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9206            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9207      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9208            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9209      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9210            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9211      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9212
9213       endif
9214 c      call transpose2(a2(1,1),a2t(1,1))
9215
9216 crc      print *,transp
9217 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9218 crc      print *,((prod(i,j),i=1,2),j=1,2)
9219
9220       return
9221       end
9222