source/unres/src_MIN/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         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57           weights_(22)=wsct
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84           wsct=weights(22)
  85         endif
  86         time_Bcast=time_Bcast+MPI_Wtime()-time00
  87         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  88 c        call chainbuild_cart
  89       endif
  90 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  91 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  92 #else
  93 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  94 c        call int_from_cart1(.false.)
  95 c      endif
  96 #endif
  97 #ifdef TIMING
  98       time00=MPI_Wtime()
  99 #endif
 100 C
 101 C Compute the side-chain and electrostatic interaction energy
 102 C
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw,evdw_p,evdw_m)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw,evdw_p,evdw_m)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw,evdw_p,evdw_m)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw,evdw_p,evdw_m)
 116       goto 107
 117 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 118   105 call egbv(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Soft-sphere potential
 121   106 call e_softsphere(evdw)
 122 C
 123 C Calculate electrostatic (H-bonding) energy of the main chain.
 124 C
 125   107 continue
 126 c      print *,"Processor",myrank," computed USCSC"
 127 #ifdef TIMING
 128       time01=MPI_Wtime()
 129 #endif
 130       call vec_and_deriv
 131 #ifdef TIMING
 132       time_vec=time_vec+MPI_Wtime()-time01
 133 #endif
 134 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 135       if (ipot.lt.6) then
 136 #ifdef SPLITELE
 137          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 138      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 139      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 140      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 141 #else
 142          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 143      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 144      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 145      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 146 #endif
 147             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 148          else
 149             ees=0.0d0
 150             evdw1=0.0d0
 151             eel_loc=0.0d0
 152             eello_turn3=0.0d0
 153             eello_turn4=0.0d0
 154          endif
 155       else
 156 c        write (iout,*) "Soft-spheer ELEC potential"
 157         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 158      &   eello_turn4)
 159       endif
 160 c      print *,"Processor",myrank," computed UELEC"
 161 C
 162 C Calculate excluded-volume interaction energy between peptide groups
 163 C and side chains.
 164 C
 165       if (ipot.lt.6) then
 166        if(wscp.gt.0d0) then
 167         call escp(evdw2,evdw2_14)
 168        else
 169         evdw2=0
 170         evdw2_14=0
 171        endif
 172       else
 173 c        write (iout,*) "Soft-sphere SCP potential"
 174         call escp_soft_sphere(evdw2,evdw2_14)
 175       endif
 176 c
 177 c Calculate the bond-stretching energy
 178 c
 179       call ebond(estr)
 180 C
 181 C Calculate the disulfide-bridge and other energy and the contributions
 182 C from other distance constraints.
 183 cd    print *,'Calling EHPB'
 184       call edis(ehpb)
 185 cd    print *,'EHPB exitted succesfully.'
 186 C
 187 C Calculate the virtual-bond-angle energy.
 188 C
 189       if (wang.gt.0d0) then
 190         call ebend(ebe)
 191       else
 192         ebe=0
 193       endif
 194 c      print *,"Processor",myrank," computed UB"
 195 C
 196 C Calculate the SC local energy.
 197 C
 198       call esc(escloc)
 199 c      print *,"Processor",myrank," computed USC"
 200 C
 201 C Calculate the virtual-bond torsional energy.
 202 C
 203 cd    print *,'nterm=',nterm
 204       if (wtor.gt.0) then
 205        call etor(etors,edihcnstr)
 206       else
 207        etors=0
 208        edihcnstr=0
 209       endif
 210 c      print *,"Processor",myrank," computed Utor"
 211 C
 212 C 6/23/01 Calculate double-torsional energy
 213 C
 214       if (wtor_d.gt.0) then
 215        call etor_d(etors_d)
 216       else
 217        etors_d=0
 218       endif
 219 c      print *,"Processor",myrank," computed Utord"
 220 C
 221 C 21/5/07 Calculate local sicdechain correlation energy
 222 C
 223       if (wsccor.gt.0.0d0) then
 224         call eback_sc_corr(esccor)
 225       else
 226         esccor=0.0d0
 227       endif
 228 c      print *,"Processor",myrank," computed Usccorr"
 229 C
 230 C 12/1/95 Multi-body terms
 231 C
 232       n_corr=0
 233       n_corr1=0
 234       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 235      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 236          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 237 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 238 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 239       else
 240          ecorr=0.0d0
 241          ecorr5=0.0d0
 242          ecorr6=0.0d0
 243          eturn6=0.0d0
 244       endif
 245       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 246          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 247 cd         write (iout,*) "multibody_hb ecorr",ecorr
 248       endif
 249 c      print *,"Processor",myrank," computed Ucorr"
 250 C
 251 C If performing constraint dynamics, call the constraint energy
 252 C  after the equilibration time
 253       if(usampl.and.totT.gt.eq_time) then
 254 c         call EconstrQ
 255          call Econstr_back
 256       else
 257          Uconst=0.0d0
 258          Uconst_back=0.0d0
 259       endif
 260 #ifdef TIMING
 261       time_enecalc=time_enecalc+MPI_Wtime()-time00
 262 #endif
 263 c      print *,"Processor",myrank," computed Uconstr"
 264 #ifdef TIMING
 265       time00=MPI_Wtime()
 266 #endif
 267 c
 268 C Sum the energies
 269 C
 270       energia(1)=evdw
 271 #ifdef SCP14
 272       energia(2)=evdw2-evdw2_14
 273       energia(18)=evdw2_14
 274 #else
 275       energia(2)=evdw2
 276       energia(18)=0.0d0
 277 #endif
 278 #ifdef SPLITELE
 279       energia(3)=ees
 280       energia(16)=evdw1
 281 #else
 282       energia(3)=ees+evdw1
 283       energia(16)=0.0d0
 284 #endif
 285       energia(4)=ecorr
 286       energia(5)=ecorr5
 287       energia(6)=ecorr6
 288       energia(7)=eel_loc
 289       energia(8)=eello_turn3
 290       energia(9)=eello_turn4
 291       energia(10)=eturn6
 292       energia(11)=ebe
 293       energia(12)=escloc
 294       energia(13)=etors
 295       energia(14)=etors_d
 296       energia(15)=ehpb
 297       energia(19)=edihcnstr
 298       energia(17)=estr
 299       energia(20)=Uconst+Uconst_back
 300       energia(21)=esccor
 301       energia(22)=evdw_p
 302       energia(23)=evdw_m
 303 c      print *," Processor",myrank," calls SUM_ENERGY"
 304       call sum_energy(energia,.true.)
 305 c      print *," Processor",myrank," left SUM_ENERGY"
 306 #ifdef TIMING
 307       time_sumene=time_sumene+MPI_Wtime()-time00
 308 #endif
 309       return
 310       end
 311 c-------------------------------------------------------------------------------
 312       subroutine sum_energy(energia,reduce)
 313       implicit real*8 (a-h,o-z)
 314       include 'DIMENSIONS'
 315 #ifndef ISNAN
 316       external proc_proc
 317 #ifdef WINPGI
 318 cMS$ATTRIBUTES C ::  proc_proc
 319 #endif
 320 #endif
 321 #ifdef MPI
 322       include "mpif.h"
 323 #endif
 324       include 'COMMON.SETUP'
 325       include 'COMMON.IOUNITS'
 326       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 327       include 'COMMON.FFIELD'
 328       include 'COMMON.DERIV'
 329       include 'COMMON.INTERACT'
 330       include 'COMMON.SBRIDGE'
 331       include 'COMMON.CHAIN'
 332       include 'COMMON.VAR'
 333       include 'COMMON.CONTROL'
 334       include 'COMMON.TIME1'
 335       logical reduce
 336 #ifdef MPI
 337       if (nfgtasks.gt.1 .and. reduce) then
 338 #ifdef DEBUG
 339         write (iout,*) "energies before REDUCE"
 340         call enerprint(energia)
 341         call flush(iout)
 342 #endif
 343         do i=0,n_ene
 344           enebuff(i)=energia(i)
 345         enddo
 346         time00=MPI_Wtime()
 347         call MPI_Barrier(FG_COMM,IERR)
 348         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 349         time00=MPI_Wtime()
 350         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 351      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 352 #ifdef DEBUG
 353         write (iout,*) "energies after REDUCE"
 354         call enerprint(energia)
 355         call flush(iout)
 356 #endif
 357         time_Reduce=time_Reduce+MPI_Wtime()-time00
 358       endif
 359       if (fg_rank.eq.0) then
 360 #endif
 361 #ifdef TSCSC
 362       evdw=energia(22)+wsct*energia(23)
 363 #else
 364       evdw=energia(1)
 365 #endif
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 446 #else
 447       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 448      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 449 #endif
 450       include 'COMMON.SETUP'
 451       include 'COMMON.IOUNITS'
 452       include 'COMMON.FFIELD'
 453       include 'COMMON.DERIV'
 454       include 'COMMON.INTERACT'
 455       include 'COMMON.SBRIDGE'
 456       include 'COMMON.CHAIN'
 457       include 'COMMON.VAR'
 458       include 'COMMON.CONTROL'
 459       include 'COMMON.TIME1'
 460       include 'COMMON.MAXGRAD'
 461 #ifdef TIMING
 462       time01=MPI_Wtime()
 463 #endif
 464 #ifdef DEBUG
 465       write (iout,*) "sum_gradient gvdwc, gvdwx"
 466       do i=1,nres
 467         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 468      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 469      &   (gvdwcT(j,i),j=1,3)
 470       enddo
 471       call flush(iout)
 472 #endif
 473 #ifdef MPI
 474 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 475         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 476      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 477 #endif
 478 C
 479 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 480 C            in virtual-bond-vector coordinates
 481 C
 482 #ifdef DEBUG
 483 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 484 c      do i=1,nres-1
 485 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 486 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 487 c      enddo
 488 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 489 c      do i=1,nres-1
 490 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 491 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 492 c      enddo
 493       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 494       do i=1,nres
 495         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 496      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 497      &   g_corr5_loc(i)
 498       enddo
 499       call flush(iout)
 500 #endif
 501 #ifdef SPLITELE
 502 #ifdef TSCSC
 503       do i=1,nct
 504         do j=1,3
 505           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 506      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 507      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 508      &                wel_loc*gel_loc_long(j,i)+
 509      &                wcorr*gradcorr_long(j,i)+
 510      &                wcorr5*gradcorr5_long(j,i)+
 511      &                wcorr6*gradcorr6_long(j,i)+
 512      &                wturn6*gcorr6_turn_long(j,i)+
 513      &                wstrain*ghpbc(j,i)
 514         enddo
 515       enddo
 516 #else
 517       do i=1,nct
 518         do j=1,3
 519           gradbufc(j,i)=wsc*gvdwc(j,i)+
 520      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 521      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 522      &                wel_loc*gel_loc_long(j,i)+
 523      &                wcorr*gradcorr_long(j,i)+
 524      &                wcorr5*gradcorr5_long(j,i)+
 525      &                wcorr6*gradcorr6_long(j,i)+
 526      &                wturn6*gcorr6_turn_long(j,i)+
 527      &                wstrain*ghpbc(j,i)
 528         enddo
 529       enddo
 530 #endif
 531 #else
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+
 537      &                wbond*gradb(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #endif
 547 #ifdef MPI
 548       if (nfgtasks.gt.1) then
 549       time00=MPI_Wtime()
 550 #ifdef DEBUG
 551       write (iout,*) "gradbufc before allreduce"
 552       do i=1,nres
 553         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 554       enddo
 555       call flush(iout)
 556 #endif
 557       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 558      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 559       time_reduce=time_reduce+MPI_Wtime()-time00
 560 #ifdef DEBUG
 561       write (iout,*) "gradbufc_sum after allreduce"
 562       do i=1,nres
 563         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 564       enddo
 565       call flush(iout)
 566 #endif
 567 #ifdef TIMING
 568       time_allreduce=time_allreduce+MPI_Wtime()-time00
 569 #endif
 570       do i=nnt,nres
 571         do k=1,3
 572           gradbufc(k,i)=0.0d0
 573         enddo
 574       enddo
 575       do i=igrad_start,igrad_end
 576         do j=jgrad_start(i),jgrad_end(i)
 577           do k=1,3
 578             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 579           enddo
 580         enddo
 581       enddo
 582       else
 583 #endif
 584 #ifdef DEBUG
 585       write (iout,*) "gradbufc"
 586       do i=1,nres
 587         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 588       enddo
 589       call flush(iout)
 590 #endif
 591       do i=nnt,nres-1
 592         do k=1,3
 593           gradbufc(k,i)=0.0d0
 594         enddo
 595         do j=i+1,nres
 596           do k=1,3
 597             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 598           enddo
 599         enddo
 600       enddo
 601 #ifdef MPI
 602       endif
 603 #endif
 604       do k=1,3
 605         gradbufc(k,nres)=0.0d0
 606       enddo
 607       do i=1,nct
 608         do j=1,3
 609 #ifdef SPLITELE
 610           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 611      &                wel_loc*gel_loc(j,i)+
 612      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 613      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 614      &                wel_loc*gel_loc_long(j,i)+
 615      &                wcorr*gradcorr_long(j,i)+
 616      &                wcorr5*gradcorr5_long(j,i)+
 617      &                wcorr6*gradcorr6_long(j,i)+
 618      &                wturn6*gcorr6_turn_long(j,i))+
 619      &                wbond*gradb(j,i)+
 620      &                wcorr*gradcorr(j,i)+
 621      &                wturn3*gcorr3_turn(j,i)+
 622      &                wturn4*gcorr4_turn(j,i)+
 623      &                wcorr5*gradcorr5(j,i)+
 624      &                wcorr6*gradcorr6(j,i)+
 625      &                wturn6*gcorr6_turn(j,i)+
 626      &                wsccor*gsccorc(j,i)
 627      &               +wscloc*gscloc(j,i)
 628 #else
 629           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 630      &                wel_loc*gel_loc(j,i)+
 631      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 632      &                welec*gelc_long(j,i)
 633      &                wel_loc*gel_loc_long(j,i)+
 634      &                wcorr*gcorr_long(j,i)+
 635      &                wcorr5*gradcorr5_long(j,i)+
 636      &                wcorr6*gradcorr6_long(j,i)+
 637      &                wturn6*gcorr6_turn_long(j,i))+
 638      &                wbond*gradb(j,i)+
 639      &                wcorr*gradcorr(j,i)+
 640      &                wturn3*gcorr3_turn(j,i)+
 641      &                wturn4*gcorr4_turn(j,i)+
 642      &                wcorr5*gradcorr5(j,i)+
 643      &                wcorr6*gradcorr6(j,i)+
 644      &                wturn6*gcorr6_turn(j,i)+
 645      &                wsccor*gsccorc(j,i)
 646      &               +wscloc*gscloc(j,i)
 647 #endif
 648 #ifdef TSCSC
 649           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 650      &                  wscp*gradx_scp(j,i)+
 651      &                  wbond*gradbx(j,i)+
 652      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 653      &                  wsccor*gsccorx(j,i)
 654      &                 +wscloc*gsclocx(j,i)
 655 #else
 656           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 657      &                  wbond*gradbx(j,i)+
 658      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 659      &                  wsccor*gsccorx(j,i)
 660      &                 +wscloc*gsclocx(j,i)
 661 #endif
 662         enddo
 663       enddo
 664 #ifdef DEBUG
 665       write (iout,*) "gloc before adding corr"
 666       do i=1,4*nres
 667         write (iout,*) i,gloc(i,icg)
 668       enddo
 669 #endif
 670       do i=1,nres-3
 671         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 672      &   +wcorr5*g_corr5_loc(i)
 673      &   +wcorr6*g_corr6_loc(i)
 674      &   +wturn4*gel_loc_turn4(i)
 675      &   +wturn3*gel_loc_turn3(i)
 676      &   +wturn6*gel_loc_turn6(i)
 677      &   +wel_loc*gel_loc_loc(i)
 678      &   +wsccor*gsccor_loc(i)
 679       enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gloc after adding corr"
 682       do i=1,4*nres
 683         write (iout,*) i,gloc(i,icg)
 684       enddo
 685 #endif
 686 #ifdef MPI
 687       if (nfgtasks.gt.1) then
 688         do j=1,3
 689           do i=1,nres
 690             gradbufc(j,i)=gradc(j,i,icg)
 691             gradbufx(j,i)=gradx(j,i,icg)
 692           enddo
 693         enddo
 694         do i=1,4*nres
 695           glocbuf(i)=gloc(i,icg)
 696         enddo
 697         time00=MPI_Wtime()
 698         call MPI_Barrier(FG_COMM,IERR)
 699         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 700         time00=MPI_Wtime()
 701         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 702      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 703         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 704      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 705         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 706      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 707         time_reduce=time_reduce+MPI_Wtime()-time00
 708 #ifdef DEBUG
 709       write (iout,*) "gloc after reduce"
 710       do i=1,4*nres
 711         write (iout,*) i,gloc(i,icg)
 712       enddo
 713 #endif
 714       endif
 715 #endif
 716       if (gnorm_check) then
 717 c
 718 c Compute the maximum elements of the gradient
 719 c
 720       gvdwc_max=0.0d0
 721       gvdwc_scp_max=0.0d0
 722       gelc_max=0.0d0
 723       gvdwpp_max=0.0d0
 724       gradb_max=0.0d0
 725       ghpbc_max=0.0d0
 726       gradcorr_max=0.0d0
 727       gel_loc_max=0.0d0
 728       gcorr3_turn_max=0.0d0
 729       gcorr4_turn_max=0.0d0
 730       gradcorr5_max=0.0d0
 731       gradcorr6_max=0.0d0
 732       gcorr6_turn_max=0.0d0
 733       gsccorc_max=0.0d0
 734       gscloc_max=0.0d0
 735       gvdwx_max=0.0d0
 736       gradx_scp_max=0.0d0
 737       ghpbx_max=0.0d0
 738       gradxorr_max=0.0d0
 739       gsccorx_max=0.0d0
 740       gsclocx_max=0.0d0
 741       do i=1,nct
 742         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 743         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 744 #ifdef TSCSC
 745         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 746         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 747 #endif
 748         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 749         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 750      &   gvdwc_scp_max=gvdwc_scp_norm
 751         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 752         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 753         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 754         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 755         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 756         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 757         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 758         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 759         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 760         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 761         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 762         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 763         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 764      &    gcorr3_turn(1,i)))
 765         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 766      &    gcorr3_turn_max=gcorr3_turn_norm
 767         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 768      &    gcorr4_turn(1,i)))
 769         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 770      &    gcorr4_turn_max=gcorr4_turn_norm
 771         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 772         if (gradcorr5_norm.gt.gradcorr5_max)
 773      &    gradcorr5_max=gradcorr5_norm
 774         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 775         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 776         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 777      &    gcorr6_turn(1,i)))
 778         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 779      &    gcorr6_turn_max=gcorr6_turn_norm
 780         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 781         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 782         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 783         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 784         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 785         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 786 #ifdef TSCSC
 787         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 788         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 789 #endif
 790         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 791         if (gradx_scp_norm.gt.gradx_scp_max)
 792      &    gradx_scp_max=gradx_scp_norm
 793         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 794         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 795         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 796         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 797         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 798         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 799         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 800         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 801       enddo
 802       if (gradout) then
 803 #ifdef AIX
 804         open(istat,file=statname,position="append")
 805 #else
 806         open(istat,file=statname,access="append")
 807 #endif
 808         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 809      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 810      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 811      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 812      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 813      &     gsccorx_max,gsclocx_max
 814         close(istat)
 815         if (gvdwc_max.gt.1.0d4) then
 816           write (iout,*) "gvdwc gvdwx gradb gradbx"
 817           do i=nnt,nct
 818             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 819      &        gradb(j,i),gradbx(j,i),j=1,3)
 820           enddo
 821           call pdbout(0.0d0,'cipiszcze',iout)
 822           call flush(iout)
 823         endif
 824       endif
 825       endif
 826 #ifdef DEBUG
 827       write (iout,*) "gradc gradx gloc"
 828       do i=1,nres
 829         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 830      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 831       enddo
 832 #endif
 833 #ifdef TIMING
 834       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 835 #endif
 836       return
 837       end
 838 c-------------------------------------------------------------------------------
 839       subroutine rescale_weights(t_bath)
 840       implicit real*8 (a-h,o-z)
 841       include 'DIMENSIONS'
 842       include 'COMMON.IOUNITS'
 843       include 'COMMON.FFIELD'
 844       include 'COMMON.SBRIDGE'
 845       double precision kfac /2.4d0/
 846       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 847 c      facT=temp0/t_bath
 848 c      facT=2*temp0/(t_bath+temp0)
 849       if (rescale_mode.eq.0) then
 850         facT=1.0d0
 851         facT2=1.0d0
 852         facT3=1.0d0
 853         facT4=1.0d0
 854         facT5=1.0d0
 855       else if (rescale_mode.eq.1) then
 856         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 857         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 858         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 859         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 860         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 861       else if (rescale_mode.eq.2) then
 862         x=t_bath/temp0
 863         x2=x*x
 864         x3=x2*x
 865         x4=x3*x
 866         x5=x4*x
 867         facT=licznik/dlog(dexp(x)+dexp(-x))
 868         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 869         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 870         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 871         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 872       else
 873         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 874         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 875 #ifdef MPI
 876        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 877 #endif
 878        stop 555
 879       endif
 880       welec=weights(3)*fact
 881       wcorr=weights(4)*fact3
 882       wcorr5=weights(5)*fact4
 883       wcorr6=weights(6)*fact5
 884       wel_loc=weights(7)*fact2
 885       wturn3=weights(8)*fact2
 886       wturn4=weights(9)*fact3
 887       wturn6=weights(10)*fact5
 888       wtor=weights(13)*fact
 889       wtor_d=weights(14)*fact2
 890       wsccor=weights(21)*fact
 891 #ifdef TSCSC
 892 c      wsct=t_bath/temp0
 893       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 894 #endif
 895       return
 896       end
 897 C------------------------------------------------------------------------
 898       subroutine enerprint(energia)
 899       implicit real*8 (a-h,o-z)
 900       include 'DIMENSIONS'
 901       include 'COMMON.IOUNITS'
 902       include 'COMMON.FFIELD'
 903       include 'COMMON.SBRIDGE'
 904       include 'COMMON.MD_'
 905       double precision energia(0:n_ene)
 906       etot=energia(0)
 907 #ifdef TSCSC
 908       evdw=energia(22)+wsct*energia(23)
 909 #else
 910       evdw=energia(1)
 911 #endif
 912       evdw2=energia(2)
 913 #ifdef SCP14
 914       evdw2=energia(2)+energia(18)
 915 #else
 916       evdw2=energia(2)
 917 #endif
 918       ees=energia(3)
 919 #ifdef SPLITELE
 920       evdw1=energia(16)
 921 #endif
 922       ecorr=energia(4)
 923       ecorr5=energia(5)
 924       ecorr6=energia(6)
 925       eel_loc=energia(7)
 926       eello_turn3=energia(8)
 927       eello_turn4=energia(9)
 928       eello_turn6=energia(10)
 929       ebe=energia(11)
 930       escloc=energia(12)
 931       etors=energia(13)
 932       etors_d=energia(14)
 933       ehpb=energia(15)
 934       edihcnstr=energia(19)
 935       estr=energia(17)
 936       Uconst=energia(20)
 937       esccor=energia(21)
 938 #ifdef SPLITELE
 939       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 940      &  estr,wbond,ebe,wang,
 941      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 942      &  ecorr,wcorr,
 943      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 944      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 945      &  edihcnstr,ebr*nss,
 946      &  Uconst,etot
 947    10 format (/'Virtual-chain energies:'//
 948      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 949      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 950      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 951      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 952      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 953      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 954      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 955      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 956      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 957      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 958      & ' (SS bridges & dist. cnstr.)'/
 959      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 960      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 961      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 962      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 963      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 964      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 965      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 966      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 967      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 968      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 969      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 970      & 'ETOT=  ',1pE16.6,' (total)')
 971 #else
 972       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 973      &  estr,wbond,ebe,wang,
 974      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 975      &  ecorr,wcorr,
 976      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 977      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 978      &  ebr*nss,Uconst,etot
 979    10 format (/'Virtual-chain energies:'//
 980      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 981      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 982      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 983      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 984      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 985      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 986      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 987      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 988      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 989      & ' (SS bridges & dist. cnstr.)'/
 990      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 993      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 994      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 995      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 996      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 997      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 998      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 999      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1000      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1001      & 'ETOT=  ',1pE16.6,' (total)')
1002 #endif
1003       return
1004       end
1005 C-----------------------------------------------------------------------
1006       subroutine elj(evdw,evdw_p,evdw_m)
1007 C
1008 C This subroutine calculates the interaction energy of nonbonded side chains
1009 C assuming the LJ potential of interaction.
1010 C
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       parameter (accur=1.0d-10)
1014       include 'COMMON.GEO'
1015       include 'COMMON.VAR'
1016       include 'COMMON.LOCAL'
1017       include 'COMMON.CHAIN'
1018       include 'COMMON.DERIV'
1019       include 'COMMON.INTERACT'
1020       include 'COMMON.TORSION'
1021       include 'COMMON.SBRIDGE'
1022       include 'COMMON.NAMES'
1023       include 'COMMON.IOUNITS'
1024       include 'COMMON.CONTACTS'
1025       dimension gg(3)
1026 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1027       evdw=0.0D0
1028       do i=iatsc_s,iatsc_e
1029         itypi=itype(i)
1030         itypi1=itype(i+1)
1031         xi=c(1,nres+i)
1032         yi=c(2,nres+i)
1033         zi=c(3,nres+i)
1034 C Change 12/1/95
1035         num_conti=0
1036 C
1037 C Calculate SC interaction energy.
1038 C
1039         do iint=1,nint_gr(i)
1040 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1041 cd   &                  'iend=',iend(i,iint)
1042           do j=istart(i,iint),iend(i,iint)
1043             itypj=itype(j)
1044             xj=c(1,nres+j)-xi
1045             yj=c(2,nres+j)-yi
1046             zj=c(3,nres+j)-zi
1047 C Change 12/1/95 to calculate four-body interactions
1048             rij=xj*xj+yj*yj+zj*zj
1049             rrij=1.0D0/rij
1050 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1051             eps0ij=eps(itypi,itypj)
1052             fac=rrij**expon2
1053             e1=fac*fac*aa(itypi,itypj)
1054             e2=fac*bb(itypi,itypj)
1055             evdwij=e1+e2
1056 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1057 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1058 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1059 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1060 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1061 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1062 #ifdef TSCSC
1063             if (bb(itypi,itypj).gt.0) then
1064                evdw_p=evdw_p+evdwij
1065             else
1066                evdw_m=evdw_m+evdwij
1067             endif
1068 #else
1069             evdw=evdw+evdwij
1070 #endif
1071 C
1072 C Calculate the components of the gradient in DC and X
1073 C
1074             fac=-rrij*(e1+evdwij)
1075             gg(1)=xj*fac
1076             gg(2)=yj*fac
1077             gg(3)=zj*fac
1078 #ifdef TSCSC
1079             if (bb(itypi,itypj).gt.0.0d0) then
1080               do k=1,3
1081                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1082                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1083                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1084                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1085               enddo
1086             else
1087               do k=1,3
1088                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1089                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1090                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1091                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1092               enddo
1093             endif
1094 #else
1095             do k=1,3
1096               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1097               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1098               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1099               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1100             enddo
1101 #endif
1102 cgrad            do k=i,j-1
1103 cgrad              do l=1,3
1104 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1105 cgrad              enddo
1106 cgrad            enddo
1107 C
1108 C 12/1/95, revised on 5/20/97
1109 C
1110 C Calculate the contact function. The ith column of the array JCONT will
1111 C contain the numbers of atoms that make contacts with the atom I (of numbers
1112 C greater than I). The arrays FACONT and GACONT will contain the values of
1113 C the contact function and its derivative.
1114 C
1115 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1116 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1117 C Uncomment next line, if the correlation interactions are contact function only
1118             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1119               rij=dsqrt(rij)
1120               sigij=sigma(itypi,itypj)
1121               r0ij=rs0(itypi,itypj)
1122 C
1123 C Check whether the SC's are not too far to make a contact.
1124 C
1125               rcut=1.5d0*r0ij
1126               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1127 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1128 C
1129               if (fcont.gt.0.0D0) then
1130 C If the SC-SC distance if close to sigma, apply spline.
1131 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1132 cAdam &             fcont1,fprimcont1)
1133 cAdam           fcont1=1.0d0-fcont1
1134 cAdam           if (fcont1.gt.0.0d0) then
1135 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1136 cAdam             fcont=fcont*fcont1
1137 cAdam           endif
1138 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1139 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1140 cga             do k=1,3
1141 cga               gg(k)=gg(k)*eps0ij
1142 cga             enddo
1143 cga             eps0ij=-evdwij*eps0ij
1144 C Uncomment for AL's type of SC correlation interactions.
1145 cadam           eps0ij=-evdwij
1146                 num_conti=num_conti+1
1147                 jcont(num_conti,i)=j
1148                 facont(num_conti,i)=fcont*eps0ij
1149                 fprimcont=eps0ij*fprimcont/rij
1150                 fcont=expon*fcont
1151 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1152 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1153 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1154 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1155                 gacont(1,num_conti,i)=-fprimcont*xj
1156                 gacont(2,num_conti,i)=-fprimcont*yj
1157                 gacont(3,num_conti,i)=-fprimcont*zj
1158 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1159 cd              write (iout,'(2i3,3f10.5)')
1160 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1161               endif
1162             endif
1163           enddo      ! j
1164         enddo        ! iint
1165 C Change 12/1/95
1166         num_cont(i)=num_conti
1167       enddo          ! i
1168       do i=1,nct
1169         do j=1,3
1170           gvdwc(j,i)=expon*gvdwc(j,i)
1171           gvdwx(j,i)=expon*gvdwx(j,i)
1172         enddo
1173       enddo
1174 C******************************************************************************
1175 C
1176 C                              N O T E !!!
1177 C
1178 C To save time, the factor of EXPON has been extracted from ALL components
1179 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1180 C use!
1181 C
1182 C******************************************************************************
1183       return
1184       end
1185 C-----------------------------------------------------------------------------
1186       subroutine eljk(evdw,evdw_p,evdw_m)
1187 C
1188 C This subroutine calculates the interaction energy of nonbonded side chains
1189 C assuming the LJK potential of interaction.
1190 C
1191       implicit real*8 (a-h,o-z)
1192       include 'DIMENSIONS'
1193       include 'COMMON.GEO'
1194       include 'COMMON.VAR'
1195       include 'COMMON.LOCAL'
1196       include 'COMMON.CHAIN'
1197       include 'COMMON.DERIV'
1198       include 'COMMON.INTERACT'
1199       include 'COMMON.IOUNITS'
1200       include 'COMMON.NAMES'
1201       dimension gg(3)
1202       logical scheck
1203 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1204       evdw=0.0D0
1205       do i=iatsc_s,iatsc_e
1206         itypi=itype(i)
1207         itypi1=itype(i+1)
1208         xi=c(1,nres+i)
1209         yi=c(2,nres+i)
1210         zi=c(3,nres+i)
1211 C
1212 C Calculate SC interaction energy.
1213 C
1214         do iint=1,nint_gr(i)
1215           do j=istart(i,iint),iend(i,iint)
1216             itypj=itype(j)
1217             xj=c(1,nres+j)-xi
1218             yj=c(2,nres+j)-yi
1219             zj=c(3,nres+j)-zi
1220             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1221             fac_augm=rrij**expon
1222             e_augm=augm(itypi,itypj)*fac_augm
1223             r_inv_ij=dsqrt(rrij)
1224             rij=1.0D0/r_inv_ij
1225             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1226             fac=r_shift_inv**expon
1227             e1=fac*fac*aa(itypi,itypj)
1228             e2=fac*bb(itypi,itypj)
1229             evdwij=e_augm+e1+e2
1230 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1231 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1232 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1233 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1234 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1235 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1236 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1237 #ifdef TSCSC
1238             if (bb(itypi,itypj).gt.0) then
1239                evdw_p=evdw_p+evdwij
1240             else
1241                evdw_m=evdw_m+evdwij
1242             endif
1243 #else
1244             evdw=evdw+evdwij
1245 #endif
1246 C
1247 C Calculate the components of the gradient in DC and X
1248 C
1249             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1250             gg(1)=xj*fac
1251             gg(2)=yj*fac
1252             gg(3)=zj*fac
1253 #ifdef TSCSC
1254             if (bb(itypi,itypj).gt.0.0d0) then
1255               do k=1,3
1256                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1257                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1258                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1259                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1260               enddo
1261             else
1262               do k=1,3
1263                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1264                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1265                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1266                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1267               enddo
1268             endif
1269 #else
1270             do k=1,3
1271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1275             enddo
1276 #endif
1277 cgrad            do k=i,j-1
1278 cgrad              do l=1,3
1279 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1280 cgrad              enddo
1281 cgrad            enddo
1282           enddo      ! j
1283         enddo        ! iint
1284       enddo          ! i
1285       do i=1,nct
1286         do j=1,3
1287           gvdwc(j,i)=expon*gvdwc(j,i)
1288           gvdwx(j,i)=expon*gvdwx(j,i)
1289         enddo
1290       enddo
1291       return
1292       end
1293 C-----------------------------------------------------------------------------
1294       subroutine ebp(evdw,evdw_p,evdw_m)
1295 C
1296 C This subroutine calculates the interaction energy of nonbonded side chains
1297 C assuming the Berne-Pechukas potential of interaction.
1298 C
1299       implicit real*8 (a-h,o-z)
1300       include 'DIMENSIONS'
1301       include 'COMMON.GEO'
1302       include 'COMMON.VAR'
1303       include 'COMMON.LOCAL'
1304       include 'COMMON.CHAIN'
1305       include 'COMMON.DERIV'
1306       include 'COMMON.NAMES'
1307       include 'COMMON.INTERACT'
1308       include 'COMMON.IOUNITS'
1309       include 'COMMON.CALC'
1310       common /srutu/ icall
1311 c     double precision rrsave(maxdim)
1312       logical lprn
1313       evdw=0.0D0
1314 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316 c     if (icall.eq.0) then
1317 c       lprn=.true.
1318 c     else
1319         lprn=.false.
1320 c     endif
1321       ind=0
1322       do i=iatsc_s,iatsc_e
1323         itypi=itype(i)
1324         itypi1=itype(i+1)
1325         xi=c(1,nres+i)
1326         yi=c(2,nres+i)
1327         zi=c(3,nres+i)
1328         dxi=dc_norm(1,nres+i)
1329         dyi=dc_norm(2,nres+i)
1330         dzi=dc_norm(3,nres+i)
1331 c        dsci_inv=dsc_inv(itypi)
1332         dsci_inv=vbld_inv(i+nres)
1333 C
1334 C Calculate SC interaction energy.
1335 C
1336         do iint=1,nint_gr(i)
1337           do j=istart(i,iint),iend(i,iint)
1338             ind=ind+1
1339             itypj=itype(j)
1340 c            dscj_inv=dsc_inv(itypj)
1341             dscj_inv=vbld_inv(j+nres)
1342             chi1=chi(itypi,itypj)
1343             chi2=chi(itypj,itypi)
1344             chi12=chi1*chi2
1345             chip1=chip(itypi)
1346             chip2=chip(itypj)
1347             chip12=chip1*chip2
1348             alf1=alp(itypi)
1349             alf2=alp(itypj)
1350             alf12=0.5D0*(alf1+alf2)
1351 C For diagnostics only!!!
1352 c           chi1=0.0D0
1353 c           chi2=0.0D0
1354 c           chi12=0.0D0
1355 c           chip1=0.0D0
1356 c           chip2=0.0D0
1357 c           chip12=0.0D0
1358 c           alf1=0.0D0
1359 c           alf2=0.0D0
1360 c           alf12=0.0D0
1361             xj=c(1,nres+j)-xi
1362             yj=c(2,nres+j)-yi
1363             zj=c(3,nres+j)-zi
1364             dxj=dc_norm(1,nres+j)
1365             dyj=dc_norm(2,nres+j)
1366             dzj=dc_norm(3,nres+j)
1367             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1368 cd          if (icall.eq.0) then
1369 cd            rrsave(ind)=rrij
1370 cd          else
1371 cd            rrij=rrsave(ind)
1372 cd          endif
1373             rij=dsqrt(rrij)
1374 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1375             call sc_angular
1376 C Calculate whole angle-dependent part of epsilon and contributions
1377 C to its derivatives
1378             fac=(rrij*sigsq)**expon2
1379             e1=fac*fac*aa(itypi,itypj)
1380             e2=fac*bb(itypi,itypj)
1381             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1382             eps2der=evdwij*eps3rt
1383             eps3der=evdwij*eps2rt
1384             evdwij=evdwij*eps2rt*eps3rt
1385 #ifdef TSCSC
1386             if (bb(itypi,itypj).gt.0) then
1387                evdw_p=evdw_p+evdwij
1388             else
1389                evdw_m=evdw_m+evdwij
1390             endif
1391 #else
1392             evdw=evdw+evdwij
1393 #endif
1394             if (lprn) then
1395             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1396             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1397 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1398 cd     &        restyp(itypi),i,restyp(itypj),j,
1399 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1400 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1401 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1402 cd     &        evdwij
1403             endif
1404 C Calculate gradient components.
1405             e1=e1*eps1*eps2rt**2*eps3rt**2
1406             fac=-expon*(e1+evdwij)
1407             sigder=fac/sigsq
1408             fac=rrij*fac
1409 C Calculate radial part of the gradient
1410             gg(1)=xj*fac
1411             gg(2)=yj*fac
1412             gg(3)=zj*fac
1413 C Calculate the angular part of the gradient and sum add the contributions
1414 C to the appropriate components of the Cartesian gradient.
1415 #ifdef TSCSC
1416             if (bb(itypi,itypj).gt.0) then
1417                call sc_grad
1418             else
1419                call sc_grad_T
1420             endif
1421 #else
1422             call sc_grad
1423 #endif
1424           enddo      ! j
1425         enddo        ! iint
1426       enddo          ! i
1427 c     stop
1428       return
1429       end
1430 C-----------------------------------------------------------------------------
1431       subroutine egb(evdw,evdw_p,evdw_m)
1432 C
1433 C This subroutine calculates the interaction energy of nonbonded side chains
1434 C assuming the Gay-Berne potential of interaction.
1435 C
1436       implicit real*8 (a-h,o-z)
1437       include 'DIMENSIONS'
1438       include 'COMMON.GEO'
1439       include 'COMMON.VAR'
1440       include 'COMMON.LOCAL'
1441       include 'COMMON.CHAIN'
1442       include 'COMMON.DERIV'
1443       include 'COMMON.NAMES'
1444       include 'COMMON.INTERACT'
1445       include 'COMMON.IOUNITS'
1446       include 'COMMON.CALC'
1447       include 'COMMON.CONTROL'
1448       logical lprn
1449       evdw=0.0D0
1450 ccccc      energy_dec=.false.
1451 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1452       evdw=0.0D0
1453       evdw_p=0.0D0
1454       evdw_m=0.0D0
1455       lprn=.false.
1456 c     if (icall.eq.0) lprn=.false.
1457       ind=0
1458       do i=iatsc_s,iatsc_e
1459         itypi=itype(i)
1460         itypi1=itype(i+1)
1461         xi=c(1,nres+i)
1462         yi=c(2,nres+i)
1463         zi=c(3,nres+i)
1464         dxi=dc_norm(1,nres+i)
1465         dyi=dc_norm(2,nres+i)
1466         dzi=dc_norm(3,nres+i)
1467 c        dsci_inv=dsc_inv(itypi)
1468         dsci_inv=vbld_inv(i+nres)
1469 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1470 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1471 C
1472 C Calculate SC interaction energy.
1473 C
1474         do iint=1,nint_gr(i)
1475           do j=istart(i,iint),iend(i,iint)
1476             ind=ind+1
1477             itypj=itype(j)
1478 c            dscj_inv=dsc_inv(itypj)
1479             dscj_inv=vbld_inv(j+nres)
1480 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1481 c     &       1.0d0/vbld(j+nres)
1482 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1483             sig0ij=sigma(itypi,itypj)
1484             chi1=chi(itypi,itypj)
1485             chi2=chi(itypj,itypi)
1486             chi12=chi1*chi2
1487             chip1=chip(itypi)
1488             chip2=chip(itypj)
1489             chip12=chip1*chip2
1490             alf1=alp(itypi)
1491             alf2=alp(itypj)
1492             alf12=0.5D0*(alf1+alf2)
1493 C For diagnostics only!!!
1494 c           chi1=0.0D0
1495 c           chi2=0.0D0
1496 c           chi12=0.0D0
1497 c           chip1=0.0D0
1498 c           chip2=0.0D0
1499 c           chip12=0.0D0
1500 c           alf1=0.0D0
1501 c           alf2=0.0D0
1502 c           alf12=0.0D0
1503             xj=c(1,nres+j)-xi
1504             yj=c(2,nres+j)-yi
1505             zj=c(3,nres+j)-zi
1506             dxj=dc_norm(1,nres+j)
1507             dyj=dc_norm(2,nres+j)
1508             dzj=dc_norm(3,nres+j)
1509 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1510 c            write (iout,*) "j",j," dc_norm",
1511 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1512             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1513             rij=dsqrt(rrij)
1514 C Calculate angle-dependent terms of energy and contributions to their
1515 C derivatives.
1516             call sc_angular
1517             sigsq=1.0D0/sigsq
1518             sig=sig0ij*dsqrt(sigsq)
1519             rij_shift=1.0D0/rij-sig+sig0ij
1520 c for diagnostics; uncomment
1521 c            rij_shift=1.2*sig0ij
1522 C I hate to put IF's in the loops, but here don't have another choice!!!!
1523             if (rij_shift.le.0.0D0) then
1524               evdw=1.0D20
1525 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526 cd     &        restyp(itypi),i,restyp(itypj),j,
1527 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1528               return
1529             endif
1530             sigder=-sig*sigsq
1531 c---------------------------------------------------------------
1532             rij_shift=1.0D0/rij_shift
1533             fac=rij_shift**expon
1534             e1=fac*fac*aa(itypi,itypj)
1535             e2=fac*bb(itypi,itypj)
1536             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1537             eps2der=evdwij*eps3rt
1538             eps3der=evdwij*eps2rt
1539 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1540 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1541             evdwij=evdwij*eps2rt*eps3rt
1542 #ifdef TSCSC
1543             if (bb(itypi,itypj).gt.0) then
1544                evdw_p=evdw_p+evdwij
1545             else
1546                evdw_m=evdw_m+evdwij
1547             endif
1548 #else
1549             evdw=evdw+evdwij
1550 #endif
1551             if (lprn) then
1552             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1553             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1554             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1555      &        restyp(itypi),i,restyp(itypj),j,
1556      &        epsi,sigm,chi1,chi2,chip1,chip2,
1557      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1558      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1559      &        evdwij
1560             endif
1561
1562             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1563      &                        'evdw',i,j,evdwij
1564
1565 C Calculate gradient components.
1566             e1=e1*eps1*eps2rt**2*eps3rt**2
1567             fac=-expon*(e1+evdwij)*rij_shift
1568             sigder=fac*sigder
1569             fac=rij*fac
1570 c            fac=0.0d0
1571 C Calculate the radial part of the gradient
1572             gg(1)=xj*fac
1573             gg(2)=yj*fac
1574             gg(3)=zj*fac
1575 C Calculate angular part of the gradient.
1576 #ifdef TSCSC
1577             if (bb(itypi,itypj).gt.0) then
1578                call sc_grad
1579             else
1580                call sc_grad_T
1581             endif
1582 #else
1583             call sc_grad
1584 #endif
1585           enddo      ! j
1586         enddo        ! iint
1587       enddo          ! i
1588 c      write (iout,*) "Number of loop steps in EGB:",ind
1589 cccc      energy_dec=.false.
1590       return
1591       end
1592 C-----------------------------------------------------------------------------
1593       subroutine egbv(evdw,evdw_p,evdw_m)
1594 C
1595 C This subroutine calculates the interaction energy of nonbonded side chains
1596 C assuming the Gay-Berne-Vorobjev potential of interaction.
1597 C
1598       implicit real*8 (a-h,o-z)
1599       include 'DIMENSIONS'
1600       include 'COMMON.GEO'
1601       include 'COMMON.VAR'
1602       include 'COMMON.LOCAL'
1603       include 'COMMON.CHAIN'
1604       include 'COMMON.DERIV'
1605       include 'COMMON.NAMES'
1606       include 'COMMON.INTERACT'
1607       include 'COMMON.IOUNITS'
1608       include 'COMMON.CALC'
1609       common /srutu/ icall
1610       logical lprn
1611       evdw=0.0D0
1612 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1613       evdw=0.0D0
1614       lprn=.false.
1615 c     if (icall.eq.0) lprn=.true.
1616       ind=0
1617       do i=iatsc_s,iatsc_e
1618         itypi=itype(i)
1619         itypi1=itype(i+1)
1620         xi=c(1,nres+i)
1621         yi=c(2,nres+i)
1622         zi=c(3,nres+i)
1623         dxi=dc_norm(1,nres+i)
1624         dyi=dc_norm(2,nres+i)
1625         dzi=dc_norm(3,nres+i)
1626 c        dsci_inv=dsc_inv(itypi)
1627         dsci_inv=vbld_inv(i+nres)
1628 C
1629 C Calculate SC interaction energy.
1630 C
1631         do iint=1,nint_gr(i)
1632           do j=istart(i,iint),iend(i,iint)
1633             ind=ind+1
1634             itypj=itype(j)
1635 c            dscj_inv=dsc_inv(itypj)
1636             dscj_inv=vbld_inv(j+nres)
1637             sig0ij=sigma(itypi,itypj)
1638             r0ij=r0(itypi,itypj)
1639             chi1=chi(itypi,itypj)
1640             chi2=chi(itypj,itypi)
1641             chi12=chi1*chi2
1642             chip1=chip(itypi)
1643             chip2=chip(itypj)
1644             chip12=chip1*chip2
1645             alf1=alp(itypi)
1646             alf2=alp(itypj)
1647             alf12=0.5D0*(alf1+alf2)
1648 C For diagnostics only!!!
1649 c           chi1=0.0D0
1650 c           chi2=0.0D0
1651 c           chi12=0.0D0
1652 c           chip1=0.0D0
1653 c           chip2=0.0D0
1654 c           chip12=0.0D0
1655 c           alf1=0.0D0
1656 c           alf2=0.0D0
1657 c           alf12=0.0D0
1658             xj=c(1,nres+j)-xi
1659             yj=c(2,nres+j)-yi
1660             zj=c(3,nres+j)-zi
1661             dxj=dc_norm(1,nres+j)
1662             dyj=dc_norm(2,nres+j)
1663             dzj=dc_norm(3,nres+j)
1664             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1665             rij=dsqrt(rrij)
1666 C Calculate angle-dependent terms of energy and contributions to their
1667 C derivatives.
1668             call sc_angular
1669             sigsq=1.0D0/sigsq
1670             sig=sig0ij*dsqrt(sigsq)
1671             rij_shift=1.0D0/rij-sig+r0ij
1672 C I hate to put IF's in the loops, but here don't have another choice!!!!
1673             if (rij_shift.le.0.0D0) then
1674               evdw=1.0D20
1675               return
1676             endif
1677             sigder=-sig*sigsq
1678 c---------------------------------------------------------------
1679             rij_shift=1.0D0/rij_shift
1680             fac=rij_shift**expon
1681             e1=fac*fac*aa(itypi,itypj)
1682             e2=fac*bb(itypi,itypj)
1683             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1684             eps2der=evdwij*eps3rt
1685             eps3der=evdwij*eps2rt
1686             fac_augm=rrij**expon
1687             e_augm=augm(itypi,itypj)*fac_augm
1688             evdwij=evdwij*eps2rt*eps3rt
1689 #ifdef TSCSC
1690             if (bb(itypi,itypj).gt.0) then
1691                evdw_p=evdw_p+evdwij+e_augm
1692             else
1693                evdw_m=evdw_m+evdwij+e_augm
1694             endif
1695 #else
1696             evdw=evdw+evdwij+e_augm
1697 #endif
1698             if (lprn) then
1699             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1700             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1701             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1702      &        restyp(itypi),i,restyp(itypj),j,
1703      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1704      &        chi1,chi2,chip1,chip2,
1705      &        eps1,eps2rt**2,eps3rt**2,
1706      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1707      &        evdwij+e_augm
1708             endif
1709 C Calculate gradient components.
1710             e1=e1*eps1*eps2rt**2*eps3rt**2
1711             fac=-expon*(e1+evdwij)*rij_shift
1712             sigder=fac*sigder
1713             fac=rij*fac-2*expon*rrij*e_augm
1714 C Calculate the radial part of the gradient
1715             gg(1)=xj*fac
1716             gg(2)=yj*fac
1717             gg(3)=zj*fac
1718 C Calculate angular part of the gradient.
1719 #ifdef TSCSC
1720             if (bb(itypi,itypj).gt.0) then
1721                call sc_grad
1722             else
1723                call sc_grad_T
1724             endif
1725 #else
1726             call sc_grad
1727 #endif
1728           enddo      ! j
1729         enddo        ! iint
1730       enddo          ! i
1731       end
1732 C-----------------------------------------------------------------------------
1733       subroutine sc_angular
1734 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1735 C om12. Called by ebp, egb, and egbv.
1736       implicit none
1737       include 'COMMON.CALC'
1738       include 'COMMON.IOUNITS'
1739       erij(1)=xj*rij
1740       erij(2)=yj*rij
1741       erij(3)=zj*rij
1742       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1743       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1744       om12=dxi*dxj+dyi*dyj+dzi*dzj
1745       chiom12=chi12*om12
1746 C Calculate eps1(om12) and its derivative in om12
1747       faceps1=1.0D0-om12*chiom12
1748       faceps1_inv=1.0D0/faceps1
1749       eps1=dsqrt(faceps1_inv)
1750 C Following variable is eps1*deps1/dom12
1751       eps1_om12=faceps1_inv*chiom12
1752 c diagnostics only
1753 c      faceps1_inv=om12
1754 c      eps1=om12
1755 c      eps1_om12=1.0d0
1756 c      write (iout,*) "om12",om12," eps1",eps1
1757 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1758 C and om12.
1759       om1om2=om1*om2
1760       chiom1=chi1*om1
1761       chiom2=chi2*om2
1762       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1763       sigsq=1.0D0-facsig*faceps1_inv
1764       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1765       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1766       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1767 c diagnostics only
1768 c      sigsq=1.0d0
1769 c      sigsq_om1=0.0d0
1770 c      sigsq_om2=0.0d0
1771 c      sigsq_om12=0.0d0
1772 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1773 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1774 c     &    " eps1",eps1
1775 C Calculate eps2 and its derivatives in om1, om2, and om12.
1776       chipom1=chip1*om1
1777       chipom2=chip2*om2
1778       chipom12=chip12*om12
1779       facp=1.0D0-om12*chipom12
1780       facp_inv=1.0D0/facp
1781       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1782 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1783 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1784 C Following variable is the square root of eps2
1785       eps2rt=1.0D0-facp1*facp_inv
1786 C Following three variables are the derivatives of the square root of eps
1787 C in om1, om2, and om12.
1788       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1789       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1790       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1791 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1792       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1793 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1794 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1795 c     &  " eps2rt_om12",eps2rt_om12
1796 C Calculate whole angle-dependent part of epsilon and contributions
1797 C to its derivatives
1798       return
1799       end
1800
1801 C----------------------------------------------------------------------------
1802       subroutine sc_grad_T
1803       implicit real*8 (a-h,o-z)
1804       include 'DIMENSIONS'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.CALC'
1808       include 'COMMON.IOUNITS'
1809       double precision dcosom1(3),dcosom2(3)
1810       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1811       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1812       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1813      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1814 c diagnostics only
1815 c      eom1=0.0d0
1816 c      eom2=0.0d0
1817 c      eom12=evdwij*eps1_om12
1818 c end diagnostics
1819 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1820 c     &  " sigder",sigder
1821 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1822 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1823       do k=1,3
1824         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1825         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1826       enddo
1827       do k=1,3
1828         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1829       enddo
1830 c      write (iout,*) "gg",(gg(k),k=1,3)
1831       do k=1,3
1832         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1833      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1834      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1835         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1836      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1837      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1838 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1839 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1840 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1841 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1842       enddo
1843 C
1844 C Calculate the components of the gradient in DC and X
1845 C
1846 cgrad      do k=i,j-1
1847 cgrad        do l=1,3
1848 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1849 cgrad        enddo
1850 cgrad      enddo
1851       do l=1,3
1852         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1853         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1854       enddo
1855       return
1856       end
1857
1858 C----------------------------------------------------------------------------
1859       subroutine sc_grad
1860       implicit real*8 (a-h,o-z)
1861       include 'DIMENSIONS'
1862       include 'COMMON.CHAIN'
1863       include 'COMMON.DERIV'
1864       include 'COMMON.CALC'
1865       include 'COMMON.IOUNITS'
1866       double precision dcosom1(3),dcosom2(3)
1867       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1868       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1869       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1870      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1871 c diagnostics only
1872 c      eom1=0.0d0
1873 c      eom2=0.0d0
1874 c      eom12=evdwij*eps1_om12
1875 c end diagnostics
1876 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1877 c     &  " sigder",sigder
1878 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1879 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1880       do k=1,3
1881         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1882         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1883       enddo
1884       do k=1,3
1885         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1886       enddo
1887 c      write (iout,*) "gg",(gg(k),k=1,3)
1888       do k=1,3
1889         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1890      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1891      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1892         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1893      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1894      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1895 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1896 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1897 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1898 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1899       enddo
1900 C
1901 C Calculate the components of the gradient in DC and X
1902 C
1903 cgrad      do k=i,j-1
1904 cgrad        do l=1,3
1905 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad        enddo
1907 cgrad      enddo
1908       do l=1,3
1909         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1910         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1911       enddo
1912       return
1913       end
1914 C-----------------------------------------------------------------------
1915       subroutine e_softsphere(evdw)
1916 C
1917 C This subroutine calculates the interaction energy of nonbonded side chains
1918 C assuming the LJ potential of interaction.
1919 C
1920       implicit real*8 (a-h,o-z)
1921       include 'DIMENSIONS'
1922       parameter (accur=1.0d-10)
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.TORSION'
1930       include 'COMMON.SBRIDGE'
1931       include 'COMMON.NAMES'
1932       include 'COMMON.IOUNITS'
1933       include 'COMMON.CONTACTS'
1934       dimension gg(3)
1935 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1936       evdw=0.0D0
1937       do i=iatsc_s,iatsc_e
1938         itypi=itype(i)
1939         itypi1=itype(i+1)
1940         xi=c(1,nres+i)
1941         yi=c(2,nres+i)
1942         zi=c(3,nres+i)
1943 C
1944 C Calculate SC interaction energy.
1945 C
1946         do iint=1,nint_gr(i)
1947 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1948 cd   &                  'iend=',iend(i,iint)
1949           do j=istart(i,iint),iend(i,iint)
1950             itypj=itype(j)
1951             xj=c(1,nres+j)-xi
1952             yj=c(2,nres+j)-yi
1953             zj=c(3,nres+j)-zi
1954             rij=xj*xj+yj*yj+zj*zj
1955 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1956             r0ij=r0(itypi,itypj)
1957             r0ijsq=r0ij*r0ij
1958 c            print *,i,j,r0ij,dsqrt(rij)
1959             if (rij.lt.r0ijsq) then
1960               evdwij=0.25d0*(rij-r0ijsq)**2
1961               fac=rij-r0ijsq
1962             else
1963               evdwij=0.0d0
1964               fac=0.0d0
1965             endif
1966             evdw=evdw+evdwij
1967 C
1968 C Calculate the components of the gradient in DC and X
1969 C
1970             gg(1)=xj*fac
1971             gg(2)=yj*fac
1972             gg(3)=zj*fac
1973             do k=1,3
1974               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1975               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1976               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1977               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1978             enddo
1979 cgrad            do k=i,j-1
1980 cgrad              do l=1,3
1981 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1982 cgrad              enddo
1983 cgrad            enddo
1984           enddo ! j
1985         enddo ! iint
1986       enddo ! i
1987       return
1988       end
1989 C--------------------------------------------------------------------------
1990       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1991      &              eello_turn4)
1992 C
1993 C Soft-sphere potential of p-p interaction
1994 C
1995       implicit real*8 (a-h,o-z)
1996       include 'DIMENSIONS'
1997       include 'COMMON.CONTROL'
1998       include 'COMMON.IOUNITS'
1999       include 'COMMON.GEO'
2000       include 'COMMON.VAR'
2001       include 'COMMON.LOCAL'
2002       include 'COMMON.CHAIN'
2003       include 'COMMON.DERIV'
2004       include 'COMMON.INTERACT'
2005       include 'COMMON.CONTACTS'
2006       include 'COMMON.TORSION'
2007       include 'COMMON.VECTORS'
2008       include 'COMMON.FFIELD'
2009       dimension ggg(3)
2010 cd      write(iout,*) 'In EELEC_soft_sphere'
2011       ees=0.0D0
2012       evdw1=0.0D0
2013       eel_loc=0.0d0
2014       eello_turn3=0.0d0
2015       eello_turn4=0.0d0
2016       ind=0
2017       do i=iatel_s,iatel_e
2018         dxi=dc(1,i)
2019         dyi=dc(2,i)
2020         dzi=dc(3,i)
2021         xmedi=c(1,i)+0.5d0*dxi
2022         ymedi=c(2,i)+0.5d0*dyi
2023         zmedi=c(3,i)+0.5d0*dzi
2024         num_conti=0
2025 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2026         do j=ielstart(i),ielend(i)
2027           ind=ind+1
2028           iteli=itel(i)
2029           itelj=itel(j)
2030           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2031           r0ij=rpp(iteli,itelj)
2032           r0ijsq=r0ij*r0ij
2033           dxj=dc(1,j)
2034           dyj=dc(2,j)
2035           dzj=dc(3,j)
2036           xj=c(1,j)+0.5D0*dxj-xmedi
2037           yj=c(2,j)+0.5D0*dyj-ymedi
2038           zj=c(3,j)+0.5D0*dzj-zmedi
2039           rij=xj*xj+yj*yj+zj*zj
2040           if (rij.lt.r0ijsq) then
2041             evdw1ij=0.25d0*(rij-r0ijsq)**2
2042             fac=rij-r0ijsq
2043           else
2044             evdw1ij=0.0d0
2045             fac=0.0d0
2046           endif
2047           evdw1=evdw1+evdw1ij
2048 C
2049 C Calculate contributions to the Cartesian gradient.
2050 C
2051           ggg(1)=fac*xj
2052           ggg(2)=fac*yj
2053           ggg(3)=fac*zj
2054           do k=1,3
2055             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2056             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2057           enddo
2058 *
2059 * Loop over residues i+1 thru j-1.
2060 *
2061 cgrad          do k=i+1,j-1
2062 cgrad            do l=1,3
2063 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2064 cgrad            enddo
2065 cgrad          enddo
2066         enddo ! j
2067       enddo   ! i
2068 cgrad      do i=nnt,nct-1
2069 cgrad        do k=1,3
2070 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2071 cgrad        enddo
2072 cgrad        do j=i+1,nct-1
2073 cgrad          do k=1,3
2074 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2075 cgrad          enddo
2076 cgrad        enddo
2077 cgrad      enddo
2078       return
2079       end
2080 c------------------------------------------------------------------------------
2081       subroutine vec_and_deriv
2082       implicit real*8 (a-h,o-z)
2083       include 'DIMENSIONS'
2084 #ifdef MPI
2085       include 'mpif.h'
2086 #endif
2087       include 'COMMON.IOUNITS'
2088       include 'COMMON.GEO'
2089       include 'COMMON.VAR'
2090       include 'COMMON.LOCAL'
2091       include 'COMMON.CHAIN'
2092       include 'COMMON.VECTORS'
2093       include 'COMMON.SETUP'
2094       include 'COMMON.TIME1'
2095       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2096 C Compute the local reference systems. For reference system (i), the
2097 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2098 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2099 #ifdef PARVEC
2100       do i=ivec_start,ivec_end
2101 #else
2102       do i=1,nres-1
2103 #endif
2104           if (i.eq.nres-1) then
2105 C Case of the last full residue
2106 C Compute the Z-axis
2107             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2108             costh=dcos(pi-theta(nres))
2109             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2110             do k=1,3
2111               uz(k,i)=fac*uz(k,i)
2112             enddo
2113 C Compute the derivatives of uz
2114             uzder(1,1,1)= 0.0d0
2115             uzder(2,1,1)=-dc_norm(3,i-1)
2116             uzder(3,1,1)= dc_norm(2,i-1)
2117             uzder(1,2,1)= dc_norm(3,i-1)
2118             uzder(2,2,1)= 0.0d0
2119             uzder(3,2,1)=-dc_norm(1,i-1)
2120             uzder(1,3,1)=-dc_norm(2,i-1)
2121             uzder(2,3,1)= dc_norm(1,i-1)
2122             uzder(3,3,1)= 0.0d0
2123             uzder(1,1,2)= 0.0d0
2124             uzder(2,1,2)= dc_norm(3,i)
2125             uzder(3,1,2)=-dc_norm(2,i)
2126             uzder(1,2,2)=-dc_norm(3,i)
2127             uzder(2,2,2)= 0.0d0
2128             uzder(3,2,2)= dc_norm(1,i)
2129             uzder(1,3,2)= dc_norm(2,i)
2130             uzder(2,3,2)=-dc_norm(1,i)
2131             uzder(3,3,2)= 0.0d0
2132 C Compute the Y-axis
2133             facy=fac
2134             do k=1,3
2135               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2136             enddo
2137 C Compute the derivatives of uy
2138             do j=1,3
2139               do k=1,3
2140                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2141      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2142                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2143               enddo
2144               uyder(j,j,1)=uyder(j,j,1)-costh
2145               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2146             enddo
2147             do j=1,2
2148               do k=1,3
2149                 do l=1,3
2150                   uygrad(l,k,j,i)=uyder(l,k,j)
2151                   uzgrad(l,k,j,i)=uzder(l,k,j)
2152                 enddo
2153               enddo
2154             enddo
2155             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2156             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2157             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2158             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2159           else
2160 C Other residues
2161 C Compute the Z-axis
2162             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2163             costh=dcos(pi-theta(i+2))
2164             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2165             do k=1,3
2166               uz(k,i)=fac*uz(k,i)
2167             enddo
2168 C Compute the derivatives of uz
2169             uzder(1,1,1)= 0.0d0
2170             uzder(2,1,1)=-dc_norm(3,i+1)
2171             uzder(3,1,1)= dc_norm(2,i+1)
2172             uzder(1,2,1)= dc_norm(3,i+1)
2173             uzder(2,2,1)= 0.0d0
2174             uzder(3,2,1)=-dc_norm(1,i+1)
2175             uzder(1,3,1)=-dc_norm(2,i+1)
2176             uzder(2,3,1)= dc_norm(1,i+1)
2177             uzder(3,3,1)= 0.0d0
2178             uzder(1,1,2)= 0.0d0
2179             uzder(2,1,2)= dc_norm(3,i)
2180             uzder(3,1,2)=-dc_norm(2,i)
2181             uzder(1,2,2)=-dc_norm(3,i)
2182             uzder(2,2,2)= 0.0d0
2183             uzder(3,2,2)= dc_norm(1,i)
2184             uzder(1,3,2)= dc_norm(2,i)
2185             uzder(2,3,2)=-dc_norm(1,i)
2186             uzder(3,3,2)= 0.0d0
2187 C Compute the Y-axis
2188             facy=fac
2189             do k=1,3
2190               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2191             enddo
2192 C Compute the derivatives of uy
2193             do j=1,3
2194               do k=1,3
2195                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2196      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2197                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2198               enddo
2199               uyder(j,j,1)=uyder(j,j,1)-costh
2200               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2201             enddo
2202             do j=1,2
2203               do k=1,3
2204                 do l=1,3
2205                   uygrad(l,k,j,i)=uyder(l,k,j)
2206                   uzgrad(l,k,j,i)=uzder(l,k,j)
2207                 enddo
2208               enddo
2209             enddo
2210             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2211             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2212             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2213             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2214           endif
2215       enddo
2216       do i=1,nres-1
2217         vbld_inv_temp(1)=vbld_inv(i+1)
2218         if (i.lt.nres-1) then
2219           vbld_inv_temp(2)=vbld_inv(i+2)
2220           else
2221           vbld_inv_temp(2)=vbld_inv(i)
2222           endif
2223         do j=1,2
2224           do k=1,3
2225             do l=1,3
2226               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2227               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2228             enddo
2229           enddo
2230         enddo
2231       enddo
2232 #if defined(PARVEC) && defined(MPI)
2233       if (nfgtasks1.gt.1) then
2234         time00=MPI_Wtime()
2235 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2236 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2237 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2238         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2239      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2240      &   FG_COMM1,IERR)
2241         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2242      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2243      &   FG_COMM1,IERR)
2244         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2245      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2246      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2247         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2248      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2249      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2250         time_gather=time_gather+MPI_Wtime()-time00
2251       endif
2252 c      if (fg_rank.eq.0) then
2253 c        write (iout,*) "Arrays UY and UZ"
2254 c        do i=1,nres-1
2255 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2256 c     &     (uz(k,i),k=1,3)
2257 c        enddo
2258 c      endif
2259 #endif
2260       return
2261       end
2262 C-----------------------------------------------------------------------------
2263       subroutine check_vecgrad
2264       implicit real*8 (a-h,o-z)
2265       include 'DIMENSIONS'
2266       include 'COMMON.IOUNITS'
2267       include 'COMMON.GEO'
2268       include 'COMMON.VAR'
2269       include 'COMMON.LOCAL'
2270       include 'COMMON.CHAIN'
2271       include 'COMMON.VECTORS'
2272       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2273       dimension uyt(3,maxres),uzt(3,maxres)
2274       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2275       double precision delta /1.0d-7/
2276       call vec_and_deriv
2277 cd      do i=1,nres
2278 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2279 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2280 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2281 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2282 cd     &     (dc_norm(if90,i),if90=1,3)
2283 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2284 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2285 cd          write(iout,'(a)')
2286 cd      enddo
2287       do i=1,nres
2288         do j=1,2
2289           do k=1,3
2290             do l=1,3
2291               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2292               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2293             enddo
2294           enddo
2295         enddo
2296       enddo
2297       call vec_and_deriv
2298       do i=1,nres
2299         do j=1,3
2300           uyt(j,i)=uy(j,i)
2301           uzt(j,i)=uz(j,i)
2302         enddo
2303       enddo
2304       do i=1,nres
2305 cd        write (iout,*) 'i=',i
2306         do k=1,3
2307           erij(k)=dc_norm(k,i)
2308         enddo
2309         do j=1,3
2310           do k=1,3
2311             dc_norm(k,i)=erij(k)
2312           enddo
2313           dc_norm(j,i)=dc_norm(j,i)+delta
2314 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2315 c          do k=1,3
2316 c            dc_norm(k,i)=dc_norm(k,i)/fac
2317 c          enddo
2318 c          write (iout,*) (dc_norm(k,i),k=1,3)
2319 c          write (iout,*) (erij(k),k=1,3)
2320           call vec_and_deriv
2321           do k=1,3
2322             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2323             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2324             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2325             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2326           enddo
2327 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2328 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2329 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2330         enddo
2331         do k=1,3
2332           dc_norm(k,i)=erij(k)
2333         enddo
2334 cd        do k=1,3
2335 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2336 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2337 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2338 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2339 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2340 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2341 cd          write (iout,'(a)')
2342 cd        enddo
2343       enddo
2344       return
2345       end
2346 C--------------------------------------------------------------------------
2347       subroutine set_matrices
2348       implicit real*8 (a-h,o-z)
2349       include 'DIMENSIONS'
2350 #ifdef MPI
2351       include "mpif.h"
2352       include "COMMON.SETUP"
2353       integer IERR
2354       integer status(MPI_STATUS_SIZE)
2355 #endif
2356       include 'COMMON.IOUNITS'
2357       include 'COMMON.GEO'
2358       include 'COMMON.VAR'
2359       include 'COMMON.LOCAL'
2360       include 'COMMON.CHAIN'
2361       include 'COMMON.DERIV'
2362       include 'COMMON.INTERACT'
2363       include 'COMMON.CONTACTS'
2364       include 'COMMON.TORSION'
2365       include 'COMMON.VECTORS'
2366       include 'COMMON.FFIELD'
2367       double precision auxvec(2),auxmat(2,2)
2368 C
2369 C Compute the virtual-bond-torsional-angle dependent quantities needed
2370 C to calculate the el-loc multibody terms of various order.
2371 C
2372 #ifdef PARMAT
2373       do i=ivec_start+2,ivec_end+2
2374 #else
2375       do i=3,nres+1
2376 #endif
2377         if (i .lt. nres+1) then
2378           sin1=dsin(phi(i))
2379           cos1=dcos(phi(i))
2380           sintab(i-2)=sin1
2381           costab(i-2)=cos1
2382           obrot(1,i-2)=cos1
2383           obrot(2,i-2)=sin1
2384           sin2=dsin(2*phi(i))
2385           cos2=dcos(2*phi(i))
2386           sintab2(i-2)=sin2
2387           costab2(i-2)=cos2
2388           obrot2(1,i-2)=cos2
2389           obrot2(2,i-2)=sin2
2390           Ug(1,1,i-2)=-cos1
2391           Ug(1,2,i-2)=-sin1
2392           Ug(2,1,i-2)=-sin1
2393           Ug(2,2,i-2)= cos1
2394           Ug2(1,1,i-2)=-cos2
2395           Ug2(1,2,i-2)=-sin2
2396           Ug2(2,1,i-2)=-sin2
2397           Ug2(2,2,i-2)= cos2
2398         else
2399           costab(i-2)=1.0d0
2400           sintab(i-2)=0.0d0
2401           obrot(1,i-2)=1.0d0
2402           obrot(2,i-2)=0.0d0
2403           obrot2(1,i-2)=0.0d0
2404           obrot2(2,i-2)=0.0d0
2405           Ug(1,1,i-2)=1.0d0
2406           Ug(1,2,i-2)=0.0d0
2407           Ug(2,1,i-2)=0.0d0
2408           Ug(2,2,i-2)=1.0d0
2409           Ug2(1,1,i-2)=0.0d0
2410           Ug2(1,2,i-2)=0.0d0
2411           Ug2(2,1,i-2)=0.0d0
2412           Ug2(2,2,i-2)=0.0d0
2413         endif
2414         if (i .gt. 3 .and. i .lt. nres+1) then
2415           obrot_der(1,i-2)=-sin1
2416           obrot_der(2,i-2)= cos1
2417           Ugder(1,1,i-2)= sin1
2418           Ugder(1,2,i-2)=-cos1
2419           Ugder(2,1,i-2)=-cos1
2420           Ugder(2,2,i-2)=-sin1
2421           dwacos2=cos2+cos2
2422           dwasin2=sin2+sin2
2423           obrot2_der(1,i-2)=-dwasin2
2424           obrot2_der(2,i-2)= dwacos2
2425           Ug2der(1,1,i-2)= dwasin2
2426           Ug2der(1,2,i-2)=-dwacos2
2427           Ug2der(2,1,i-2)=-dwacos2
2428           Ug2der(2,2,i-2)=-dwasin2
2429         else
2430           obrot_der(1,i-2)=0.0d0
2431           obrot_der(2,i-2)=0.0d0
2432           Ugder(1,1,i-2)=0.0d0
2433           Ugder(1,2,i-2)=0.0d0
2434           Ugder(2,1,i-2)=0.0d0
2435           Ugder(2,2,i-2)=0.0d0
2436           obrot2_der(1,i-2)=0.0d0
2437           obrot2_der(2,i-2)=0.0d0
2438           Ug2der(1,1,i-2)=0.0d0
2439           Ug2der(1,2,i-2)=0.0d0
2440           Ug2der(2,1,i-2)=0.0d0
2441           Ug2der(2,2,i-2)=0.0d0
2442         endif
2443 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2444         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2445           iti = itortyp(itype(i-2))
2446         else
2447           iti=ntortyp+1
2448         endif
2449 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2450         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2451           iti1 = itortyp(itype(i-1))
2452         else
2453           iti1=ntortyp+1
2454         endif
2455 cd        write (iout,*) '*******i',i,' iti1',iti
2456 cd        write (iout,*) 'b1',b1(:,iti)
2457 cd        write (iout,*) 'b2',b2(:,iti)
2458 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2459 c        if (i .gt. iatel_s+2) then
2460         if (i .gt. nnt+2) then
2461           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2462           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2463           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2464      &    then
2465           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2466           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2467           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2468           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2469           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2470           endif
2471         else
2472           do k=1,2
2473             Ub2(k,i-2)=0.0d0
2474             Ctobr(k,i-2)=0.0d0
2475             Dtobr2(k,i-2)=0.0d0
2476             do l=1,2
2477               EUg(l,k,i-2)=0.0d0
2478               CUg(l,k,i-2)=0.0d0
2479               DUg(l,k,i-2)=0.0d0
2480               DtUg2(l,k,i-2)=0.0d0
2481             enddo
2482           enddo
2483         endif
2484         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2485         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2486         do k=1,2
2487           muder(k,i-2)=Ub2der(k,i-2)
2488         enddo
2489 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2490         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2491           iti1 = itortyp(itype(i-1))
2492         else
2493           iti1=ntortyp+1
2494         endif
2495         do k=1,2
2496           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2497         enddo
2498 cd        write (iout,*) 'mu ',mu(:,i-2)
2499 cd        write (iout,*) 'mu1',mu1(:,i-2)
2500 cd        write (iout,*) 'mu2',mu2(:,i-2)
2501         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2502      &  then
2503         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2504         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2505         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2506         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2507         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2508 C Vectors and matrices dependent on a single virtual-bond dihedral.
2509         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2510         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2511         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2512         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2513         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2514         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2515         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2516         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2517         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2518         endif
2519       enddo
2520 C Matrices dependent on two consecutive virtual-bond dihedrals.
2521 C The order of matrices is from left to right.
2522       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2523      &then
2524 c      do i=max0(ivec_start,2),ivec_end
2525       do i=2,nres-1
2526         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2527         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2528         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2529         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2530         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2531         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2532         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2533         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2534       enddo
2535       endif
2536 #if defined(MPI) && defined(PARMAT)
2537 #ifdef DEBUG
2538 c      if (fg_rank.eq.0) then
2539         write (iout,*) "Arrays UG and UGDER before GATHER"
2540         do i=1,nres-1
2541           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2542      &     ((ug(l,k,i),l=1,2),k=1,2),
2543      &     ((ugder(l,k,i),l=1,2),k=1,2)
2544         enddo
2545         write (iout,*) "Arrays UG2 and UG2DER"
2546         do i=1,nres-1
2547           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2548      &     ((ug2(l,k,i),l=1,2),k=1,2),
2549      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2550         enddo
2551         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2552         do i=1,nres-1
2553           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2554      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2555      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2556         enddo
2557         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2558         do i=1,nres-1
2559           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2560      &     costab(i),sintab(i),costab2(i),sintab2(i)
2561         enddo
2562         write (iout,*) "Array MUDER"
2563         do i=1,nres-1
2564           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2565         enddo
2566 c      endif
2567 #endif
2568       if (nfgtasks.gt.1) then
2569         time00=MPI_Wtime()
2570 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2571 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2572 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2573 #ifdef MATGATHER
2574         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2575      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2576      &   FG_COMM1,IERR)
2577         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2578      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2582      &   FG_COMM1,IERR)
2583         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2593      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2594      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2595         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2596      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2597      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2598         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2599      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2600      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2601         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2602      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2603      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2604         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2605      &  then
2606         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2614      &   FG_COMM1,IERR)
2615        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2622      &   ivec_count(fg_rank1),
2623      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2626      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2630      &   FG_COMM1,IERR)
2631         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2641      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2642      &   FG_COMM1,IERR)
2643         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2644      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2645      &   FG_COMM1,IERR)
2646         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2647      &   ivec_count(fg_rank1),
2648      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2649      &   FG_COMM1,IERR)
2650         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2651      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2652      &   FG_COMM1,IERR)
2653        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2654      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2655      &   FG_COMM1,IERR)
2656         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2657      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2658      &   FG_COMM1,IERR)
2659        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2660      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2661      &   FG_COMM1,IERR)
2662         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2663      &   ivec_count(fg_rank1),
2664      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2665      &   FG_COMM1,IERR)
2666         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2667      &   ivec_count(fg_rank1),
2668      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2669      &   FG_COMM1,IERR)
2670         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2671      &   ivec_count(fg_rank1),
2672      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2673      &   MPI_MAT2,FG_COMM1,IERR)
2674         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2675      &   ivec_count(fg_rank1),
2676      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2677      &   MPI_MAT2,FG_COMM1,IERR)
2678         endif
2679 #else
2680 c Passes matrix info through the ring
2681       isend=fg_rank1
2682       irecv=fg_rank1-1
2683       if (irecv.lt.0) irecv=nfgtasks1-1
2684       iprev=irecv
2685       inext=fg_rank1+1
2686       if (inext.ge.nfgtasks1) inext=0
2687       do i=1,nfgtasks1-1
2688 c        write (iout,*) "isend",isend," irecv",irecv
2689 c        call flush(iout)
2690         lensend=lentyp(isend)
2691         lenrecv=lentyp(irecv)
2692 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2693 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2694 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2695 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2696 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2697 c        write (iout,*) "Gather ROTAT1"
2698 c        call flush(iout)
2699 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2700 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2701 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2702 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2703 c        write (iout,*) "Gather ROTAT2"
2704 c        call flush(iout)
2705         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2706      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2707      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2708      &   iprev,4400+irecv,FG_COMM,status,IERR)
2709 c        write (iout,*) "Gather ROTAT_OLD"
2710 c        call flush(iout)
2711         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2712      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2713      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2714      &   iprev,5500+irecv,FG_COMM,status,IERR)
2715 c        write (iout,*) "Gather PRECOMP11"
2716 c        call flush(iout)
2717         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2718      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2719      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2720      &   iprev,6600+irecv,FG_COMM,status,IERR)
2721 c        write (iout,*) "Gather PRECOMP12"
2722 c        call flush(iout)
2723         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2724      &  then
2725         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2726      &   MPI_ROTAT2(lensend),inext,7700+isend,
2727      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2728      &   iprev,7700+irecv,FG_COMM,status,IERR)
2729 c        write (iout,*) "Gather PRECOMP21"
2730 c        call flush(iout)
2731         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2732      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2733      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2734      &   iprev,8800+irecv,FG_COMM,status,IERR)
2735 c        write (iout,*) "Gather PRECOMP22"
2736 c        call flush(iout)
2737         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2738      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2739      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2740      &   MPI_PRECOMP23(lenrecv),
2741      &   iprev,9900+irecv,FG_COMM,status,IERR)
2742 c        write (iout,*) "Gather PRECOMP23"
2743 c        call flush(iout)
2744         endif
2745         isend=irecv
2746         irecv=irecv-1
2747         if (irecv.lt.0) irecv=nfgtasks1-1
2748       enddo
2749 #endif
2750         time_gather=time_gather+MPI_Wtime()-time00
2751       endif
2752 #ifdef DEBUG
2753 c      if (fg_rank.eq.0) then
2754         write (iout,*) "Arrays UG and UGDER"
2755         do i=1,nres-1
2756           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2757      &     ((ug(l,k,i),l=1,2),k=1,2),
2758      &     ((ugder(l,k,i),l=1,2),k=1,2)
2759         enddo
2760         write (iout,*) "Arrays UG2 and UG2DER"
2761         do i=1,nres-1
2762           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2763      &     ((ug2(l,k,i),l=1,2),k=1,2),
2764      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2765         enddo
2766         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2767         do i=1,nres-1
2768           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2769      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2770      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2771         enddo
2772         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2773         do i=1,nres-1
2774           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2775      &     costab(i),sintab(i),costab2(i),sintab2(i)
2776         enddo
2777         write (iout,*) "Array MUDER"
2778         do i=1,nres-1
2779           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2780         enddo
2781 c      endif
2782 #endif
2783 #endif
2784 cd      do i=1,nres
2785 cd        iti = itortyp(itype(i))
2786 cd        write (iout,*) i
2787 cd        do j=1,2
2788 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2789 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2790 cd        enddo
2791 cd      enddo
2792       return
2793       end
2794 C--------------------------------------------------------------------------
2795       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2796 C
2797 C This subroutine calculates the average interaction energy and its gradient
2798 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2799 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2800 C The potential depends both on the distance of peptide-group centers and on
2801 C the orientation of the CA-CA virtual bonds.
2802 C
2803       implicit real*8 (a-h,o-z)
2804 #ifdef MPI
2805       include 'mpif.h'
2806 #endif
2807       include 'DIMENSIONS'
2808       include 'COMMON.CONTROL'
2809       include 'COMMON.SETUP'
2810       include 'COMMON.IOUNITS'
2811       include 'COMMON.GEO'
2812       include 'COMMON.VAR'
2813       include 'COMMON.LOCAL'
2814       include 'COMMON.CHAIN'
2815       include 'COMMON.DERIV'
2816       include 'COMMON.INTERACT'
2817       include 'COMMON.CONTACTS'
2818       include 'COMMON.TORSION'
2819       include 'COMMON.VECTORS'
2820       include 'COMMON.FFIELD'
2821       include 'COMMON.TIME1'
2822       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2823      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2824       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2825      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2826       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2827      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2828      &    num_conti,j1,j2
2829 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2830 #ifdef MOMENT
2831       double precision scal_el /1.0d0/
2832 #else
2833       double precision scal_el /0.5d0/
2834 #endif
2835 C 12/13/98
2836 C 13-go grudnia roku pamietnego...
2837       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2838      &                   0.0d0,1.0d0,0.0d0,
2839      &                   0.0d0,0.0d0,1.0d0/
2840 cd      write(iout,*) 'In EELEC'
2841 cd      do i=1,nloctyp
2842 cd        write(iout,*) 'Type',i
2843 cd        write(iout,*) 'B1',B1(:,i)
2844 cd        write(iout,*) 'B2',B2(:,i)
2845 cd        write(iout,*) 'CC',CC(:,:,i)
2846 cd        write(iout,*) 'DD',DD(:,:,i)
2847 cd        write(iout,*) 'EE',EE(:,:,i)
2848 cd      enddo
2849 cd      call check_vecgrad
2850 cd      stop
2851       if (icheckgrad.eq.1) then
2852         do i=1,nres-1
2853           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2854           do k=1,3
2855             dc_norm(k,i)=dc(k,i)*fac
2856           enddo
2857 c          write (iout,*) 'i',i,' fac',fac
2858         enddo
2859       endif
2860       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2861      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2862      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2863 c        call vec_and_deriv
2864 #ifdef TIMING
2865         time01=MPI_Wtime()
2866 #endif
2867         call set_matrices
2868 #ifdef TIMING
2869         time_mat=time_mat+MPI_Wtime()-time01
2870 #endif
2871       endif
2872 cd      do i=1,nres-1
2873 cd        write (iout,*) 'i=',i
2874 cd        do k=1,3
2875 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2876 cd        enddo
2877 cd        do k=1,3
2878 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2879 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2880 cd        enddo
2881 cd      enddo
2882       t_eelecij=0.0d0
2883       ees=0.0D0
2884       evdw1=0.0D0
2885       eel_loc=0.0d0
2886       eello_turn3=0.0d0
2887       eello_turn4=0.0d0
2888       ind=0
2889       do i=1,nres
2890         num_cont_hb(i)=0
2891       enddo
2892 cd      print '(a)','Enter EELEC'
2893 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2894       do i=1,nres
2895         gel_loc_loc(i)=0.0d0
2896         gcorr_loc(i)=0.0d0
2897       enddo
2898 c
2899 c
2900 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2901 C
2902 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2903 C
2904       do i=iturn3_start,iturn3_end
2905         dxi=dc(1,i)
2906         dyi=dc(2,i)
2907         dzi=dc(3,i)
2908         dx_normi=dc_norm(1,i)
2909         dy_normi=dc_norm(2,i)
2910         dz_normi=dc_norm(3,i)
2911         xmedi=c(1,i)+0.5d0*dxi
2912         ymedi=c(2,i)+0.5d0*dyi
2913         zmedi=c(3,i)+0.5d0*dzi
2914         num_conti=0
2915         call eelecij(i,i+2,ees,evdw1,eel_loc)
2916         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2917         num_cont_hb(i)=num_conti
2918       enddo
2919       do i=iturn4_start,iturn4_end
2920         dxi=dc(1,i)
2921         dyi=dc(2,i)
2922         dzi=dc(3,i)
2923         dx_normi=dc_norm(1,i)
2924         dy_normi=dc_norm(2,i)
2925         dz_normi=dc_norm(3,i)
2926         xmedi=c(1,i)+0.5d0*dxi
2927         ymedi=c(2,i)+0.5d0*dyi
2928         zmedi=c(3,i)+0.5d0*dzi
2929         num_conti=num_cont_hb(i)
2930         call eelecij(i,i+3,ees,evdw1,eel_loc)
2931         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2932         num_cont_hb(i)=num_conti
2933       enddo   ! i
2934 c
2935 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2936 c
2937       do i=iatel_s,iatel_e
2938         dxi=dc(1,i)
2939         dyi=dc(2,i)
2940         dzi=dc(3,i)
2941         dx_normi=dc_norm(1,i)
2942         dy_normi=dc_norm(2,i)
2943         dz_normi=dc_norm(3,i)
2944         xmedi=c(1,i)+0.5d0*dxi
2945         ymedi=c(2,i)+0.5d0*dyi
2946         zmedi=c(3,i)+0.5d0*dzi
2947 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2948         num_conti=num_cont_hb(i)
2949         do j=ielstart(i),ielend(i)
2950           call eelecij(i,j,ees,evdw1,eel_loc)
2951         enddo ! j
2952         num_cont_hb(i)=num_conti
2953       enddo   ! i
2954 c      write (iout,*) "Number of loop steps in EELEC:",ind
2955 cd      do i=1,nres
2956 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2957 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2958 cd      enddo
2959 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2960 ccc      eel_loc=eel_loc+eello_turn3
2961 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2962       return
2963       end
2964 C-------------------------------------------------------------------------------
2965       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2966       implicit real*8 (a-h,o-z)
2967       include 'DIMENSIONS'
2968 #ifdef MPI
2969       include "mpif.h"
2970 #endif
2971       include 'COMMON.CONTROL'
2972       include 'COMMON.IOUNITS'
2973       include 'COMMON.GEO'
2974       include 'COMMON.VAR'
2975       include 'COMMON.LOCAL'
2976       include 'COMMON.CHAIN'
2977       include 'COMMON.DERIV'
2978       include 'COMMON.INTERACT'
2979       include 'COMMON.CONTACTS'
2980       include 'COMMON.TORSION'
2981       include 'COMMON.VECTORS'
2982       include 'COMMON.FFIELD'
2983       include 'COMMON.TIME1'
2984       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2985      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2986       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2987      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2988       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2989      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2990      &    num_conti,j1,j2
2991 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2992 #ifdef MOMENT
2993       double precision scal_el /1.0d0/
2994 #else
2995       double precision scal_el /0.5d0/
2996 #endif
2997 C 12/13/98
2998 C 13-go grudnia roku pamietnego...
2999       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3000      &                   0.0d0,1.0d0,0.0d0,
3001      &                   0.0d0,0.0d0,1.0d0/
3002 c          time00=MPI_Wtime()
3003 cd      write (iout,*) "eelecij",i,j
3004 c          ind=ind+1
3005           iteli=itel(i)
3006           itelj=itel(j)
3007           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3008           aaa=app(iteli,itelj)
3009           bbb=bpp(iteli,itelj)
3010           ael6i=ael6(iteli,itelj)
3011           ael3i=ael3(iteli,itelj)
3012           dxj=dc(1,j)
3013           dyj=dc(2,j)
3014           dzj=dc(3,j)
3015           dx_normj=dc_norm(1,j)
3016           dy_normj=dc_norm(2,j)
3017           dz_normj=dc_norm(3,j)
3018           xj=c(1,j)+0.5D0*dxj-xmedi
3019           yj=c(2,j)+0.5D0*dyj-ymedi
3020           zj=c(3,j)+0.5D0*dzj-zmedi
3021           rij=xj*xj+yj*yj+zj*zj
3022           rrmij=1.0D0/rij
3023           rij=dsqrt(rij)
3024           rmij=1.0D0/rij
3025           r3ij=rrmij*rmij
3026           r6ij=r3ij*r3ij
3027           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3028           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3029           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3030           fac=cosa-3.0D0*cosb*cosg
3031           ev1=aaa*r6ij*r6ij
3032 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3033           if (j.eq.i+2) ev1=scal_el*ev1
3034           ev2=bbb*r6ij
3035           fac3=ael6i*r6ij
3036           fac4=ael3i*r3ij
3037           evdwij=ev1+ev2
3038           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3039           el2=fac4*fac
3040           eesij=el1+el2
3041 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3042           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3043           ees=ees+eesij
3044           evdw1=evdw1+evdwij
3045 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3046 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3047 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3048 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3049
3050           if (energy_dec) then
3051               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3052               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3053           endif
3054
3055 C
3056 C Calculate contributions to the Cartesian gradient.
3057 C
3058 #ifdef SPLITELE
3059           facvdw=-6*rrmij*(ev1+evdwij)
3060           facel=-3*rrmij*(el1+eesij)
3061           fac1=fac
3062           erij(1)=xj*rmij
3063           erij(2)=yj*rmij
3064           erij(3)=zj*rmij
3065 *
3066 * Radial derivatives. First process both termini of the fragment (i,j)
3067 *
3068           ggg(1)=facel*xj
3069           ggg(2)=facel*yj
3070           ggg(3)=facel*zj
3071 c          do k=1,3
3072 c            ghalf=0.5D0*ggg(k)
3073 c            gelc(k,i)=gelc(k,i)+ghalf
3074 c            gelc(k,j)=gelc(k,j)+ghalf
3075 c          enddo
3076 c 9/28/08 AL Gradient compotents will be summed only at the end
3077           do k=1,3
3078             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3079             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3080           enddo
3081 *
3082 * Loop over residues i+1 thru j-1.
3083 *
3084 cgrad          do k=i+1,j-1
3085 cgrad            do l=1,3
3086 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3087 cgrad            enddo
3088 cgrad          enddo
3089           ggg(1)=facvdw*xj
3090           ggg(2)=facvdw*yj
3091           ggg(3)=facvdw*zj
3092 c          do k=1,3
3093 c            ghalf=0.5D0*ggg(k)
3094 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3095 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3096 c          enddo
3097 c 9/28/08 AL Gradient compotents will be summed only at the end
3098           do k=1,3
3099             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3100             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3101           enddo
3102 *
3103 * Loop over residues i+1 thru j-1.
3104 *
3105 cgrad          do k=i+1,j-1
3106 cgrad            do l=1,3
3107 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3108 cgrad            enddo
3109 cgrad          enddo
3110 #else
3111           facvdw=ev1+evdwij
3112           facel=el1+eesij
3113           fac1=fac
3114           fac=-3*rrmij*(facvdw+facvdw+facel)
3115           erij(1)=xj*rmij
3116           erij(2)=yj*rmij
3117           erij(3)=zj*rmij
3118 *
3119 * Radial derivatives. First process both termini of the fragment (i,j)
3120 *
3121           ggg(1)=fac*xj
3122           ggg(2)=fac*yj
3123           ggg(3)=fac*zj
3124 c          do k=1,3
3125 c            ghalf=0.5D0*ggg(k)
3126 c            gelc(k,i)=gelc(k,i)+ghalf
3127 c            gelc(k,j)=gelc(k,j)+ghalf
3128 c          enddo
3129 c 9/28/08 AL Gradient compotents will be summed only at the end
3130           do k=1,3
3131             gelc_long(k,j)=gelc(k,j)+ggg(k)
3132             gelc_long(k,i)=gelc(k,i)-ggg(k)
3133           enddo
3134 *
3135 * Loop over residues i+1 thru j-1.
3136 *
3137 cgrad          do k=i+1,j-1
3138 cgrad            do l=1,3
3139 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3140 cgrad            enddo
3141 cgrad          enddo
3142 c 9/28/08 AL Gradient compotents will be summed only at the end
3143           ggg(1)=facvdw*xj
3144           ggg(2)=facvdw*yj
3145           ggg(3)=facvdw*zj
3146           do k=1,3
3147             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3148             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3149           enddo
3150 #endif
3151 *
3152 * Angular part
3153 *
3154           ecosa=2.0D0*fac3*fac1+fac4
3155           fac4=-3.0D0*fac4
3156           fac3=-6.0D0*fac3
3157           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3158           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3159           do k=1,3
3160             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3161             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3162           enddo
3163 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3164 cd   &          (dcosg(k),k=1,3)
3165           do k=1,3
3166             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3167           enddo
3168 c          do k=1,3
3169 c            ghalf=0.5D0*ggg(k)
3170 c            gelc(k,i)=gelc(k,i)+ghalf
3171 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3172 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3173 c            gelc(k,j)=gelc(k,j)+ghalf
3174 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3175 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3176 c          enddo
3177 cgrad          do k=i+1,j-1
3178 cgrad            do l=1,3
3179 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3180 cgrad            enddo
3181 cgrad          enddo
3182           do k=1,3
3183             gelc(k,i)=gelc(k,i)
3184      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3185      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3186             gelc(k,j)=gelc(k,j)
3187      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3188      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3193      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3194      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3195 C
3196 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3197 C   energy of a peptide unit is assumed in the form of a second-order
3198 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3199 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3200 C   are computed for EVERY pair of non-contiguous peptide groups.
3201 C
3202           if (j.lt.nres-1) then
3203             j1=j+1
3204             j2=j-1
3205           else
3206             j1=j-1
3207             j2=j-2
3208           endif
3209           kkk=0
3210           do k=1,2
3211             do l=1,2
3212               kkk=kkk+1
3213               muij(kkk)=mu(k,i)*mu(l,j)
3214             enddo
3215           enddo
3216 cd         write (iout,*) 'EELEC: i',i,' j',j
3217 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3218 cd          write(iout,*) 'muij',muij
3219           ury=scalar(uy(1,i),erij)
3220           urz=scalar(uz(1,i),erij)
3221           vry=scalar(uy(1,j),erij)
3222           vrz=scalar(uz(1,j),erij)
3223           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3224           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3225           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3226           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3227           fac=dsqrt(-ael6i)*r3ij
3228           a22=a22*fac
3229           a23=a23*fac
3230           a32=a32*fac
3231           a33=a33*fac
3232 cd          write (iout,'(4i5,4f10.5)')
3233 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3234 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3235 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3236 cd     &      uy(:,j),uz(:,j)
3237 cd          write (iout,'(4f10.5)')
3238 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3239 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3240 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3241 cd           write (iout,'(9f10.5/)')
3242 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3243 C Derivatives of the elements of A in virtual-bond vectors
3244           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3245           do k=1,3
3246             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3247             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3248             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3249             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3250             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3251             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3252             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3253             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3254             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3255             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3256             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3257             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3258           enddo
3259 C Compute radial contributions to the gradient
3260           facr=-3.0d0*rrmij
3261           a22der=a22*facr
3262           a23der=a23*facr
3263           a32der=a32*facr
3264           a33der=a33*facr
3265           agg(1,1)=a22der*xj
3266           agg(2,1)=a22der*yj
3267           agg(3,1)=a22der*zj
3268           agg(1,2)=a23der*xj
3269           agg(2,2)=a23der*yj
3270           agg(3,2)=a23der*zj
3271           agg(1,3)=a32der*xj
3272           agg(2,3)=a32der*yj
3273           agg(3,3)=a32der*zj
3274           agg(1,4)=a33der*xj
3275           agg(2,4)=a33der*yj
3276           agg(3,4)=a33der*zj
3277 C Add the contributions coming from er
3278           fac3=-3.0d0*fac
3279           do k=1,3
3280             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3281             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3282             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3283             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3284           enddo
3285           do k=1,3
3286 C Derivatives in DC(i)
3287 cgrad            ghalf1=0.5d0*agg(k,1)
3288 cgrad            ghalf2=0.5d0*agg(k,2)
3289 cgrad            ghalf3=0.5d0*agg(k,3)
3290 cgrad            ghalf4=0.5d0*agg(k,4)
3291             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3292      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3293             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3294      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3295             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3296      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3297             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3298      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3299 C Derivatives in DC(i+1)
3300             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3301      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3302             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3303      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3304             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3305      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3306             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3307      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3308 C Derivatives in DC(j)
3309             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3310      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3311             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3312      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3313             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3314      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3315             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3316      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3317 C Derivatives in DC(j+1) or DC(nres-1)
3318             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3319      &      -3.0d0*vryg(k,3)*ury)
3320             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3321      &      -3.0d0*vrzg(k,3)*ury)
3322             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3323      &      -3.0d0*vryg(k,3)*urz)
3324             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3325      &      -3.0d0*vrzg(k,3)*urz)
3326 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3327 cgrad              do l=1,4
3328 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3329 cgrad              enddo
3330 cgrad            endif
3331           enddo
3332           acipa(1,1)=a22
3333           acipa(1,2)=a23
3334           acipa(2,1)=a32
3335           acipa(2,2)=a33
3336           a22=-a22
3337           a23=-a23
3338           do l=1,2
3339             do k=1,3
3340               agg(k,l)=-agg(k,l)
3341               aggi(k,l)=-aggi(k,l)
3342               aggi1(k,l)=-aggi1(k,l)
3343               aggj(k,l)=-aggj(k,l)
3344               aggj1(k,l)=-aggj1(k,l)
3345             enddo
3346           enddo
3347           if (j.lt.nres-1) then
3348             a22=-a22
3349             a32=-a32
3350             do l=1,3,2
3351               do k=1,3
3352                 agg(k,l)=-agg(k,l)
3353                 aggi(k,l)=-aggi(k,l)
3354                 aggi1(k,l)=-aggi1(k,l)
3355                 aggj(k,l)=-aggj(k,l)
3356                 aggj1(k,l)=-aggj1(k,l)
3357               enddo
3358             enddo
3359           else
3360             a22=-a22
3361             a23=-a23
3362             a32=-a32
3363             a33=-a33
3364             do l=1,4
3365               do k=1,3
3366                 agg(k,l)=-agg(k,l)
3367                 aggi(k,l)=-aggi(k,l)
3368                 aggi1(k,l)=-aggi1(k,l)
3369                 aggj(k,l)=-aggj(k,l)
3370                 aggj1(k,l)=-aggj1(k,l)
3371               enddo
3372             enddo
3373           endif
3374           ENDIF ! WCORR
3375           IF (wel_loc.gt.0.0d0) THEN
3376 C Contribution to the local-electrostatic energy coming from the i-j pair
3377           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3378      &     +a33*muij(4)
3379 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3380
3381           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3382      &            'eelloc',i,j,eel_loc_ij
3383
3384           eel_loc=eel_loc+eel_loc_ij
3385 C Partial derivatives in virtual-bond dihedral angles gamma
3386           if (i.gt.1)
3387      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3388      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3389      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3390           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3391      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3392      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3393 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3394           do l=1,3
3395             ggg(l)=agg(l,1)*muij(1)+
3396      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3397             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3398             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3399 cgrad            ghalf=0.5d0*ggg(l)
3400 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3401 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3402           enddo
3403 cgrad          do k=i+1,j2
3404 cgrad            do l=1,3
3405 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3406 cgrad            enddo
3407 cgrad          enddo
3408 C Remaining derivatives of eello
3409           do l=1,3
3410             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3411      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3412             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3413      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3414             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3415      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3416             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3417      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3418           enddo
3419           ENDIF
3420 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3421 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3422           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3423      &       .and. num_conti.le.maxconts) then
3424 c            write (iout,*) i,j," entered corr"
3425 C
3426 C Calculate the contact function. The ith column of the array JCONT will
3427 C contain the numbers of atoms that make contacts with the atom I (of numbers
3428 C greater than I). The arrays FACONT and GACONT will contain the values of
3429 C the contact function and its derivative.
3430 c           r0ij=1.02D0*rpp(iteli,itelj)
3431 c           r0ij=1.11D0*rpp(iteli,itelj)
3432             r0ij=2.20D0*rpp(iteli,itelj)
3433 c           r0ij=1.55D0*rpp(iteli,itelj)
3434             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3435             if (fcont.gt.0.0D0) then
3436               num_conti=num_conti+1
3437               if (num_conti.gt.maxconts) then
3438                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3439      &                         ' will skip next contacts for this conf.'
3440               else
3441                 jcont_hb(num_conti,i)=j
3442 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3443 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3444                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3445      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3446 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3447 C  terms.
3448                 d_cont(num_conti,i)=rij
3449 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3450 C     --- Electrostatic-interaction matrix ---
3451                 a_chuj(1,1,num_conti,i)=a22
3452                 a_chuj(1,2,num_conti,i)=a23
3453                 a_chuj(2,1,num_conti,i)=a32
3454                 a_chuj(2,2,num_conti,i)=a33
3455 C     --- Gradient of rij
3456                 do kkk=1,3
3457                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3458                 enddo
3459                 kkll=0
3460                 do k=1,2
3461                   do l=1,2
3462                     kkll=kkll+1
3463                     do m=1,3
3464                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3465                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3466                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3467                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3468                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3469                     enddo
3470                   enddo
3471                 enddo
3472                 ENDIF
3473                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3474 C Calculate contact energies
3475                 cosa4=4.0D0*cosa
3476                 wij=cosa-3.0D0*cosb*cosg
3477                 cosbg1=cosb+cosg
3478                 cosbg2=cosb-cosg
3479 c               fac3=dsqrt(-ael6i)/r0ij**3
3480                 fac3=dsqrt(-ael6i)*r3ij
3481 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3482                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3483                 if (ees0tmp.gt.0) then
3484                   ees0pij=dsqrt(ees0tmp)
3485                 else
3486                   ees0pij=0
3487                 endif
3488 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3489                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3490                 if (ees0tmp.gt.0) then
3491                   ees0mij=dsqrt(ees0tmp)
3492                 else
3493                   ees0mij=0
3494                 endif
3495 c               ees0mij=0.0D0
3496                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3497                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3498 C Diagnostics. Comment out or remove after debugging!
3499 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3500 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3501 c               ees0m(num_conti,i)=0.0D0
3502 C End diagnostics.
3503 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3504 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3505 C Angular derivatives of the contact function
3506                 ees0pij1=fac3/ees0pij
3507                 ees0mij1=fac3/ees0mij
3508                 fac3p=-3.0D0*fac3*rrmij
3509                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3510                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3511 c               ees0mij1=0.0D0
3512                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3513                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3514                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3515                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3516                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3517                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3518                 ecosap=ecosa1+ecosa2
3519                 ecosbp=ecosb1+ecosb2
3520                 ecosgp=ecosg1+ecosg2
3521                 ecosam=ecosa1-ecosa2
3522                 ecosbm=ecosb1-ecosb2
3523                 ecosgm=ecosg1-ecosg2
3524 C Diagnostics
3525 c               ecosap=ecosa1
3526 c               ecosbp=ecosb1
3527 c               ecosgp=ecosg1
3528 c               ecosam=0.0D0
3529 c               ecosbm=0.0D0
3530 c               ecosgm=0.0D0
3531 C End diagnostics
3532                 facont_hb(num_conti,i)=fcont
3533                 fprimcont=fprimcont/rij
3534 cd              facont_hb(num_conti,i)=1.0D0
3535 C Following line is for diagnostics.
3536 cd              fprimcont=0.0D0
3537                 do k=1,3
3538                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3539                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3540                 enddo
3541                 do k=1,3
3542                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3543                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3544                 enddo
3545                 gggp(1)=gggp(1)+ees0pijp*xj
3546                 gggp(2)=gggp(2)+ees0pijp*yj
3547                 gggp(3)=gggp(3)+ees0pijp*zj
3548                 gggm(1)=gggm(1)+ees0mijp*xj
3549                 gggm(2)=gggm(2)+ees0mijp*yj
3550                 gggm(3)=gggm(3)+ees0mijp*zj
3551 C Derivatives due to the contact function
3552                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3553                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3554                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3555                 do k=1,3
3556 c
3557 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3558 c          following the change of gradient-summation algorithm.
3559 c
3560 cgrad                  ghalfp=0.5D0*gggp(k)
3561 cgrad                  ghalfm=0.5D0*gggm(k)
3562                   gacontp_hb1(k,num_conti,i)=!ghalfp
3563      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3564      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3565                   gacontp_hb2(k,num_conti,i)=!ghalfp
3566      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3567      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3568                   gacontp_hb3(k,num_conti,i)=gggp(k)
3569                   gacontm_hb1(k,num_conti,i)=!ghalfm
3570      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3571      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3572                   gacontm_hb2(k,num_conti,i)=!ghalfm
3573      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3574      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3575                   gacontm_hb3(k,num_conti,i)=gggm(k)
3576                 enddo
3577 C Diagnostics. Comment out or remove after debugging!
3578 cdiag           do k=1,3
3579 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3580 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3581 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3582 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3583 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3584 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3585 cdiag           enddo
3586               ENDIF ! wcorr
3587               endif  ! num_conti.le.maxconts
3588             endif  ! fcont.gt.0
3589           endif    ! j.gt.i+1
3590           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3591             do k=1,4
3592               do l=1,3
3593                 ghalf=0.5d0*agg(l,k)
3594                 aggi(l,k)=aggi(l,k)+ghalf
3595                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3596                 aggj(l,k)=aggj(l,k)+ghalf
3597               enddo
3598             enddo
3599             if (j.eq.nres-1 .and. i.lt.j-2) then
3600               do k=1,4
3601                 do l=1,3
3602                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3603                 enddo
3604               enddo
3605             endif
3606           endif
3607 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3608       return
3609       end
3610 C-----------------------------------------------------------------------------
3611       subroutine eturn3(i,eello_turn3)
3612 C Third- and fourth-order contributions from turns
3613       implicit real*8 (a-h,o-z)
3614       include 'DIMENSIONS'
3615       include 'COMMON.IOUNITS'
3616       include 'COMMON.GEO'
3617       include 'COMMON.VAR'
3618       include 'COMMON.LOCAL'
3619       include 'COMMON.CHAIN'
3620       include 'COMMON.DERIV'
3621       include 'COMMON.INTERACT'
3622       include 'COMMON.CONTACTS'
3623       include 'COMMON.TORSION'
3624       include 'COMMON.VECTORS'
3625       include 'COMMON.FFIELD'
3626       include 'COMMON.CONTROL'
3627       dimension ggg(3)
3628       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3629      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3630      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3631       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3632      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3633       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3634      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3635      &    num_conti,j1,j2
3636       j=i+2
3637 c      write (iout,*) "eturn3",i,j,j1,j2
3638       a_temp(1,1)=a22
3639       a_temp(1,2)=a23
3640       a_temp(2,1)=a32
3641       a_temp(2,2)=a33
3642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3643 C
3644 C               Third-order contributions
3645 C
3646 C                 (i+2)o----(i+3)
3647 C                      | |
3648 C                      | |
3649 C                 (i+1)o----i
3650 C
3651 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3652 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3653         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3654         call transpose2(auxmat(1,1),auxmat1(1,1))
3655         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3656         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3657         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3658      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3659 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3660 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3661 cd     &    ' eello_turn3_num',4*eello_turn3_num
3662 C Derivatives in gamma(i)
3663         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3664         call transpose2(auxmat2(1,1),auxmat3(1,1))
3665         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3666         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3667 C Derivatives in gamma(i+1)
3668         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3669         call transpose2(auxmat2(1,1),auxmat3(1,1))
3670         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3671         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3672      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3673 C Cartesian derivatives
3674         do l=1,3
3675 c            ghalf1=0.5d0*agg(l,1)
3676 c            ghalf2=0.5d0*agg(l,2)
3677 c            ghalf3=0.5d0*agg(l,3)
3678 c            ghalf4=0.5d0*agg(l,4)
3679           a_temp(1,1)=aggi(l,1)!+ghalf1
3680           a_temp(1,2)=aggi(l,2)!+ghalf2
3681           a_temp(2,1)=aggi(l,3)!+ghalf3
3682           a_temp(2,2)=aggi(l,4)!+ghalf4
3683           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3684           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3685      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3686           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3687           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3688           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3689           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3690           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3691           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3692      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3693           a_temp(1,1)=aggj(l,1)!+ghalf1
3694           a_temp(1,2)=aggj(l,2)!+ghalf2
3695           a_temp(2,1)=aggj(l,3)!+ghalf3
3696           a_temp(2,2)=aggj(l,4)!+ghalf4
3697           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3698           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3699      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3700           a_temp(1,1)=aggj1(l,1)
3701           a_temp(1,2)=aggj1(l,2)
3702           a_temp(2,1)=aggj1(l,3)
3703           a_temp(2,2)=aggj1(l,4)
3704           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3705           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3706      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3707         enddo
3708       return
3709       end
3710 C-------------------------------------------------------------------------------
3711       subroutine eturn4(i,eello_turn4)
3712 C Third- and fourth-order contributions from turns
3713       implicit real*8 (a-h,o-z)
3714       include 'DIMENSIONS'
3715       include 'COMMON.IOUNITS'
3716       include 'COMMON.GEO'
3717       include 'COMMON.VAR'
3718       include 'COMMON.LOCAL'
3719       include 'COMMON.CHAIN'
3720       include 'COMMON.DERIV'
3721       include 'COMMON.INTERACT'
3722       include 'COMMON.CONTACTS'
3723       include 'COMMON.TORSION'
3724       include 'COMMON.VECTORS'
3725       include 'COMMON.FFIELD'
3726       include 'COMMON.CONTROL'
3727       dimension ggg(3)
3728       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3729      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3730      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3731       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3732      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3733       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3734      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3735      &    num_conti,j1,j2
3736       j=i+3
3737 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3738 C
3739 C               Fourth-order contributions
3740 C
3741 C                 (i+3)o----(i+4)
3742 C                     /  |
3743 C               (i+2)o   |
3744 C                     \  |
3745 C                 (i+1)o----i
3746 C
3747 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3748 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3749 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3750         a_temp(1,1)=a22
3751         a_temp(1,2)=a23
3752         a_temp(2,1)=a32
3753         a_temp(2,2)=a33
3754         iti1=itortyp(itype(i+1))
3755         iti2=itortyp(itype(i+2))
3756         iti3=itortyp(itype(i+3))
3757 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3758         call transpose2(EUg(1,1,i+1),e1t(1,1))
3759         call transpose2(Eug(1,1,i+2),e2t(1,1))
3760         call transpose2(Eug(1,1,i+3),e3t(1,1))
3761         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3762         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3763         s1=scalar2(b1(1,iti2),auxvec(1))
3764         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3765         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3766         s2=scalar2(b1(1,iti1),auxvec(1))
3767         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3768         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3769         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3770         eello_turn4=eello_turn4-(s1+s2+s3)
3771         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3772      &      'eturn4',i,j,-(s1+s2+s3)
3773 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3774 cd     &    ' eello_turn4_num',8*eello_turn4_num
3775 C Derivatives in gamma(i)
3776         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3777         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3778         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3779         s1=scalar2(b1(1,iti2),auxvec(1))
3780         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3781         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3782         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3783 C Derivatives in gamma(i+1)
3784         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3785         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3786         s2=scalar2(b1(1,iti1),auxvec(1))
3787         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3788         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3789         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3790         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3791 C Derivatives in gamma(i+2)
3792         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3793         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3794         s1=scalar2(b1(1,iti2),auxvec(1))
3795         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3796         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3797         s2=scalar2(b1(1,iti1),auxvec(1))
3798         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3799         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3800         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3801         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3802 C Cartesian derivatives
3803 C Derivatives of this turn contributions in DC(i+2)
3804         if (j.lt.nres-1) then
3805           do l=1,3
3806             a_temp(1,1)=agg(l,1)
3807             a_temp(1,2)=agg(l,2)
3808             a_temp(2,1)=agg(l,3)
3809             a_temp(2,2)=agg(l,4)
3810             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3811             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3812             s1=scalar2(b1(1,iti2),auxvec(1))
3813             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3814             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3815             s2=scalar2(b1(1,iti1),auxvec(1))
3816             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3817             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3818             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3819             ggg(l)=-(s1+s2+s3)
3820             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3821           enddo
3822         endif
3823 C Remaining derivatives of this turn contribution
3824         do l=1,3
3825           a_temp(1,1)=aggi(l,1)
3826           a_temp(1,2)=aggi(l,2)
3827           a_temp(2,1)=aggi(l,3)
3828           a_temp(2,2)=aggi(l,4)
3829           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3830           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3831           s1=scalar2(b1(1,iti2),auxvec(1))
3832           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3833           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3834           s2=scalar2(b1(1,iti1),auxvec(1))
3835           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3836           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3837           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3838           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3839           a_temp(1,1)=aggi1(l,1)
3840           a_temp(1,2)=aggi1(l,2)
3841           a_temp(2,1)=aggi1(l,3)
3842           a_temp(2,2)=aggi1(l,4)
3843           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3844           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3845           s1=scalar2(b1(1,iti2),auxvec(1))
3846           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3847           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3848           s2=scalar2(b1(1,iti1),auxvec(1))
3849           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3850           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3851           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3852           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3853           a_temp(1,1)=aggj(l,1)
3854           a_temp(1,2)=aggj(l,2)
3855           a_temp(2,1)=aggj(l,3)
3856           a_temp(2,2)=aggj(l,4)
3857           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3858           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3859           s1=scalar2(b1(1,iti2),auxvec(1))
3860           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3861           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3862           s2=scalar2(b1(1,iti1),auxvec(1))
3863           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3864           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3865           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3867           a_temp(1,1)=aggj1(l,1)
3868           a_temp(1,2)=aggj1(l,2)
3869           a_temp(2,1)=aggj1(l,3)
3870           a_temp(2,2)=aggj1(l,4)
3871           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3872           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3873           s1=scalar2(b1(1,iti2),auxvec(1))
3874           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3875           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3876           s2=scalar2(b1(1,iti1),auxvec(1))
3877           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3878           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3879           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3880 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3881           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3882         enddo
3883       return
3884       end
3885 C-----------------------------------------------------------------------------
3886       subroutine vecpr(u,v,w)
3887       implicit real*8(a-h,o-z)
3888       dimension u(3),v(3),w(3)
3889       w(1)=u(2)*v(3)-u(3)*v(2)
3890       w(2)=-u(1)*v(3)+u(3)*v(1)
3891       w(3)=u(1)*v(2)-u(2)*v(1)
3892       return
3893       end
3894 C-----------------------------------------------------------------------------
3895       subroutine unormderiv(u,ugrad,unorm,ungrad)
3896 C This subroutine computes the derivatives of a normalized vector u, given
3897 C the derivatives computed without normalization conditions, ugrad. Returns
3898 C ungrad.
3899       implicit none
3900       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3901       double precision vec(3)
3902       double precision scalar
3903       integer i,j
3904 c      write (2,*) 'ugrad',ugrad
3905 c      write (2,*) 'u',u
3906       do i=1,3
3907         vec(i)=scalar(ugrad(1,i),u(1))
3908       enddo
3909 c      write (2,*) 'vec',vec
3910       do i=1,3
3911         do j=1,3
3912           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3913         enddo
3914       enddo
3915 c      write (2,*) 'ungrad',ungrad
3916       return
3917       end
3918 C-----------------------------------------------------------------------------
3919       subroutine escp_soft_sphere(evdw2,evdw2_14)
3920 C
3921 C This subroutine calculates the excluded-volume interaction energy between
3922 C peptide-group centers and side chains and its gradient in virtual-bond and
3923 C side-chain vectors.
3924 C
3925       implicit real*8 (a-h,o-z)
3926       include 'DIMENSIONS'
3927       include 'COMMON.GEO'
3928       include 'COMMON.VAR'
3929       include 'COMMON.LOCAL'
3930       include 'COMMON.CHAIN'
3931       include 'COMMON.DERIV'
3932       include 'COMMON.INTERACT'
3933       include 'COMMON.FFIELD'
3934       include 'COMMON.IOUNITS'
3935       include 'COMMON.CONTROL'
3936       dimension ggg(3)
3937       evdw2=0.0D0
3938       evdw2_14=0.0d0
3939       r0_scp=4.5d0
3940 cd    print '(a)','Enter ESCP'
3941 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3942       do i=iatscp_s,iatscp_e
3943         iteli=itel(i)
3944         xi=0.5D0*(c(1,i)+c(1,i+1))
3945         yi=0.5D0*(c(2,i)+c(2,i+1))
3946         zi=0.5D0*(c(3,i)+c(3,i+1))
3947
3948         do iint=1,nscp_gr(i)
3949
3950         do j=iscpstart(i,iint),iscpend(i,iint)
3951           itypj=itype(j)
3952 C Uncomment following three lines for SC-p interactions
3953 c         xj=c(1,nres+j)-xi
3954 c         yj=c(2,nres+j)-yi
3955 c         zj=c(3,nres+j)-zi
3956 C Uncomment following three lines for Ca-p interactions
3957           xj=c(1,j)-xi
3958           yj=c(2,j)-yi
3959           zj=c(3,j)-zi
3960           rij=xj*xj+yj*yj+zj*zj
3961           r0ij=r0_scp
3962           r0ijsq=r0ij*r0ij
3963           if (rij.lt.r0ijsq) then
3964             evdwij=0.25d0*(rij-r0ijsq)**2
3965             fac=rij-r0ijsq
3966           else
3967             evdwij=0.0d0
3968             fac=0.0d0
3969           endif
3970           evdw2=evdw2+evdwij
3971 C
3972 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3973 C
3974           ggg(1)=xj*fac
3975           ggg(2)=yj*fac
3976           ggg(3)=zj*fac
3977 cgrad          if (j.lt.i) then
3978 cd          write (iout,*) 'j<i'
3979 C Uncomment following three lines for SC-p interactions
3980 c           do k=1,3
3981 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3982 c           enddo
3983 cgrad          else
3984 cd          write (iout,*) 'j>i'
3985 cgrad            do k=1,3
3986 cgrad              ggg(k)=-ggg(k)
3987 C Uncomment following line for SC-p interactions
3988 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3989 cgrad            enddo
3990 cgrad          endif
3991 cgrad          do k=1,3
3992 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3993 cgrad          enddo
3994 cgrad          kstart=min0(i+1,j)
3995 cgrad          kend=max0(i-1,j-1)
3996 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3997 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3998 cgrad          do k=kstart,kend
3999 cgrad            do l=1,3
4000 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4001 cgrad            enddo
4002 cgrad          enddo
4003           do k=1,3
4004             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4005             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4006           enddo
4007         enddo
4008
4009         enddo ! iint
4010       enddo ! i
4011       return
4012       end
4013 C-----------------------------------------------------------------------------
4014       subroutine escp(evdw2,evdw2_14)
4015 C
4016 C This subroutine calculates the excluded-volume interaction energy between
4017 C peptide-group centers and side chains and its gradient in virtual-bond and
4018 C side-chain vectors.
4019 C
4020       implicit real*8 (a-h,o-z)
4021       include 'DIMENSIONS'
4022       include 'COMMON.GEO'
4023       include 'COMMON.VAR'
4024       include 'COMMON.LOCAL'
4025       include 'COMMON.CHAIN'
4026       include 'COMMON.DERIV'
4027       include 'COMMON.INTERACT'
4028       include 'COMMON.FFIELD'
4029       include 'COMMON.IOUNITS'
4030       include 'COMMON.CONTROL'
4031       dimension ggg(3)
4032       evdw2=0.0D0
4033       evdw2_14=0.0d0
4034 cd    print '(a)','Enter ESCP'
4035 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4036       do i=iatscp_s,iatscp_e
4037         iteli=itel(i)
4038         xi=0.5D0*(c(1,i)+c(1,i+1))
4039         yi=0.5D0*(c(2,i)+c(2,i+1))
4040         zi=0.5D0*(c(3,i)+c(3,i+1))
4041
4042         do iint=1,nscp_gr(i)
4043
4044         do j=iscpstart(i,iint),iscpend(i,iint)
4045           itypj=itype(j)
4046 C Uncomment following three lines for SC-p interactions
4047 c         xj=c(1,nres+j)-xi
4048 c         yj=c(2,nres+j)-yi
4049 c         zj=c(3,nres+j)-zi
4050 C Uncomment following three lines for Ca-p interactions
4051           xj=c(1,j)-xi
4052           yj=c(2,j)-yi
4053           zj=c(3,j)-zi
4054           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4055           fac=rrij**expon2
4056           e1=fac*fac*aad(itypj,iteli)
4057           e2=fac*bad(itypj,iteli)
4058           if (iabs(j-i) .le. 2) then
4059             e1=scal14*e1
4060             e2=scal14*e2
4061             evdw2_14=evdw2_14+e1+e2
4062           endif
4063           evdwij=e1+e2
4064           evdw2=evdw2+evdwij
4065           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4066      &        'evdw2',i,j,evdwij
4067 C
4068 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4069 C
4070           fac=-(evdwij+e1)*rrij
4071           ggg(1)=xj*fac
4072           ggg(2)=yj*fac
4073           ggg(3)=zj*fac
4074 cgrad          if (j.lt.i) then
4075 cd          write (iout,*) 'j<i'
4076 C Uncomment following three lines for SC-p interactions
4077 c           do k=1,3
4078 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4079 c           enddo
4080 cgrad          else
4081 cd          write (iout,*) 'j>i'
4082 cgrad            do k=1,3
4083 cgrad              ggg(k)=-ggg(k)
4084 C Uncomment following line for SC-p interactions
4085 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4086 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4087 cgrad            enddo
4088 cgrad          endif
4089 cgrad          do k=1,3
4090 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4091 cgrad          enddo
4092 cgrad          kstart=min0(i+1,j)
4093 cgrad          kend=max0(i-1,j-1)
4094 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4095 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4096 cgrad          do k=kstart,kend
4097 cgrad            do l=1,3
4098 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4099 cgrad            enddo
4100 cgrad          enddo
4101           do k=1,3
4102             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4103             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4104           enddo
4105         enddo
4106
4107         enddo ! iint
4108       enddo ! i
4109       do i=1,nct
4110         do j=1,3
4111           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4112           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4113           gradx_scp(j,i)=expon*gradx_scp(j,i)
4114         enddo
4115       enddo
4116 C******************************************************************************
4117 C
4118 C                              N O T E !!!
4119 C
4120 C To save time the factor EXPON has been extracted from ALL components
4121 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4122 C use!
4123 C
4124 C******************************************************************************
4125       return
4126       end
4127 C--------------------------------------------------------------------------
4128       subroutine edis(ehpb)
4129 C
4130 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4131 C
4132       implicit real*8 (a-h,o-z)
4133       include 'DIMENSIONS'
4134       include 'COMMON.SBRIDGE'
4135       include 'COMMON.CHAIN'
4136       include 'COMMON.DERIV'
4137       include 'COMMON.VAR'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.IOUNITS'
4140       dimension ggg(3)
4141       ehpb=0.0D0
4142 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4143 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4144       if (link_end.eq.0) return
4145       do i=link_start,link_end
4146 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4147 C CA-CA distance used in regularization of structure.
4148         ii=ihpb(i)
4149         jj=jhpb(i)
4150 C iii and jjj point to the residues for which the distance is assigned.
4151         if (ii.gt.nres) then
4152           iii=ii-nres
4153           jjj=jj-nres
4154         else
4155           iii=ii
4156           jjj=jj
4157         endif
4158 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4159 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4160 C    distance and angle dependent SS bond potential.
4161         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4162           call ssbond_ene(iii,jjj,eij)
4163           ehpb=ehpb+2*eij
4164 cd          write (iout,*) "eij",eij
4165         else
4166 C Calculate the distance between the two points and its difference from the
4167 C target distance.
4168         dd=dist(ii,jj)
4169         rdis=dd-dhpb(i)
4170 C Get the force constant corresponding to this distance.
4171         waga=forcon(i)
4172 C Calculate the contribution to energy.
4173         ehpb=ehpb+waga*rdis*rdis
4174 C
4175 C Evaluate gradient.
4176 C
4177         fac=waga*rdis/dd
4178 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4179 cd   &   ' waga=',waga,' fac=',fac
4180         do j=1,3
4181           ggg(j)=fac*(c(j,jj)-c(j,ii))
4182         enddo
4183 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4184 C If this is a SC-SC distance, we need to calculate the contributions to the
4185 C Cartesian gradient in the SC vectors (ghpbx).
4186         if (iii.lt.ii) then
4187           do j=1,3
4188             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4189             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4190           enddo
4191         endif
4192 cgrad        do j=iii,jjj-1
4193 cgrad          do k=1,3
4194 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4195 cgrad          enddo
4196 cgrad        enddo
4197         do k=1,3
4198           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4199           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4200         enddo
4201         endif
4202       enddo
4203       ehpb=0.5D0*ehpb
4204       return
4205       end
4206 C--------------------------------------------------------------------------
4207       subroutine ssbond_ene(i,j,eij)
4208 C
4209 C Calculate the distance and angle dependent SS-bond potential energy
4210 C using a free-energy function derived based on RHF/6-31G** ab initio
4211 C calculations of diethyl disulfide.
4212 C
4213 C A. Liwo and U. Kozlowska, 11/24/03
4214 C
4215       implicit real*8 (a-h,o-z)
4216       include 'DIMENSIONS'
4217       include 'COMMON.SBRIDGE'
4218       include 'COMMON.CHAIN'
4219       include 'COMMON.DERIV'
4220       include 'COMMON.LOCAL'
4221       include 'COMMON.INTERACT'
4222       include 'COMMON.VAR'
4223       include 'COMMON.IOUNITS'
4224       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4225       itypi=itype(i)
4226       xi=c(1,nres+i)
4227       yi=c(2,nres+i)
4228       zi=c(3,nres+i)
4229       dxi=dc_norm(1,nres+i)
4230       dyi=dc_norm(2,nres+i)
4231       dzi=dc_norm(3,nres+i)
4232 c      dsci_inv=dsc_inv(itypi)
4233       dsci_inv=vbld_inv(nres+i)
4234       itypj=itype(j)
4235 c      dscj_inv=dsc_inv(itypj)
4236       dscj_inv=vbld_inv(nres+j)
4237       xj=c(1,nres+j)-xi
4238       yj=c(2,nres+j)-yi
4239       zj=c(3,nres+j)-zi
4240       dxj=dc_norm(1,nres+j)
4241       dyj=dc_norm(2,nres+j)
4242       dzj=dc_norm(3,nres+j)
4243       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4244       rij=dsqrt(rrij)
4245       erij(1)=xj*rij
4246       erij(2)=yj*rij
4247       erij(3)=zj*rij
4248       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4249       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4250       om12=dxi*dxj+dyi*dyj+dzi*dzj
4251       do k=1,3
4252         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4253         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4254       enddo
4255       rij=1.0d0/rij
4256       deltad=rij-d0cm
4257       deltat1=1.0d0-om1
4258       deltat2=1.0d0+om2
4259       deltat12=om2-om1+2.0d0
4260       cosphi=om12-om1*om2
4261       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4262      &  +akct*deltad*deltat12
4263      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4264 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4265 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4266 c     &  " deltat12",deltat12," eij",eij
4267       ed=2*akcm*deltad+akct*deltat12
4268       pom1=akct*deltad
4269       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4270       eom1=-2*akth*deltat1-pom1-om2*pom2
4271       eom2= 2*akth*deltat2+pom1-om1*pom2
4272       eom12=pom2
4273       do k=1,3
4274         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4275         ghpbx(k,i)=ghpbx(k,i)-ggk
4276      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4277      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4278         ghpbx(k,j)=ghpbx(k,j)+ggk
4279      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4280      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4281         ghpbc(k,i)=ghpbc(k,i)-ggk
4282         ghpbc(k,j)=ghpbc(k,j)+ggk
4283       enddo
4284 C
4285 C Calculate the components of the gradient in DC and X
4286 C
4287 cgrad      do k=i,j-1
4288 cgrad        do l=1,3
4289 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4290 cgrad        enddo
4291 cgrad      enddo
4292       return
4293       end
4294 C--------------------------------------------------------------------------
4295       subroutine ebond(estr)
4296 c
4297 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4298 c
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.LOCAL'
4302       include 'COMMON.GEO'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.VAR'
4306       include 'COMMON.CHAIN'
4307       include 'COMMON.IOUNITS'
4308       include 'COMMON.NAMES'
4309       include 'COMMON.FFIELD'
4310       include 'COMMON.CONTROL'
4311       include 'COMMON.SETUP'
4312       double precision u(3),ud(3)
4313       estr=0.0d0
4314       do i=ibondp_start,ibondp_end
4315         diff = vbld(i)-vbldp0
4316 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4317         estr=estr+diff*diff
4318         do j=1,3
4319           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4320         enddo
4321 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4322       enddo
4323       estr=0.5d0*AKP*estr
4324 c
4325 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4326 c
4327       do i=ibond_start,ibond_end
4328         iti=itype(i)
4329         if (iti.ne.10) then
4330           nbi=nbondterm(iti)
4331           if (nbi.eq.1) then
4332             diff=vbld(i+nres)-vbldsc0(1,iti)
4333 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4334 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4335             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4336             do j=1,3
4337               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4338             enddo
4339           else
4340             do j=1,nbi
4341               diff=vbld(i+nres)-vbldsc0(j,iti)
4342               ud(j)=aksc(j,iti)*diff
4343               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4344             enddo
4345             uprod=u(1)
4346             do j=2,nbi
4347               uprod=uprod*u(j)
4348             enddo
4349             usum=0.0d0
4350             usumsqder=0.0d0
4351             do j=1,nbi
4352               uprod1=1.0d0
4353               uprod2=1.0d0
4354               do k=1,nbi
4355                 if (k.ne.j) then
4356                   uprod1=uprod1*u(k)
4357                   uprod2=uprod2*u(k)*u(k)
4358                 endif
4359               enddo
4360               usum=usum+uprod1
4361               usumsqder=usumsqder+ud(j)*uprod2
4362             enddo
4363             estr=estr+uprod/usum
4364             do j=1,3
4365              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4366             enddo
4367           endif
4368         endif
4369       enddo
4370       return
4371       end
4372 #ifdef CRYST_THETA
4373 C--------------------------------------------------------------------------
4374       subroutine ebend(etheta)
4375 C
4376 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4377 C angles gamma and its derivatives in consecutive thetas and gammas.
4378 C
4379       implicit real*8 (a-h,o-z)
4380       include 'DIMENSIONS'
4381       include 'COMMON.LOCAL'
4382       include 'COMMON.GEO'
4383       include 'COMMON.INTERACT'
4384       include 'COMMON.DERIV'
4385       include 'COMMON.VAR'
4386       include 'COMMON.CHAIN'
4387       include 'COMMON.IOUNITS'
4388       include 'COMMON.NAMES'
4389       include 'COMMON.FFIELD'
4390       include 'COMMON.CONTROL'
4391       common /calcthet/ term1,term2,termm,diffak,ratak,
4392      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4393      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4394       double precision y(2),z(2)
4395       delta=0.02d0*pi
4396 c      time11=dexp(-2*time)
4397 c      time12=1.0d0
4398       etheta=0.0D0
4399 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4400       do i=ithet_start,ithet_end
4401 C Zero the energy function and its derivative at 0 or pi.
4402         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4403         it=itype(i-1)
4404         if (i.gt.3) then
4405 #ifdef OSF
4406           phii=phi(i)
4407           if (phii.ne.phii) phii=150.0
4408 #else
4409           phii=phi(i)
4410 #endif
4411           y(1)=dcos(phii)
4412           y(2)=dsin(phii)
4413         else
4414           y(1)=0.0D0
4415           y(2)=0.0D0
4416         endif
4417         if (i.lt.nres) then
4418 #ifdef OSF
4419           phii1=phi(i+1)
4420           if (phii1.ne.phii1) phii1=150.0
4421           phii1=pinorm(phii1)
4422           z(1)=cos(phii1)
4423 #else
4424           phii1=phi(i+1)
4425           z(1)=dcos(phii1)
4426 #endif
4427           z(2)=dsin(phii1)
4428         else
4429           z(1)=0.0D0
4430           z(2)=0.0D0
4431         endif
4432 C Calculate the "mean" value of theta from the part of the distribution
4433 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4434 C In following comments this theta will be referred to as t_c.
4435         thet_pred_mean=0.0d0
4436         do k=1,2
4437           athetk=athet(k,it)
4438           bthetk=bthet(k,it)
4439           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4440         enddo
4441         dthett=thet_pred_mean*ssd
4442         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4443 C Derivatives of the "mean" values in gamma1 and gamma2.
4444         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4445         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4446         if (theta(i).gt.pi-delta) then
4447           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4448      &         E_tc0)
4449           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4450           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4451           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4452      &        E_theta)
4453           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4454      &        E_tc)
4455         else if (theta(i).lt.delta) then
4456           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4457           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4458           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4459      &        E_theta)
4460           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4461           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4462      &        E_tc)
4463         else
4464           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4465      &        E_theta,E_tc)
4466         endif
4467         etheta=etheta+ethetai
4468         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4469      &      'ebend',i,ethetai
4470         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4471         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4472         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4473       enddo
4474 C Ufff.... We've done all this!!!
4475       return
4476       end
4477 C---------------------------------------------------------------------------
4478       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4479      &     E_tc)
4480       implicit real*8 (a-h,o-z)
4481       include 'DIMENSIONS'
4482       include 'COMMON.LOCAL'
4483       include 'COMMON.IOUNITS'
4484       common /calcthet/ term1,term2,termm,diffak,ratak,
4485      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4486      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4487 C Calculate the contributions to both Gaussian lobes.
4488 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4489 C The "polynomial part" of the "standard deviation" of this part of
4490 C the distribution.
4491         sig=polthet(3,it)
4492         do j=2,0,-1
4493           sig=sig*thet_pred_mean+polthet(j,it)
4494         enddo
4495 C Derivative of the "interior part" of the "standard deviation of the"
4496 C gamma-dependent Gaussian lobe in t_c.
4497         sigtc=3*polthet(3,it)
4498         do j=2,1,-1
4499           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4500         enddo
4501         sigtc=sig*sigtc
4502 C Set the parameters of both Gaussian lobes of the distribution.
4503 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4504         fac=sig*sig+sigc0(it)
4505         sigcsq=fac+fac
4506         sigc=1.0D0/sigcsq
4507 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4508         sigsqtc=-4.0D0*sigcsq*sigtc
4509 c       print *,i,sig,sigtc,sigsqtc
4510 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4511         sigtc=-sigtc/(fac*fac)
4512 C Following variable is sigma(t_c)**(-2)
4513         sigcsq=sigcsq*sigcsq
4514         sig0i=sig0(it)
4515         sig0inv=1.0D0/sig0i**2
4516         delthec=thetai-thet_pred_mean
4517         delthe0=thetai-theta0i
4518         term1=-0.5D0*sigcsq*delthec*delthec
4519         term2=-0.5D0*sig0inv*delthe0*delthe0
4520 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4521 C NaNs in taking the logarithm. We extract the largest exponent which is added
4522 C to the energy (this being the log of the distribution) at the end of energy
4523 C term evaluation for this virtual-bond angle.
4524         if (term1.gt.term2) then
4525           termm=term1
4526           term2=dexp(term2-termm)
4527           term1=1.0d0
4528         else
4529           termm=term2
4530           term1=dexp(term1-termm)
4531           term2=1.0d0
4532         endif
4533 C The ratio between the gamma-independent and gamma-dependent lobes of
4534 C the distribution is a Gaussian function of thet_pred_mean too.
4535         diffak=gthet(2,it)-thet_pred_mean
4536         ratak=diffak/gthet(3,it)**2
4537         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4538 C Let's differentiate it in thet_pred_mean NOW.
4539         aktc=ak*ratak
4540 C Now put together the distribution terms to make complete distribution.
4541         termexp=term1+ak*term2
4542         termpre=sigc+ak*sig0i
4543 C Contribution of the bending energy from this theta is just the -log of
4544 C the sum of the contributions from the two lobes and the pre-exponential
4545 C factor. Simple enough, isn't it?
4546         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4547 C NOW the derivatives!!!
4548 C 6/6/97 Take into account the deformation.
4549         E_theta=(delthec*sigcsq*term1
4550      &       +ak*delthe0*sig0inv*term2)/termexp
4551         E_tc=((sigtc+aktc*sig0i)/termpre
4552      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4553      &       aktc*term2)/termexp)
4554       return
4555       end
4556 c-----------------------------------------------------------------------------
4557       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4558       implicit real*8 (a-h,o-z)
4559       include 'DIMENSIONS'
4560       include 'COMMON.LOCAL'
4561       include 'COMMON.IOUNITS'
4562       common /calcthet/ term1,term2,termm,diffak,ratak,
4563      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4564      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4565       delthec=thetai-thet_pred_mean
4566       delthe0=thetai-theta0i
4567 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4568       t3 = thetai-thet_pred_mean
4569       t6 = t3**2
4570       t9 = term1
4571       t12 = t3*sigcsq
4572       t14 = t12+t6*sigsqtc
4573       t16 = 1.0d0
4574       t21 = thetai-theta0i
4575       t23 = t21**2
4576       t26 = term2
4577       t27 = t21*t26
4578       t32 = termexp
4579       t40 = t32**2
4580       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4581      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4582      & *(-t12*t9-ak*sig0inv*t27)
4583       return
4584       end
4585 #else
4586 C--------------------------------------------------------------------------
4587       subroutine ebend(etheta)
4588 C
4589 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4590 C angles gamma and its derivatives in consecutive thetas and gammas.
4591 C ab initio-derived potentials from
4592 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4593 C
4594       implicit real*8 (a-h,o-z)
4595       include 'DIMENSIONS'
4596       include 'COMMON.LOCAL'
4597       include 'COMMON.GEO'
4598       include 'COMMON.INTERACT'
4599       include 'COMMON.DERIV'
4600       include 'COMMON.VAR'
4601       include 'COMMON.CHAIN'
4602       include 'COMMON.IOUNITS'
4603       include 'COMMON.NAMES'
4604       include 'COMMON.FFIELD'
4605       include 'COMMON.CONTROL'
4606       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4607      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4608      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4609      & sinph1ph2(maxdouble,maxdouble)
4610       logical lprn /.false./, lprn1 /.false./
4611       etheta=0.0D0
4612       do i=ithet_start,ithet_end
4613         dethetai=0.0d0
4614         dephii=0.0d0
4615         dephii1=0.0d0
4616         theti2=0.5d0*theta(i)
4617         ityp2=ithetyp(itype(i-1))
4618         do k=1,nntheterm
4619           coskt(k)=dcos(k*theti2)
4620           sinkt(k)=dsin(k*theti2)
4621         enddo
4622         if (i.gt.3) then
4623 #ifdef OSF
4624           phii=phi(i)
4625           if (phii.ne.phii) phii=150.0
4626 #else
4627           phii=phi(i)
4628 #endif
4629           ityp1=ithetyp(itype(i-2))
4630           do k=1,nsingle
4631             cosph1(k)=dcos(k*phii)
4632             sinph1(k)=dsin(k*phii)
4633           enddo
4634         else
4635           phii=0.0d0
4636           ityp1=nthetyp+1
4637           do k=1,nsingle
4638             cosph1(k)=0.0d0
4639             sinph1(k)=0.0d0
4640           enddo
4641         endif
4642         if (i.lt.nres) then
4643 #ifdef OSF
4644           phii1=phi(i+1)
4645           if (phii1.ne.phii1) phii1=150.0
4646           phii1=pinorm(phii1)
4647 #else
4648           phii1=phi(i+1)
4649 #endif
4650           ityp3=ithetyp(itype(i))
4651           do k=1,nsingle
4652             cosph2(k)=dcos(k*phii1)
4653             sinph2(k)=dsin(k*phii1)
4654           enddo
4655         else
4656           phii1=0.0d0
4657           ityp3=nthetyp+1
4658           do k=1,nsingle
4659             cosph2(k)=0.0d0
4660             sinph2(k)=0.0d0
4661           enddo
4662         endif
4663         ethetai=aa0thet(ityp1,ityp2,ityp3)
4664         do k=1,ndouble
4665           do l=1,k-1
4666             ccl=cosph1(l)*cosph2(k-l)
4667             ssl=sinph1(l)*sinph2(k-l)
4668             scl=sinph1(l)*cosph2(k-l)
4669             csl=cosph1(l)*sinph2(k-l)
4670             cosph1ph2(l,k)=ccl-ssl
4671             cosph1ph2(k,l)=ccl+ssl
4672             sinph1ph2(l,k)=scl+csl
4673             sinph1ph2(k,l)=scl-csl
4674           enddo
4675         enddo
4676         if (lprn) then
4677         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4678      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4679         write (iout,*) "coskt and sinkt"
4680         do k=1,nntheterm
4681           write (iout,*) k,coskt(k),sinkt(k)
4682         enddo
4683         endif
4684         do k=1,ntheterm
4685           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4686           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4687      &      *coskt(k)
4688           if (lprn)
4689      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4690      &     " ethetai",ethetai
4691         enddo
4692         if (lprn) then
4693         write (iout,*) "cosph and sinph"
4694         do k=1,nsingle
4695           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4696         enddo
4697         write (iout,*) "cosph1ph2 and sinph2ph2"
4698         do k=2,ndouble
4699           do l=1,k-1
4700             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4701      &         sinph1ph2(l,k),sinph1ph2(k,l)
4702           enddo
4703         enddo
4704         write(iout,*) "ethetai",ethetai
4705         endif
4706         do m=1,ntheterm2
4707           do k=1,nsingle
4708             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4709      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4710      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4711      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4712             ethetai=ethetai+sinkt(m)*aux
4713             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4714             dephii=dephii+k*sinkt(m)*(
4715      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4716      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4717             dephii1=dephii1+k*sinkt(m)*(
4718      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4719      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4720             if (lprn)
4721      &      write (iout,*) "m",m," k",k," bbthet",
4722      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4723      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4724      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4725      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4726           enddo
4727         enddo
4728         if (lprn)
4729      &  write(iout,*) "ethetai",ethetai
4730         do m=1,ntheterm3
4731           do k=2,ndouble
4732             do l=1,k-1
4733               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4734      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4735      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4736      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4737               ethetai=ethetai+sinkt(m)*aux
4738               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4739               dephii=dephii+l*sinkt(m)*(
4740      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4741      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4742      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4743      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4744               dephii1=dephii1+(k-l)*sinkt(m)*(
4745      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4746      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4747      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4748      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4749               if (lprn) then
4750               write (iout,*) "m",m," k",k," l",l," ffthet",
4751      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4752      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4753      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4754      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4755               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4756      &            cosph1ph2(k,l)*sinkt(m),
4757      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4758               endif
4759             enddo
4760           enddo
4761         enddo
4762 10      continue
4763         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4764      &   i,theta(i)*rad2deg,phii*rad2deg,
4765      &   phii1*rad2deg,ethetai
4766         etheta=etheta+ethetai
4767         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4768         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4769         gloc(nphi+i-2,icg)=wang*dethetai
4770       enddo
4771       return
4772       end
4773 #endif
4774 #ifdef CRYST_SC
4775 c-----------------------------------------------------------------------------
4776       subroutine esc(escloc)
4777 C Calculate the local energy of a side chain and its derivatives in the
4778 C corresponding virtual-bond valence angles THETA and the spherical angles
4779 C ALPHA and OMEGA.
4780       implicit real*8 (a-h,o-z)
4781       include 'DIMENSIONS'
4782       include 'COMMON.GEO'
4783       include 'COMMON.LOCAL'
4784       include 'COMMON.VAR'
4785       include 'COMMON.INTERACT'
4786       include 'COMMON.DERIV'
4787       include 'COMMON.CHAIN'
4788       include 'COMMON.IOUNITS'
4789       include 'COMMON.NAMES'
4790       include 'COMMON.FFIELD'
4791       include 'COMMON.CONTROL'
4792       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4793      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4794       common /sccalc/ time11,time12,time112,theti,it,nlobit
4795       delta=0.02d0*pi
4796       escloc=0.0D0
4797 c     write (iout,'(a)') 'ESC'
4798       do i=loc_start,loc_end
4799         it=itype(i)
4800         if (it.eq.10) goto 1
4801         nlobit=nlob(it)
4802 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4803 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4804         theti=theta(i+1)-pipol
4805         x(1)=dtan(theti)
4806         x(2)=alph(i)
4807         x(3)=omeg(i)
4808
4809         if (x(2).gt.pi-delta) then
4810           xtemp(1)=x(1)
4811           xtemp(2)=pi-delta
4812           xtemp(3)=x(3)
4813           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4814           xtemp(2)=pi
4815           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4816           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4817      &        escloci,dersc(2))
4818           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4819      &        ddersc0(1),dersc(1))
4820           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4821      &        ddersc0(3),dersc(3))
4822           xtemp(2)=pi-delta
4823           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4824           xtemp(2)=pi
4825           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4826           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4827      &            dersc0(2),esclocbi,dersc02)
4828           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4829      &            dersc12,dersc01)
4830           call splinthet(x(2),0.5d0*delta,ss,ssd)
4831           dersc0(1)=dersc01
4832           dersc0(2)=dersc02
4833           dersc0(3)=0.0d0
4834           do k=1,3
4835             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4836           enddo
4837           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4838 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4839 c    &             esclocbi,ss,ssd
4840           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4841 c         escloci=esclocbi
4842 c         write (iout,*) escloci
4843         else if (x(2).lt.delta) then
4844           xtemp(1)=x(1)
4845           xtemp(2)=delta
4846           xtemp(3)=x(3)
4847           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4848           xtemp(2)=0.0d0
4849           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4850           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4851      &        escloci,dersc(2))
4852           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4853      &        ddersc0(1),dersc(1))
4854           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4855      &        ddersc0(3),dersc(3))
4856           xtemp(2)=delta
4857           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4858           xtemp(2)=0.0d0
4859           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4860           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4861      &            dersc0(2),esclocbi,dersc02)
4862           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4863      &            dersc12,dersc01)
4864           dersc0(1)=dersc01
4865           dersc0(2)=dersc02
4866           dersc0(3)=0.0d0
4867           call splinthet(x(2),0.5d0*delta,ss,ssd)
4868           do k=1,3
4869             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4870           enddo
4871           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4872 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4873 c    &             esclocbi,ss,ssd
4874           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4875 c         write (iout,*) escloci
4876         else
4877           call enesc(x,escloci,dersc,ddummy,.false.)
4878         endif
4879
4880         escloc=escloc+escloci
4881         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4882      &     'escloc',i,escloci
4883 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4884
4885         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4886      &   wscloc*dersc(1)
4887         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4888         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4889     1   continue
4890       enddo
4891       return
4892       end
4893 C---------------------------------------------------------------------------
4894       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4895       implicit real*8 (a-h,o-z)
4896       include 'DIMENSIONS'
4897       include 'COMMON.GEO'
4898       include 'COMMON.LOCAL'
4899       include 'COMMON.IOUNITS'
4900       common /sccalc/ time11,time12,time112,theti,it,nlobit
4901       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4902       double precision contr(maxlob,-1:1)
4903       logical mixed
4904 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4905         escloc_i=0.0D0
4906         do j=1,3
4907           dersc(j)=0.0D0
4908           if (mixed) ddersc(j)=0.0d0
4909         enddo
4910         x3=x(3)
4911
4912 C Because of periodicity of the dependence of the SC energy in omega we have
4913 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4914 C To avoid underflows, first compute & store the exponents.
4915
4916         do iii=-1,1
4917
4918           x(3)=x3+iii*dwapi
4919
4920           do j=1,nlobit
4921             do k=1,3
4922               z(k)=x(k)-censc(k,j,it)
4923             enddo
4924             do k=1,3
4925               Axk=0.0D0
4926               do l=1,3
4927                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4928               enddo
4929               Ax(k,j,iii)=Axk
4930             enddo
4931             expfac=0.0D0
4932             do k=1,3
4933               expfac=expfac+Ax(k,j,iii)*z(k)
4934             enddo
4935             contr(j,iii)=expfac
4936           enddo ! j
4937
4938         enddo ! iii
4939
4940         x(3)=x3
4941 C As in the case of ebend, we want to avoid underflows in exponentiation and
4942 C subsequent NaNs and INFs in energy calculation.
4943 C Find the largest exponent
4944         emin=contr(1,-1)
4945         do iii=-1,1
4946           do j=1,nlobit
4947             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4948           enddo
4949         enddo
4950         emin=0.5D0*emin
4951 cd      print *,'it=',it,' emin=',emin
4952
4953 C Compute the contribution to SC energy and derivatives
4954         do iii=-1,1
4955
4956           do j=1,nlobit
4957 #ifdef OSF
4958             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4959             if(adexp.ne.adexp) adexp=1.0
4960             expfac=dexp(adexp)
4961 #else
4962             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4963 #endif
4964 cd          print *,'j=',j,' expfac=',expfac
4965             escloc_i=escloc_i+expfac
4966             do k=1,3
4967               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4968             enddo
4969             if (mixed) then
4970               do k=1,3,2
4971                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4972      &            +gaussc(k,2,j,it))*expfac
4973               enddo
4974             endif
4975           enddo
4976
4977         enddo ! iii
4978
4979         dersc(1)=dersc(1)/cos(theti)**2
4980         ddersc(1)=ddersc(1)/cos(theti)**2
4981         ddersc(3)=ddersc(3)
4982
4983         escloci=-(dlog(escloc_i)-emin)
4984         do j=1,3
4985           dersc(j)=dersc(j)/escloc_i
4986         enddo
4987         if (mixed) then
4988           do j=1,3,2
4989             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4990           enddo
4991         endif
4992       return
4993       end
4994 C------------------------------------------------------------------------------
4995       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4996       implicit real*8 (a-h,o-z)
4997       include 'DIMENSIONS'
4998       include 'COMMON.GEO'
4999       include 'COMMON.LOCAL'
5000       include 'COMMON.IOUNITS'
5001       common /sccalc/ time11,time12,time112,theti,it,nlobit
5002       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5003       double precision contr(maxlob)
5004       logical mixed
5005
5006       escloc_i=0.0D0
5007
5008       do j=1,3
5009         dersc(j)=0.0D0
5010       enddo
5011
5012       do j=1,nlobit
5013         do k=1,2
5014           z(k)=x(k)-censc(k,j,it)
5015         enddo
5016         z(3)=dwapi
5017         do k=1,3
5018           Axk=0.0D0
5019           do l=1,3
5020             Axk=Axk+gaussc(l,k,j,it)*z(l)
5021           enddo
5022           Ax(k,j)=Axk
5023         enddo
5024         expfac=0.0D0
5025         do k=1,3
5026           expfac=expfac+Ax(k,j)*z(k)
5027         enddo
5028         contr(j)=expfac
5029       enddo ! j
5030
5031 C As in the case of ebend, we want to avoid underflows in exponentiation and
5032 C subsequent NaNs and INFs in energy calculation.
5033 C Find the largest exponent
5034       emin=contr(1)
5035       do j=1,nlobit
5036         if (emin.gt.contr(j)) emin=contr(j)
5037       enddo
5038       emin=0.5D0*emin
5039
5040 C Compute the contribution to SC energy and derivatives
5041
5042       dersc12=0.0d0
5043       do j=1,nlobit
5044         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5045         escloc_i=escloc_i+expfac
5046         do k=1,2
5047           dersc(k)=dersc(k)+Ax(k,j)*expfac
5048         enddo
5049         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5050      &            +gaussc(1,2,j,it))*expfac
5051         dersc(3)=0.0d0
5052       enddo
5053
5054       dersc(1)=dersc(1)/cos(theti)**2
5055       dersc12=dersc12/cos(theti)**2
5056       escloci=-(dlog(escloc_i)-emin)
5057       do j=1,2
5058         dersc(j)=dersc(j)/escloc_i
5059       enddo
5060       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5061       return
5062       end
5063 #else
5064 c----------------------------------------------------------------------------------
5065       subroutine esc(escloc)
5066 C Calculate the local energy of a side chain and its derivatives in the
5067 C corresponding virtual-bond valence angles THETA and the spherical angles
5068 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5069 C added by Urszula Kozlowska. 07/11/2007
5070 C
5071       implicit real*8 (a-h,o-z)
5072       include 'DIMENSIONS'
5073       include 'COMMON.GEO'
5074       include 'COMMON.LOCAL'
5075       include 'COMMON.VAR'
5076       include 'COMMON.SCROT'
5077       include 'COMMON.INTERACT'
5078       include 'COMMON.DERIV'
5079       include 'COMMON.CHAIN'
5080       include 'COMMON.IOUNITS'
5081       include 'COMMON.NAMES'
5082       include 'COMMON.FFIELD'
5083       include 'COMMON.CONTROL'
5084       include 'COMMON.VECTORS'
5085       double precision x_prime(3),y_prime(3),z_prime(3)
5086      &    , sumene,dsc_i,dp2_i,x(65),
5087      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5088      &    de_dxx,de_dyy,de_dzz,de_dt
5089       double precision s1_t,s1_6_t,s2_t,s2_6_t
5090       double precision
5091      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5092      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5093      & dt_dCi(3),dt_dCi1(3)
5094       common /sccalc/ time11,time12,time112,theti,it,nlobit
5095       delta=0.02d0*pi
5096       escloc=0.0D0
5097       do i=loc_start,loc_end
5098         costtab(i+1) =dcos(theta(i+1))
5099         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5100         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5101         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5102         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5103         cosfac=dsqrt(cosfac2)
5104         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5105         sinfac=dsqrt(sinfac2)
5106         it=itype(i)
5107         if (it.eq.10) goto 1
5108 c
5109 C  Compute the axes of tghe local cartesian coordinates system; store in
5110 c   x_prime, y_prime and z_prime
5111 c
5112         do j=1,3
5113           x_prime(j) = 0.00
5114           y_prime(j) = 0.00
5115           z_prime(j) = 0.00
5116         enddo
5117 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5118 C     &   dc_norm(3,i+nres)
5119         do j = 1,3
5120           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5121           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5122         enddo
5123         do j = 1,3
5124           z_prime(j) = -uz(j,i-1)
5125         enddo
5126 c       write (2,*) "i",i
5127 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5128 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5129 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5130 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5131 c      & " xy",scalar(x_prime(1),y_prime(1)),
5132 c      & " xz",scalar(x_prime(1),z_prime(1)),
5133 c      & " yy",scalar(y_prime(1),y_prime(1)),
5134 c      & " yz",scalar(y_prime(1),z_prime(1)),
5135 c      & " zz",scalar(z_prime(1),z_prime(1))
5136 c
5137 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5138 C to local coordinate system. Store in xx, yy, zz.
5139 c
5140         xx=0.0d0
5141         yy=0.0d0
5142         zz=0.0d0
5143         do j = 1,3
5144           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5145           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5146           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5147         enddo
5148
5149         xxtab(i)=xx
5150         yytab(i)=yy
5151         zztab(i)=zz
5152 C
5153 C Compute the energy of the ith side cbain
5154 C
5155 c        write (2,*) "xx",xx," yy",yy," zz",zz
5156         it=itype(i)
5157         do j = 1,65
5158           x(j) = sc_parmin(j,it)
5159         enddo
5160 #ifdef CHECK_COORD
5161 Cc diagnostics - remove later
5162         xx1 = dcos(alph(2))
5163         yy1 = dsin(alph(2))*dcos(omeg(2))
5164         zz1 = -dsin(alph(2))*dsin(omeg(2))
5165         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5166      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5167      &    xx1,yy1,zz1
5168 C,"  --- ", xx_w,yy_w,zz_w
5169 c end diagnostics
5170 #endif
5171         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5172      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5173      &   + x(10)*yy*zz
5174         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5175      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5176      & + x(20)*yy*zz
5177         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5178      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5179      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5180      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5181      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5182      &  +x(40)*xx*yy*zz
5183         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5184      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5185      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5186      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5187      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5188      &  +x(60)*xx*yy*zz
5189         dsc_i   = 0.743d0+x(61)
5190         dp2_i   = 1.9d0+x(62)
5191         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5192      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5193         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5194      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5195         s1=(1+x(63))/(0.1d0 + dscp1)
5196         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5197         s2=(1+x(65))/(0.1d0 + dscp2)
5198         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5199         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5200      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5201 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5202 c     &   sumene4,
5203 c     &   dscp1,dscp2,sumene
5204 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5205         escloc = escloc + sumene
5206 c        write (2,*) "i",i," escloc",sumene,escloc
5207 #ifdef DEBUG
5208 C
5209 C This section to check the numerical derivatives of the energy of ith side
5210 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5211 C #define DEBUG in the code to turn it on.
5212 C
5213         write (2,*) "sumene               =",sumene
5214         aincr=1.0d-7
5215         xxsave=xx
5216         xx=xx+aincr
5217         write (2,*) xx,yy,zz
5218         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5219         de_dxx_num=(sumenep-sumene)/aincr
5220         xx=xxsave
5221         write (2,*) "xx+ sumene from enesc=",sumenep
5222         yysave=yy
5223         yy=yy+aincr
5224         write (2,*) xx,yy,zz
5225         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5226         de_dyy_num=(sumenep-sumene)/aincr
5227         yy=yysave
5228         write (2,*) "yy+ sumene from enesc=",sumenep
5229         zzsave=zz
5230         zz=zz+aincr
5231         write (2,*) xx,yy,zz
5232         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5233         de_dzz_num=(sumenep-sumene)/aincr
5234         zz=zzsave
5235         write (2,*) "zz+ sumene from enesc=",sumenep
5236         costsave=cost2tab(i+1)
5237         sintsave=sint2tab(i+1)
5238         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5239         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5240         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5241         de_dt_num=(sumenep-sumene)/aincr
5242         write (2,*) " t+ sumene from enesc=",sumenep
5243         cost2tab(i+1)=costsave
5244         sint2tab(i+1)=sintsave
5245 C End of diagnostics section.
5246 #endif
5247 C
5248 C Compute the gradient of esc
5249 C
5250         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5251         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5252         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5253         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5254         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5255         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5256         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5257         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5258         pom1=(sumene3*sint2tab(i+1)+sumene1)
5259      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5260         pom2=(sumene4*cost2tab(i+1)+sumene2)
5261      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5262         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5263         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5264      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5265      &  +x(40)*yy*zz
5266         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5267         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5268      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5269      &  +x(60)*yy*zz
5270         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5271      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5272      &        +(pom1+pom2)*pom_dx
5273 #ifdef DEBUG
5274         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5275 #endif
5276 C
5277         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5278         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5279      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5280      &  +x(40)*xx*zz
5281         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5282         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5283      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5284      &  +x(59)*zz**2 +x(60)*xx*zz
5285         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5286      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5287      &        +(pom1-pom2)*pom_dy
5288 #ifdef DEBUG
5289         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5290 #endif
5291 C
5292         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5293      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5294      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5295      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5296      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5297      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5298      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5299      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5300 #ifdef DEBUG
5301         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5302 #endif
5303 C
5304         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5305      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5306      &  +pom1*pom_dt1+pom2*pom_dt2
5307 #ifdef DEBUG
5308         write(2,*), "de_dt = ", de_dt,de_dt_num
5309 #endif
5310 c
5311 C
5312        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5313        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5314        cosfac2xx=cosfac2*xx
5315        sinfac2yy=sinfac2*yy
5316        do k = 1,3
5317          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5318      &      vbld_inv(i+1)
5319          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5320      &      vbld_inv(i)
5321          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5322          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5323 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5324 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5325 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5326 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5327          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5328          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5329          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5330          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5331          dZZ_Ci1(k)=0.0d0
5332          dZZ_Ci(k)=0.0d0
5333          do j=1,3
5334            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5335            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5336          enddo
5337
5338          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5339          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5340          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5341 c
5342          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5343          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5344        enddo
5345
5346        do k=1,3
5347          dXX_Ctab(k,i)=dXX_Ci(k)
5348          dXX_C1tab(k,i)=dXX_Ci1(k)
5349          dYY_Ctab(k,i)=dYY_Ci(k)
5350          dYY_C1tab(k,i)=dYY_Ci1(k)
5351          dZZ_Ctab(k,i)=dZZ_Ci(k)
5352          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5353          dXX_XYZtab(k,i)=dXX_XYZ(k)
5354          dYY_XYZtab(k,i)=dYY_XYZ(k)
5355          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5356        enddo
5357
5358        do k = 1,3
5359 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5360 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5361 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5362 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5363 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5364 c     &    dt_dci(k)
5365 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5366 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5367          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5368      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5369          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5370      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5371          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5372      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5373        enddo
5374 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5375 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5376
5377 C to check gradient call subroutine check_grad
5378
5379     1 continue
5380       enddo
5381       return
5382       end
5383 c------------------------------------------------------------------------------
5384       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5385       implicit none
5386       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5387      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5388       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5389      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5390      &   + x(10)*yy*zz
5391       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5392      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5393      & + x(20)*yy*zz
5394       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5395      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5396      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5397      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5398      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5399      &  +x(40)*xx*yy*zz
5400       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5401      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5402      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5403      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5404      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5405      &  +x(60)*xx*yy*zz
5406       dsc_i   = 0.743d0+x(61)
5407       dp2_i   = 1.9d0+x(62)
5408       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5409      &          *(xx*cost2+yy*sint2))
5410       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5411      &          *(xx*cost2-yy*sint2))
5412       s1=(1+x(63))/(0.1d0 + dscp1)
5413       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5414       s2=(1+x(65))/(0.1d0 + dscp2)
5415       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5416       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5417      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5418       enesc=sumene
5419       return
5420       end
5421 #endif
5422 c------------------------------------------------------------------------------
5423       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5424 C
5425 C This procedure calculates two-body contact function g(rij) and its derivative:
5426 C
5427 C           eps0ij                                     !       x < -1
5428 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5429 C            0                                         !       x > 1
5430 C
5431 C where x=(rij-r0ij)/delta
5432 C
5433 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5434 C
5435       implicit none
5436       double precision rij,r0ij,eps0ij,fcont,fprimcont
5437       double precision x,x2,x4,delta
5438 c     delta=0.02D0*r0ij
5439 c      delta=0.2D0*r0ij
5440       x=(rij-r0ij)/delta
5441       if (x.lt.-1.0D0) then
5442         fcont=eps0ij
5443         fprimcont=0.0D0
5444       else if (x.le.1.0D0) then
5445         x2=x*x
5446         x4=x2*x2
5447         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5448         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5449       else
5450         fcont=0.0D0
5451         fprimcont=0.0D0
5452       endif
5453       return
5454       end
5455 c------------------------------------------------------------------------------
5456       subroutine splinthet(theti,delta,ss,ssder)
5457       implicit real*8 (a-h,o-z)
5458       include 'DIMENSIONS'
5459       include 'COMMON.VAR'
5460       include 'COMMON.GEO'
5461       thetup=pi-delta
5462       thetlow=delta
5463       if (theti.gt.pipol) then
5464         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5465       else
5466         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5467         ssder=-ssder
5468       endif
5469       return
5470       end
5471 c------------------------------------------------------------------------------
5472       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5473       implicit none
5474       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5475       double precision ksi,ksi2,ksi3,a1,a2,a3
5476       a1=fprim0*delta/(f1-f0)
5477       a2=3.0d0-2.0d0*a1
5478       a3=a1-2.0d0
5479       ksi=(x-x0)/delta
5480       ksi2=ksi*ksi
5481       ksi3=ksi2*ksi
5482       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5483       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5484       return
5485       end
5486 c------------------------------------------------------------------------------
5487       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5488       implicit none
5489       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5490       double precision ksi,ksi2,ksi3,a1,a2,a3
5491       ksi=(x-x0)/delta
5492       ksi2=ksi*ksi
5493       ksi3=ksi2*ksi
5494       a1=fprim0x*delta
5495       a2=3*(f1x-f0x)-2*fprim0x*delta
5496       a3=fprim0x*delta-2*(f1x-f0x)
5497       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5498       return
5499       end
5500 C-----------------------------------------------------------------------------
5501 #ifdef CRYST_TOR
5502 C-----------------------------------------------------------------------------
5503       subroutine etor(etors,edihcnstr)
5504       implicit real*8 (a-h,o-z)
5505       include 'DIMENSIONS'
5506       include 'COMMON.VAR'
5507       include 'COMMON.GEO'
5508       include 'COMMON.LOCAL'
5509       include 'COMMON.TORSION'
5510       include 'COMMON.INTERACT'
5511       include 'COMMON.DERIV'
5512       include 'COMMON.CHAIN'
5513       include 'COMMON.NAMES'
5514       include 'COMMON.IOUNITS'
5515       include 'COMMON.FFIELD'
5516       include 'COMMON.TORCNSTR'
5517       include 'COMMON.CONTROL'
5518       logical lprn
5519 C Set lprn=.true. for debugging
5520       lprn=.false.
5521 c      lprn=.true.
5522       etors=0.0D0
5523       do i=iphi_start,iphi_end
5524       etors_ii=0.0D0
5525         itori=itortyp(itype(i-2))
5526         itori1=itortyp(itype(i-1))
5527         phii=phi(i)
5528         gloci=0.0D0
5529 C Proline-Proline pair is a special case...
5530         if (itori.eq.3 .and. itori1.eq.3) then
5531           if (phii.gt.-dwapi3) then
5532             cosphi=dcos(3*phii)
5533             fac=1.0D0/(1.0D0-cosphi)
5534             etorsi=v1(1,3,3)*fac
5535             etorsi=etorsi+etorsi
5536             etors=etors+etorsi-v1(1,3,3)
5537             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5538             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5539           endif
5540           do j=1,3
5541             v1ij=v1(j+1,itori,itori1)
5542             v2ij=v2(j+1,itori,itori1)
5543             cosphi=dcos(j*phii)
5544             sinphi=dsin(j*phii)
5545             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5546             if (energy_dec) etors_ii=etors_ii+
5547      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5548             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5549           enddo
5550         else
5551           do j=1,nterm_old
5552             v1ij=v1(j,itori,itori1)
5553             v2ij=v2(j,itori,itori1)
5554             cosphi=dcos(j*phii)
5555             sinphi=dsin(j*phii)
5556             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5557             if (energy_dec) etors_ii=etors_ii+
5558      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5559             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5560           enddo
5561         endif
5562         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5563      &        'etor',i,etors_ii
5564         if (lprn)
5565      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5566      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5567      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5568         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5569 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5570       enddo
5571 ! 6/20/98 - dihedral angle constraints
5572       edihcnstr=0.0d0
5573       do i=1,ndih_constr
5574         itori=idih_constr(i)
5575         phii=phi(itori)
5576         difi=phii-phi0(i)
5577         if (difi.gt.drange(i)) then
5578           difi=difi-drange(i)
5579           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5580           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5581         else if (difi.lt.-drange(i)) then
5582           difi=difi+drange(i)
5583           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5584           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5585         endif
5586 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5587 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5588       enddo
5589 !      write (iout,*) 'edihcnstr',edihcnstr
5590       return
5591       end
5592 c------------------------------------------------------------------------------
5593       subroutine etor_d(etors_d)
5594       etors_d=0.0d0
5595       return
5596       end
5597 c----------------------------------------------------------------------------
5598 #else
5599       subroutine etor(etors,edihcnstr)
5600       implicit real*8 (a-h,o-z)
5601       include 'DIMENSIONS'
5602       include 'COMMON.VAR'
5603       include 'COMMON.GEO'
5604       include 'COMMON.LOCAL'
5605       include 'COMMON.TORSION'
5606       include 'COMMON.INTERACT'
5607       include 'COMMON.DERIV'
5608       include 'COMMON.CHAIN'
5609       include 'COMMON.NAMES'
5610       include 'COMMON.IOUNITS'
5611       include 'COMMON.FFIELD'
5612       include 'COMMON.TORCNSTR'
5613       include 'COMMON.CONTROL'
5614       logical lprn
5615 C Set lprn=.true. for debugging
5616       lprn=.false.
5617 c     lprn=.true.
5618       etors=0.0D0
5619       do i=iphi_start,iphi_end
5620       etors_ii=0.0D0
5621         itori=itortyp(itype(i-2))
5622         itori1=itortyp(itype(i-1))
5623         phii=phi(i)
5624         gloci=0.0D0
5625 C Regular cosine and sine terms
5626         do j=1,nterm(itori,itori1)
5627           v1ij=v1(j,itori,itori1)
5628           v2ij=v2(j,itori,itori1)
5629           cosphi=dcos(j*phii)
5630           sinphi=dsin(j*phii)
5631           etors=etors+v1ij*cosphi+v2ij*sinphi
5632           if (energy_dec) etors_ii=etors_ii+
5633      &                v1ij*cosphi+v2ij*sinphi
5634           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5635         enddo
5636 C Lorentz terms
5637 C                         v1
5638 C  E = SUM ----------------------------------- - v1
5639 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5640 C
5641         cosphi=dcos(0.5d0*phii)
5642         sinphi=dsin(0.5d0*phii)
5643         do j=1,nlor(itori,itori1)
5644           vl1ij=vlor1(j,itori,itori1)
5645           vl2ij=vlor2(j,itori,itori1)
5646           vl3ij=vlor3(j,itori,itori1)
5647           pom=vl2ij*cosphi+vl3ij*sinphi
5648           pom1=1.0d0/(pom*pom+1.0d0)
5649           etors=etors+vl1ij*pom1
5650           if (energy_dec) etors_ii=etors_ii+
5651      &                vl1ij*pom1
5652           pom=-pom*pom1*pom1
5653           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5654         enddo
5655 C Subtract the constant term
5656         etors=etors-v0(itori,itori1)
5657           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5658      &         'etor',i,etors_ii-v0(itori,itori1)
5659         if (lprn)
5660      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5661      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5662      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5663         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5664 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5665       enddo
5666 ! 6/20/98 - dihedral angle constraints
5667       edihcnstr=0.0d0
5668 c      do i=1,ndih_constr
5669       do i=idihconstr_start,idihconstr_end
5670         itori=idih_constr(i)
5671         phii=phi(itori)
5672         difi=pinorm(phii-phi0(i))
5673         if (difi.gt.drange(i)) then
5674           difi=difi-drange(i)
5675           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5676           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5677         else if (difi.lt.-drange(i)) then
5678           difi=difi+drange(i)
5679           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5680           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5681         else
5682           difi=0.0
5683         endif
5684 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5685 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5686 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5687       enddo
5688 cd       write (iout,*) 'edihcnstr',edihcnstr
5689       return
5690       end
5691 c----------------------------------------------------------------------------
5692       subroutine etor_d(etors_d)
5693 C 6/23/01 Compute double torsional energy
5694       implicit real*8 (a-h,o-z)
5695       include 'DIMENSIONS'
5696       include 'COMMON.VAR'
5697       include 'COMMON.GEO'
5698       include 'COMMON.LOCAL'
5699       include 'COMMON.TORSION'
5700       include 'COMMON.INTERACT'
5701       include 'COMMON.DERIV'
5702       include 'COMMON.CHAIN'
5703       include 'COMMON.NAMES'
5704       include 'COMMON.IOUNITS'
5705       include 'COMMON.FFIELD'
5706       include 'COMMON.TORCNSTR'
5707       logical lprn
5708 C Set lprn=.true. for debugging
5709       lprn=.false.
5710 c     lprn=.true.
5711       etors_d=0.0D0
5712       do i=iphid_start,iphid_end
5713         itori=itortyp(itype(i-2))
5714         itori1=itortyp(itype(i-1))
5715         itori2=itortyp(itype(i))
5716         phii=phi(i)
5717         phii1=phi(i+1)
5718         gloci1=0.0D0
5719         gloci2=0.0D0
5720 C Regular cosine and sine terms
5721         do j=1,ntermd_1(itori,itori1,itori2)
5722           v1cij=v1c(1,j,itori,itori1,itori2)
5723           v1sij=v1s(1,j,itori,itori1,itori2)
5724           v2cij=v1c(2,j,itori,itori1,itori2)
5725           v2sij=v1s(2,j,itori,itori1,itori2)
5726           cosphi1=dcos(j*phii)
5727           sinphi1=dsin(j*phii)
5728           cosphi2=dcos(j*phii1)
5729           sinphi2=dsin(j*phii1)
5730           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5731      &     v2cij*cosphi2+v2sij*sinphi2
5732           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5733           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5734         enddo
5735         do k=2,ntermd_2(itori,itori1,itori2)
5736           do l=1,k-1
5737             v1cdij = v2c(k,l,itori,itori1,itori2)
5738             v2cdij = v2c(l,k,itori,itori1,itori2)
5739             v1sdij = v2s(k,l,itori,itori1,itori2)
5740             v2sdij = v2s(l,k,itori,itori1,itori2)
5741             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5742             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5743             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5744             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5745             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5746      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5747             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5748      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5749             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5750      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5751           enddo
5752         enddo
5753         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5754         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5755       enddo
5756       return
5757       end
5758 #endif
5759 c------------------------------------------------------------------------------
5760       subroutine eback_sc_corr(esccor)
5761 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5762 c        conformational states; temporarily implemented as differences
5763 c        between UNRES torsional potentials (dependent on three types of
5764 c        residues) and the torsional potentials dependent on all 20 types
5765 c        of residues computed from AM1  energy surfaces of terminally-blocked
5766 c        amino-acid residues.
5767       implicit real*8 (a-h,o-z)
5768       include 'DIMENSIONS'
5769       include 'COMMON.VAR'
5770       include 'COMMON.GEO'
5771       include 'COMMON.LOCAL'
5772       include 'COMMON.TORSION'
5773       include 'COMMON.SCCOR'
5774       include 'COMMON.INTERACT'
5775       include 'COMMON.DERIV'
5776       include 'COMMON.CHAIN'
5777       include 'COMMON.NAMES'
5778       include 'COMMON.IOUNITS'
5779       include 'COMMON.FFIELD'
5780       include 'COMMON.CONTROL'
5781       logical lprn
5782 C Set lprn=.true. for debugging
5783       lprn=.false.
5784 c      lprn=.true.
5785 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5786       esccor=0.0D0
5787       do i=iphi_start,iphi_end
5788         esccor_ii=0.0D0
5789         itori=itype(i-2)
5790         itori1=itype(i-1)
5791         phii=phi(i)
5792         gloci=0.0D0
5793         do j=1,nterm_sccor
5794           v1ij=v1sccor(j,itori,itori1)
5795           v2ij=v2sccor(j,itori,itori1)
5796           cosphi=dcos(j*phii)
5797           sinphi=dsin(j*phii)
5798           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5799           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5800         enddo
5801         if (lprn)
5802      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5803      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5804      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5805         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5806       enddo
5807       return
5808       end
5809 c----------------------------------------------------------------------------
5810       subroutine multibody(ecorr)
5811 C This subroutine calculates multi-body contributions to energy following
5812 C the idea of Skolnick et al. If side chains I and J make a contact and
5813 C at the same time side chains I+1 and J+1 make a contact, an extra
5814 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5815       implicit real*8 (a-h,o-z)
5816       include 'DIMENSIONS'
5817       include 'COMMON.IOUNITS'
5818       include 'COMMON.DERIV'
5819       include 'COMMON.INTERACT'
5820       include 'COMMON.CONTACTS'
5821       double precision gx(3),gx1(3)
5822       logical lprn
5823
5824 C Set lprn=.true. for debugging
5825       lprn=.false.
5826
5827       if (lprn) then
5828         write (iout,'(a)') 'Contact function values:'
5829         do i=nnt,nct-2
5830           write (iout,'(i2,20(1x,i2,f10.5))')
5831      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5832         enddo
5833       endif
5834       ecorr=0.0D0
5835       do i=nnt,nct
5836         do j=1,3
5837           gradcorr(j,i)=0.0D0
5838           gradxorr(j,i)=0.0D0
5839         enddo
5840       enddo
5841       do i=nnt,nct-2
5842
5843         DO ISHIFT = 3,4
5844
5845         i1=i+ishift
5846         num_conti=num_cont(i)
5847         num_conti1=num_cont(i1)
5848         do jj=1,num_conti
5849           j=jcont(jj,i)
5850           do kk=1,num_conti1
5851             j1=jcont(kk,i1)
5852             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5853 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5854 cd   &                   ' ishift=',ishift
5855 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5856 C The system gains extra energy.
5857               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5858             endif   ! j1==j+-ishift
5859           enddo     ! kk
5860         enddo       ! jj
5861
5862         ENDDO ! ISHIFT
5863
5864       enddo         ! i
5865       return
5866       end
5867 c------------------------------------------------------------------------------
5868       double precision function esccorr(i,j,k,l,jj,kk)
5869       implicit real*8 (a-h,o-z)
5870       include 'DIMENSIONS'
5871       include 'COMMON.IOUNITS'
5872       include 'COMMON.DERIV'
5873       include 'COMMON.INTERACT'
5874       include 'COMMON.CONTACTS'
5875       double precision gx(3),gx1(3)
5876       logical lprn
5877       lprn=.false.
5878       eij=facont(jj,i)
5879       ekl=facont(kk,k)
5880 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5881 C Calculate the multi-body contribution to energy.
5882 C Calculate multi-body contributions to the gradient.
5883 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5884 cd   & k,l,(gacont(m,kk,k),m=1,3)
5885       do m=1,3
5886         gx(m) =ekl*gacont(m,jj,i)
5887         gx1(m)=eij*gacont(m,kk,k)
5888         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5889         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5890         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5891         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5892       enddo
5893       do m=i,j-1
5894         do ll=1,3
5895           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5896         enddo
5897       enddo
5898       do m=k,l-1
5899         do ll=1,3
5900           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5901         enddo
5902       enddo
5903       esccorr=-eij*ekl
5904       return
5905       end
5906 c------------------------------------------------------------------------------
5907       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5908 C This subroutine calculates multi-body contributions to hydrogen-bonding
5909       implicit real*8 (a-h,o-z)
5910       include 'DIMENSIONS'
5911       include 'COMMON.IOUNITS'
5912 #ifdef MPI
5913       include "mpif.h"
5914       parameter (max_cont=maxconts)
5915       parameter (max_dim=26)
5916       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5917       double precision zapas(max_dim,maxconts,max_fg_procs),
5918      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5919       common /przechowalnia/ zapas
5920       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5921      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5922 #endif
5923       include 'COMMON.SETUP'
5924       include 'COMMON.FFIELD'
5925       include 'COMMON.DERIV'
5926       include 'COMMON.INTERACT'
5927       include 'COMMON.CONTACTS'
5928       include 'COMMON.CONTROL'
5929       include 'COMMON.LOCAL'
5930       double precision gx(3),gx1(3),time00
5931       logical lprn,ldone
5932
5933 C Set lprn=.true. for debugging
5934       lprn=.false.
5935 #ifdef MPI
5936       n_corr=0
5937       n_corr1=0
5938       if (nfgtasks.le.1) goto 30
5939       if (lprn) then
5940         write (iout,'(a)') 'Contact function values before RECEIVE:'
5941         do i=nnt,nct-2
5942           write (iout,'(2i3,50(1x,i2,f5.2))')
5943      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5944      &    j=1,num_cont_hb(i))
5945         enddo
5946       endif
5947       call flush(iout)
5948       do i=1,ntask_cont_from
5949         ncont_recv(i)=0
5950       enddo
5951       do i=1,ntask_cont_to
5952         ncont_sent(i)=0
5953       enddo
5954 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5955 c     & ntask_cont_to
5956 C Make the list of contacts to send to send to other procesors
5957 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5958 c      call flush(iout)
5959       do i=iturn3_start,iturn3_end
5960 c        write (iout,*) "make contact list turn3",i," num_cont",
5961 c     &    num_cont_hb(i)
5962         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5963       enddo
5964       do i=iturn4_start,iturn4_end
5965 c        write (iout,*) "make contact list turn4",i," num_cont",
5966 c     &   num_cont_hb(i)
5967         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5968       enddo
5969       do ii=1,nat_sent
5970         i=iat_sent(ii)
5971 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5972 c     &    num_cont_hb(i)
5973         do j=1,num_cont_hb(i)
5974         do k=1,4
5975           jjc=jcont_hb(j,i)
5976           iproc=iint_sent_local(k,jjc,ii)
5977 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5978           if (iproc.gt.0) then
5979             ncont_sent(iproc)=ncont_sent(iproc)+1
5980             nn=ncont_sent(iproc)
5981             zapas(1,nn,iproc)=i
5982             zapas(2,nn,iproc)=jjc
5983             zapas(3,nn,iproc)=facont_hb(j,i)
5984             zapas(4,nn,iproc)=ees0p(j,i)
5985             zapas(5,nn,iproc)=ees0m(j,i)
5986             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5987             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5988             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5989             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5990             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5991             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5992             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5993             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5994             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5995             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5996             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5997             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5998             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5999             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6000             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6001             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6002             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6003             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6004             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6005             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6006             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6007           endif
6008         enddo
6009         enddo
6010       enddo
6011       if (lprn) then
6012       write (iout,*)
6013      &  "Numbers of contacts to be sent to other processors",
6014      &  (ncont_sent(i),i=1,ntask_cont_to)
6015       write (iout,*) "Contacts sent"
6016       do ii=1,ntask_cont_to
6017         nn=ncont_sent(ii)
6018         iproc=itask_cont_to(ii)
6019         write (iout,*) nn," contacts to processor",iproc,
6020      &   " of CONT_TO_COMM group"
6021         do i=1,nn
6022           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6023         enddo
6024       enddo
6025       call flush(iout)
6026       endif
6027       CorrelType=477
6028       CorrelID=fg_rank+1
6029       CorrelType1=478
6030       CorrelID1=nfgtasks+fg_rank+1
6031       ireq=0
6032 C Receive the numbers of needed contacts from other processors
6033       do ii=1,ntask_cont_from
6034         iproc=itask_cont_from(ii)
6035         ireq=ireq+1
6036         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6037      &    FG_COMM,req(ireq),IERR)
6038       enddo
6039 c      write (iout,*) "IRECV ended"
6040 c      call flush(iout)
6041 C Send the number of contacts needed by other processors
6042       do ii=1,ntask_cont_to
6043         iproc=itask_cont_to(ii)
6044         ireq=ireq+1
6045         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6046      &    FG_COMM,req(ireq),IERR)
6047       enddo
6048 c      write (iout,*) "ISEND ended"
6049 c      write (iout,*) "number of requests (nn)",ireq
6050       call flush(iout)
6051       if (ireq.gt.0)
6052      &  call MPI_Waitall(ireq,req,status_array,ierr)
6053 c      write (iout,*)
6054 c     &  "Numbers of contacts to be received from other processors",
6055 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6056 c      call flush(iout)
6057 C Receive contacts
6058       ireq=0
6059       do ii=1,ntask_cont_from
6060         iproc=itask_cont_from(ii)
6061         nn=ncont_recv(ii)
6062 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6063 c     &   " of CONT_TO_COMM group"
6064         call flush(iout)
6065         if (nn.gt.0) then
6066           ireq=ireq+1
6067           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6068      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6069 c          write (iout,*) "ireq,req",ireq,req(ireq)
6070         endif
6071       enddo
6072 C Send the contacts to processors that need them
6073       do ii=1,ntask_cont_to
6074         iproc=itask_cont_to(ii)
6075         nn=ncont_sent(ii)
6076 c        write (iout,*) nn," contacts to processor",iproc,
6077 c     &   " of CONT_TO_COMM group"
6078         if (nn.gt.0) then
6079           ireq=ireq+1
6080           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6081      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6082 c          write (iout,*) "ireq,req",ireq,req(ireq)
6083 c          do i=1,nn
6084 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6085 c          enddo
6086         endif
6087       enddo
6088 c      write (iout,*) "number of requests (contacts)",ireq
6089 c      write (iout,*) "req",(req(i),i=1,4)
6090 c      call flush(iout)
6091       if (ireq.gt.0)
6092      & call MPI_Waitall(ireq,req,status_array,ierr)
6093       do iii=1,ntask_cont_from
6094         iproc=itask_cont_from(iii)
6095         nn=ncont_recv(iii)
6096         if (lprn) then
6097         write (iout,*) "Received",nn," contacts from processor",iproc,
6098      &   " of CONT_FROM_COMM group"
6099         call flush(iout)
6100         do i=1,nn
6101           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6102         enddo
6103         call flush(iout)
6104         endif
6105         do i=1,nn
6106           ii=zapas_recv(1,i,iii)
6107 c Flag the received contacts to prevent double-counting
6108           jj=-zapas_recv(2,i,iii)
6109 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6110 c          call flush(iout)
6111           nnn=num_cont_hb(ii)+1
6112           num_cont_hb(ii)=nnn
6113           jcont_hb(nnn,ii)=jj
6114           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6115           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6116           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6117           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6118           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6119           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6120           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6121           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6122           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6123           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6124           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6125           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6126           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6127           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6128           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6129           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6130           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6131           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6132           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6133           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6134           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6135           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6136           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6137           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6138         enddo
6139       enddo
6140       call flush(iout)
6141       if (lprn) then
6142         write (iout,'(a)') 'Contact function values after receive:'
6143         do i=nnt,nct-2
6144           write (iout,'(2i3,50(1x,i3,f5.2))')
6145      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6146      &    j=1,num_cont_hb(i))
6147         enddo
6148         call flush(iout)
6149       endif
6150    30 continue
6151 #endif
6152       if (lprn) then
6153         write (iout,'(a)') 'Contact function values:'
6154         do i=nnt,nct-2
6155           write (iout,'(2i3,50(1x,i3,f5.2))')
6156      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6157      &    j=1,num_cont_hb(i))
6158         enddo
6159       endif
6160       ecorr=0.0D0
6161 C Remove the loop below after debugging !!!
6162       do i=nnt,nct
6163         do j=1,3
6164           gradcorr(j,i)=0.0D0
6165           gradxorr(j,i)=0.0D0
6166         enddo
6167       enddo
6168 C Calculate the local-electrostatic correlation terms
6169       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6170         i1=i+1
6171         num_conti=num_cont_hb(i)
6172         num_conti1=num_cont_hb(i+1)
6173         do jj=1,num_conti
6174           j=jcont_hb(jj,i)
6175           jp=iabs(j)
6176           do kk=1,num_conti1
6177             j1=jcont_hb(kk,i1)
6178             jp1=iabs(j1)
6179 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6180 c     &         ' jj=',jj,' kk=',kk
6181             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6182      &          .or. j.lt.0 .and. j1.gt.0) .and.
6183      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6184 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6185 C The system gains extra energy.
6186               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6187               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6188      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6189               n_corr=n_corr+1
6190             else if (j1.eq.j) then
6191 C Contacts I-J and I-(J+1) occur simultaneously.
6192 C The system loses extra energy.
6193 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6194             endif
6195           enddo ! kk
6196           do kk=1,num_conti
6197             j1=jcont_hb(kk,i)
6198 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6199 c    &         ' jj=',jj,' kk=',kk
6200             if (j1.eq.j+1) then
6201 C Contacts I-J and (I+1)-J occur simultaneously.
6202 C The system loses extra energy.
6203 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6204             endif ! j1==j+1
6205           enddo ! kk
6206         enddo ! jj
6207       enddo ! i
6208       return
6209       end
6210 c------------------------------------------------------------------------------
6211       subroutine add_hb_contact(ii,jj,itask)
6212       implicit real*8 (a-h,o-z)
6213       include "DIMENSIONS"
6214       include "COMMON.IOUNITS"
6215       integer max_cont
6216       integer max_dim
6217       parameter (max_cont=maxconts)
6218       parameter (max_dim=26)
6219       include "COMMON.CONTACTS"
6220       double precision zapas(max_dim,maxconts,max_fg_procs),
6221      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6222       common /przechowalnia/ zapas
6223       integer i,j,ii,jj,iproc,itask(4),nn
6224 c      write (iout,*) "itask",itask
6225       do i=1,2
6226         iproc=itask(i)
6227         if (iproc.gt.0) then
6228           do j=1,num_cont_hb(ii)
6229             jjc=jcont_hb(j,ii)
6230 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6231             if (jjc.eq.jj) then
6232               ncont_sent(iproc)=ncont_sent(iproc)+1
6233               nn=ncont_sent(iproc)
6234               zapas(1,nn,iproc)=ii
6235               zapas(2,nn,iproc)=jjc
6236               zapas(3,nn,iproc)=facont_hb(j,ii)
6237               zapas(4,nn,iproc)=ees0p(j,ii)
6238               zapas(5,nn,iproc)=ees0m(j,ii)
6239               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6240               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6241               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6242               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6243               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6244               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6245               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6246               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6247               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6248               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6249               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6250               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6251               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6252               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6253               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6254               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6255               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6256               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6257               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6258               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6259               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6260               exit
6261             endif
6262           enddo
6263         endif
6264       enddo
6265       return
6266       end
6267 c------------------------------------------------------------------------------
6268       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6269      &  n_corr1)
6270 C This subroutine calculates multi-body contributions to hydrogen-bonding
6271       implicit real*8 (a-h,o-z)
6272       include 'DIMENSIONS'
6273       include 'COMMON.IOUNITS'
6274 #ifdef MPI
6275       include "mpif.h"
6276       parameter (max_cont=maxconts)
6277       parameter (max_dim=70)
6278       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6279       double precision zapas(max_dim,maxconts,max_fg_procs),
6280      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6281       common /przechowalnia/ zapas
6282       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6283      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6284 #endif
6285       include 'COMMON.SETUP'
6286       include 'COMMON.FFIELD'
6287       include 'COMMON.DERIV'
6288       include 'COMMON.LOCAL'
6289       include 'COMMON.INTERACT'
6290       include 'COMMON.CONTACTS'
6291       include 'COMMON.CHAIN'
6292       include 'COMMON.CONTROL'
6293       double precision gx(3),gx1(3)
6294       integer num_cont_hb_old(maxres)
6295       logical lprn,ldone
6296       double precision eello4,eello5,eelo6,eello_turn6
6297       external eello4,eello5,eello6,eello_turn6
6298 C Set lprn=.true. for debugging
6299       lprn=.false.
6300       eturn6=0.0d0
6301 #ifdef MPI
6302       do i=1,nres
6303         num_cont_hb_old(i)=num_cont_hb(i)
6304       enddo
6305       n_corr=0
6306       n_corr1=0
6307       if (nfgtasks.le.1) goto 30
6308       if (lprn) then
6309         write (iout,'(a)') 'Contact function values before RECEIVE:'
6310         do i=nnt,nct-2
6311           write (iout,'(2i3,50(1x,i2,f5.2))')
6312      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6313      &    j=1,num_cont_hb(i))
6314         enddo
6315       endif
6316       call flush(iout)
6317       do i=1,ntask_cont_from
6318         ncont_recv(i)=0
6319       enddo
6320       do i=1,ntask_cont_to
6321         ncont_sent(i)=0
6322       enddo
6323 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6324 c     & ntask_cont_to
6325 C Make the list of contacts to send to send to other procesors
6326       do i=iturn3_start,iturn3_end
6327 c        write (iout,*) "make contact list turn3",i," num_cont",
6328 c     &    num_cont_hb(i)
6329         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6330       enddo
6331       do i=iturn4_start,iturn4_end
6332 c        write (iout,*) "make contact list turn4",i," num_cont",
6333 c     &   num_cont_hb(i)
6334         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6335       enddo
6336       do ii=1,nat_sent
6337         i=iat_sent(ii)
6338 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6339 c     &    num_cont_hb(i)
6340         do j=1,num_cont_hb(i)
6341         do k=1,4
6342           jjc=jcont_hb(j,i)
6343           iproc=iint_sent_local(k,jjc,ii)
6344 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6345           if (iproc.ne.0) then
6346             ncont_sent(iproc)=ncont_sent(iproc)+1
6347             nn=ncont_sent(iproc)
6348             zapas(1,nn,iproc)=i
6349             zapas(2,nn,iproc)=jjc
6350             zapas(3,nn,iproc)=d_cont(j,i)
6351             ind=3
6352             do kk=1,3
6353               ind=ind+1
6354               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6355             enddo
6356             do kk=1,2
6357               do ll=1,2
6358                 ind=ind+1
6359                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6360               enddo
6361             enddo
6362             do jj=1,5
6363               do kk=1,3
6364                 do ll=1,2
6365                   do mm=1,2
6366                     ind=ind+1
6367                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6368                   enddo
6369                 enddo
6370               enddo
6371             enddo
6372           endif
6373         enddo
6374         enddo
6375       enddo
6376       if (lprn) then
6377       write (iout,*)
6378      &  "Numbers of contacts to be sent to other processors",
6379      &  (ncont_sent(i),i=1,ntask_cont_to)
6380       write (iout,*) "Contacts sent"
6381       do ii=1,ntask_cont_to
6382         nn=ncont_sent(ii)
6383         iproc=itask_cont_to(ii)
6384         write (iout,*) nn," contacts to processor",iproc,
6385      &   " of CONT_TO_COMM group"
6386         do i=1,nn
6387           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6388         enddo
6389       enddo
6390       call flush(iout)
6391       endif
6392       CorrelType=477
6393       CorrelID=fg_rank+1
6394       CorrelType1=478
6395       CorrelID1=nfgtasks+fg_rank+1
6396       ireq=0
6397 C Receive the numbers of needed contacts from other processors
6398       do ii=1,ntask_cont_from
6399         iproc=itask_cont_from(ii)
6400         ireq=ireq+1
6401         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6402      &    FG_COMM,req(ireq),IERR)
6403       enddo
6404 c      write (iout,*) "IRECV ended"
6405 c      call flush(iout)
6406 C Send the number of contacts needed by other processors
6407       do ii=1,ntask_cont_to
6408         iproc=itask_cont_to(ii)
6409         ireq=ireq+1
6410         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6411      &    FG_COMM,req(ireq),IERR)
6412       enddo
6413 c      write (iout,*) "ISEND ended"
6414 c      write (iout,*) "number of requests (nn)",ireq
6415       call flush(iout)
6416       if (ireq.gt.0)
6417      &  call MPI_Waitall(ireq,req,status_array,ierr)
6418 c      write (iout,*)
6419 c     &  "Numbers of contacts to be received from other processors",
6420 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6421 c      call flush(iout)
6422 C Receive contacts
6423       ireq=0
6424       do ii=1,ntask_cont_from
6425         iproc=itask_cont_from(ii)
6426         nn=ncont_recv(ii)
6427 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6428 c     &   " of CONT_TO_COMM group"
6429         call flush(iout)
6430         if (nn.gt.0) then
6431           ireq=ireq+1
6432           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6433      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6434 c          write (iout,*) "ireq,req",ireq,req(ireq)
6435         endif
6436       enddo
6437 C Send the contacts to processors that need them
6438       do ii=1,ntask_cont_to
6439         iproc=itask_cont_to(ii)
6440         nn=ncont_sent(ii)
6441 c        write (iout,*) nn," contacts to processor",iproc,
6442 c     &   " of CONT_TO_COMM group"
6443         if (nn.gt.0) then
6444           ireq=ireq+1
6445           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6446      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6447 c          write (iout,*) "ireq,req",ireq,req(ireq)
6448 c          do i=1,nn
6449 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6450 c          enddo
6451         endif
6452       enddo
6453 c      write (iout,*) "number of requests (contacts)",ireq
6454 c      write (iout,*) "req",(req(i),i=1,4)
6455 c      call flush(iout)
6456       if (ireq.gt.0)
6457      & call MPI_Waitall(ireq,req,status_array,ierr)
6458       do iii=1,ntask_cont_from
6459         iproc=itask_cont_from(iii)
6460         nn=ncont_recv(iii)
6461         if (lprn) then
6462         write (iout,*) "Received",nn," contacts from processor",iproc,
6463      &   " of CONT_FROM_COMM group"
6464         call flush(iout)
6465         do i=1,nn
6466           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6467         enddo
6468         call flush(iout)
6469         endif
6470         do i=1,nn
6471           ii=zapas_recv(1,i,iii)
6472 c Flag the received contacts to prevent double-counting
6473           jj=-zapas_recv(2,i,iii)
6474 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6475 c          call flush(iout)
6476           nnn=num_cont_hb(ii)+1
6477           num_cont_hb(ii)=nnn
6478           jcont_hb(nnn,ii)=jj
6479           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6480           ind=3
6481           do kk=1,3
6482             ind=ind+1
6483             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6484           enddo
6485           do kk=1,2
6486             do ll=1,2
6487               ind=ind+1
6488               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6489             enddo
6490           enddo
6491           do jj=1,5
6492             do kk=1,3
6493               do ll=1,2
6494                 do mm=1,2
6495                   ind=ind+1
6496                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6497                 enddo
6498               enddo
6499             enddo
6500           enddo
6501         enddo
6502       enddo
6503       call flush(iout)
6504       if (lprn) then
6505         write (iout,'(a)') 'Contact function values after receive:'
6506         do i=nnt,nct-2
6507           write (iout,'(2i3,50(1x,i3,5f6.3))')
6508      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6509      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6510         enddo
6511         call flush(iout)
6512       endif
6513    30 continue
6514 #endif
6515       if (lprn) then
6516         write (iout,'(a)') 'Contact function values:'
6517         do i=nnt,nct-2
6518           write (iout,'(2i3,50(1x,i2,5f6.3))')
6519      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6520      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6521         enddo
6522       endif
6523       ecorr=0.0D0
6524       ecorr5=0.0d0
6525       ecorr6=0.0d0
6526 C Remove the loop below after debugging !!!
6527       do i=nnt,nct
6528         do j=1,3
6529           gradcorr(j,i)=0.0D0
6530           gradxorr(j,i)=0.0D0
6531         enddo
6532       enddo
6533 C Calculate the dipole-dipole interaction energies
6534       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6535       do i=iatel_s,iatel_e+1
6536         num_conti=num_cont_hb(i)
6537         do jj=1,num_conti
6538           j=jcont_hb(jj,i)
6539 #ifdef MOMENT
6540           call dipole(i,j,jj)
6541 #endif
6542         enddo
6543       enddo
6544       endif
6545 C Calculate the local-electrostatic correlation terms
6546 c                write (iout,*) "gradcorr5 in eello5 before loop"
6547 c                do iii=1,nres
6548 c                  write (iout,'(i5,3f10.5)')
6549 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6550 c                enddo
6551       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6552 c        write (iout,*) "corr loop i",i
6553         i1=i+1
6554         num_conti=num_cont_hb(i)
6555         num_conti1=num_cont_hb(i+1)
6556         do jj=1,num_conti
6557           j=jcont_hb(jj,i)
6558           jp=iabs(j)
6559           do kk=1,num_conti1
6560             j1=jcont_hb(kk,i1)
6561             jp1=iabs(j1)
6562 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6563 c     &         ' jj=',jj,' kk=',kk
6564 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6565             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6566      &          .or. j.lt.0 .and. j1.gt.0) .and.
6567      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6568 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6569 C The system gains extra energy.
6570               n_corr=n_corr+1
6571               sqd1=dsqrt(d_cont(jj,i))
6572               sqd2=dsqrt(d_cont(kk,i1))
6573               sred_geom = sqd1*sqd2
6574               IF (sred_geom.lt.cutoff_corr) THEN
6575                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6576      &            ekont,fprimcont)
6577 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6578 cd     &         ' jj=',jj,' kk=',kk
6579                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6580                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6581                 do l=1,3
6582                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6583                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6584                 enddo
6585                 n_corr1=n_corr1+1
6586 cd               write (iout,*) 'sred_geom=',sred_geom,
6587 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6588 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6589 cd               write (iout,*) "g_contij",g_contij
6590 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6591 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6592                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6593                 if (wcorr4.gt.0.0d0)
6594      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6595                   if (energy_dec.and.wcorr4.gt.0.0d0)
6596      1                 write (iout,'(a6,4i5,0pf7.3)')
6597      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6598 c                write (iout,*) "gradcorr5 before eello5"
6599 c                do iii=1,nres
6600 c                  write (iout,'(i5,3f10.5)')
6601 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6602 c                enddo
6603                 if (wcorr5.gt.0.0d0)
6604      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6605 c                write (iout,*) "gradcorr5 after eello5"
6606 c                do iii=1,nres
6607 c                  write (iout,'(i5,3f10.5)')
6608 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6609 c                enddo
6610                   if (energy_dec.and.wcorr5.gt.0.0d0)
6611      1                 write (iout,'(a6,4i5,0pf7.3)')
6612      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6613 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6614 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6615                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6616      &               .or. wturn6.eq.0.0d0))then
6617 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6618                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6619                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6620      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6621 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6622 cd     &            'ecorr6=',ecorr6
6623 cd                write (iout,'(4e15.5)') sred_geom,
6624 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6625 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6626 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6627                 else if (wturn6.gt.0.0d0
6628      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6629 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6630                   eturn6=eturn6+eello_turn6(i,jj,kk)
6631                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6632      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6633 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6634                 endif
6635               ENDIF
6636 1111          continue
6637             endif
6638           enddo ! kk
6639         enddo ! jj
6640       enddo ! i
6641       do i=1,nres
6642         num_cont_hb(i)=num_cont_hb_old(i)
6643       enddo
6644 c                write (iout,*) "gradcorr5 in eello5"
6645 c                do iii=1,nres
6646 c                  write (iout,'(i5,3f10.5)')
6647 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6648 c                enddo
6649       return
6650       end
6651 c------------------------------------------------------------------------------
6652       subroutine add_hb_contact_eello(ii,jj,itask)
6653       implicit real*8 (a-h,o-z)
6654       include "DIMENSIONS"
6655       include "COMMON.IOUNITS"
6656       integer max_cont
6657       integer max_dim
6658       parameter (max_cont=maxconts)
6659       parameter (max_dim=70)
6660       include "COMMON.CONTACTS"
6661       double precision zapas(max_dim,maxconts,max_fg_procs),
6662      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6663       common /przechowalnia/ zapas
6664       integer i,j,ii,jj,iproc,itask(4),nn
6665 c      write (iout,*) "itask",itask
6666       do i=1,2
6667         iproc=itask(i)
6668         if (iproc.gt.0) then
6669           do j=1,num_cont_hb(ii)
6670             jjc=jcont_hb(j,ii)
6671 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6672             if (jjc.eq.jj) then
6673               ncont_sent(iproc)=ncont_sent(iproc)+1
6674               nn=ncont_sent(iproc)
6675               zapas(1,nn,iproc)=ii
6676               zapas(2,nn,iproc)=jjc
6677               zapas(3,nn,iproc)=d_cont(j,ii)
6678               ind=3
6679               do kk=1,3
6680                 ind=ind+1
6681                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6682               enddo
6683               do kk=1,2
6684                 do ll=1,2
6685                   ind=ind+1
6686                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
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                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6695                     enddo
6696                   enddo
6697                 enddo
6698               enddo
6699               exit
6700             endif
6701           enddo
6702         endif
6703       enddo
6704       return
6705       end
6706 c------------------------------------------------------------------------------
6707       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6708       implicit real*8 (a-h,o-z)
6709       include 'DIMENSIONS'
6710       include 'COMMON.IOUNITS'
6711       include 'COMMON.DERIV'
6712       include 'COMMON.INTERACT'
6713       include 'COMMON.CONTACTS'
6714       double precision gx(3),gx1(3)
6715       logical lprn
6716       lprn=.false.
6717       eij=facont_hb(jj,i)
6718       ekl=facont_hb(kk,k)
6719       ees0pij=ees0p(jj,i)
6720       ees0pkl=ees0p(kk,k)
6721       ees0mij=ees0m(jj,i)
6722       ees0mkl=ees0m(kk,k)
6723       ekont=eij*ekl
6724       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6725 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6726 C Following 4 lines for diagnostics.
6727 cd    ees0pkl=0.0D0
6728 cd    ees0pij=1.0D0
6729 cd    ees0mkl=0.0D0
6730 cd    ees0mij=1.0D0
6731 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6732 c     & 'Contacts ',i,j,
6733 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6734 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6735 c     & 'gradcorr_long'
6736 C Calculate the multi-body contribution to energy.
6737 c      ecorr=ecorr+ekont*ees
6738 C Calculate multi-body contributions to the gradient.
6739       coeffpees0pij=coeffp*ees0pij
6740       coeffmees0mij=coeffm*ees0mij
6741       coeffpees0pkl=coeffp*ees0pkl
6742       coeffmees0mkl=coeffm*ees0mkl
6743       do ll=1,3
6744 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6745         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6746      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6747      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6748         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6749      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6750      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6751 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6752         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6753      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6754      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6755         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6756      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6757      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6758         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6759      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6760      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6761         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6762         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6763         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6764      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6765      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6766         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6767         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6768 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6769       enddo
6770 c      write (iout,*)
6771 cgrad      do m=i+1,j-1
6772 cgrad        do ll=1,3
6773 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6774 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6775 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6776 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6777 cgrad        enddo
6778 cgrad      enddo
6779 cgrad      do m=k+1,l-1
6780 cgrad        do ll=1,3
6781 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6782 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6783 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6784 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6785 cgrad        enddo
6786 cgrad      enddo
6787 c      write (iout,*) "ehbcorr",ekont*ees
6788       ehbcorr=ekont*ees
6789       return
6790       end
6791 #ifdef MOMENT
6792 C---------------------------------------------------------------------------
6793       subroutine dipole(i,j,jj)
6794       implicit real*8 (a-h,o-z)
6795       include 'DIMENSIONS'
6796       include 'COMMON.IOUNITS'
6797       include 'COMMON.CHAIN'
6798       include 'COMMON.FFIELD'
6799       include 'COMMON.DERIV'
6800       include 'COMMON.INTERACT'
6801       include 'COMMON.CONTACTS'
6802       include 'COMMON.TORSION'
6803       include 'COMMON.VAR'
6804       include 'COMMON.GEO'
6805       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6806      &  auxmat(2,2)
6807       iti1 = itortyp(itype(i+1))
6808       if (j.lt.nres-1) then
6809         itj1 = itortyp(itype(j+1))
6810       else
6811         itj1=ntortyp+1
6812       endif
6813       do iii=1,2
6814         dipi(iii,1)=Ub2(iii,i)
6815         dipderi(iii)=Ub2der(iii,i)
6816         dipi(iii,2)=b1(iii,iti1)
6817         dipj(iii,1)=Ub2(iii,j)
6818         dipderj(iii)=Ub2der(iii,j)
6819         dipj(iii,2)=b1(iii,itj1)
6820       enddo
6821       kkk=0
6822       do iii=1,2
6823         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6824         do jjj=1,2
6825           kkk=kkk+1
6826           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6827         enddo
6828       enddo
6829       do kkk=1,5
6830         do lll=1,3
6831           mmm=0
6832           do iii=1,2
6833             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6834      &        auxvec(1))
6835             do jjj=1,2
6836               mmm=mmm+1
6837               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6838             enddo
6839           enddo
6840         enddo
6841       enddo
6842       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6843       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6844       do iii=1,2
6845         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6846       enddo
6847       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6848       do iii=1,2
6849         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6850       enddo
6851       return
6852       end
6853 #endif
6854 C---------------------------------------------------------------------------
6855       subroutine calc_eello(i,j,k,l,jj,kk)
6856 C
6857 C This subroutine computes matrices and vectors needed to calculate
6858 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6859 C
6860       implicit real*8 (a-h,o-z)
6861       include 'DIMENSIONS'
6862       include 'COMMON.IOUNITS'
6863       include 'COMMON.CHAIN'
6864       include 'COMMON.DERIV'
6865       include 'COMMON.INTERACT'
6866       include 'COMMON.CONTACTS'
6867       include 'COMMON.TORSION'
6868       include 'COMMON.VAR'
6869       include 'COMMON.GEO'
6870       include 'COMMON.FFIELD'
6871       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6872      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6873       logical lprn
6874       common /kutas/ lprn
6875 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6876 cd     & ' jj=',jj,' kk=',kk
6877 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6878 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6879 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6880       do iii=1,2
6881         do jjj=1,2
6882           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6883           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6884         enddo
6885       enddo
6886       call transpose2(aa1(1,1),aa1t(1,1))
6887       call transpose2(aa2(1,1),aa2t(1,1))
6888       do kkk=1,5
6889         do lll=1,3
6890           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6891      &      aa1tder(1,1,lll,kkk))
6892           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6893      &      aa2tder(1,1,lll,kkk))
6894         enddo
6895       enddo
6896       if (l.eq.j+1) then
6897 C parallel orientation of the two CA-CA-CA frames.
6898         if (i.gt.1) then
6899           iti=itortyp(itype(i))
6900         else
6901           iti=ntortyp+1
6902         endif
6903         itk1=itortyp(itype(k+1))
6904         itj=itortyp(itype(j))
6905         if (l.lt.nres-1) then
6906           itl1=itortyp(itype(l+1))
6907         else
6908           itl1=ntortyp+1
6909         endif
6910 C A1 kernel(j+1) A2T
6911 cd        do iii=1,2
6912 cd          write (iout,'(3f10.5,5x,3f10.5)')
6913 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6914 cd        enddo
6915         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6916      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6917      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6918 C Following matrices are needed only for 6-th order cumulants
6919         IF (wcorr6.gt.0.0d0) THEN
6920         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6921      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6922      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6923         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6924      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6925      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6926      &   ADtEAderx(1,1,1,1,1,1))
6927         lprn=.false.
6928         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6929      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6930      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6931      &   ADtEA1derx(1,1,1,1,1,1))
6932         ENDIF
6933 C End 6-th order cumulants
6934 cd        lprn=.false.
6935 cd        if (lprn) then
6936 cd        write (2,*) 'In calc_eello6'
6937 cd        do iii=1,2
6938 cd          write (2,*) 'iii=',iii
6939 cd          do kkk=1,5
6940 cd            write (2,*) 'kkk=',kkk
6941 cd            do jjj=1,2
6942 cd              write (2,'(3(2f10.5),5x)')
6943 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6944 cd            enddo
6945 cd          enddo
6946 cd        enddo
6947 cd        endif
6948         call transpose2(EUgder(1,1,k),auxmat(1,1))
6949         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6950         call transpose2(EUg(1,1,k),auxmat(1,1))
6951         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6952         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6953         do iii=1,2
6954           do kkk=1,5
6955             do lll=1,3
6956               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6957      &          EAEAderx(1,1,lll,kkk,iii,1))
6958             enddo
6959           enddo
6960         enddo
6961 C A1T kernel(i+1) A2
6962         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6963      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6964      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6965 C Following matrices are needed only for 6-th order cumulants
6966         IF (wcorr6.gt.0.0d0) THEN
6967         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6968      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6969      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6970         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6971      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6972      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6973      &   ADtEAderx(1,1,1,1,1,2))
6974         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6975      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6976      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6977      &   ADtEA1derx(1,1,1,1,1,2))
6978         ENDIF
6979 C End 6-th order cumulants
6980         call transpose2(EUgder(1,1,l),auxmat(1,1))
6981         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6982         call transpose2(EUg(1,1,l),auxmat(1,1))
6983         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6984         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6985         do iii=1,2
6986           do kkk=1,5
6987             do lll=1,3
6988               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6989      &          EAEAderx(1,1,lll,kkk,iii,2))
6990             enddo
6991           enddo
6992         enddo
6993 C AEAb1 and AEAb2
6994 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6995 C They are needed only when the fifth- or the sixth-order cumulants are
6996 C indluded.
6997         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6998         call transpose2(AEA(1,1,1),auxmat(1,1))
6999         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7000         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7001         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7002         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7003         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7004         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7005         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7006         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7007         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7008         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7009         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7010         call transpose2(AEA(1,1,2),auxmat(1,1))
7011         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7012         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7013         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7014         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7015         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7016         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7017         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7018         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7019         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7020         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7021         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7022 C Calculate the Cartesian derivatives of the vectors.
7023         do iii=1,2
7024           do kkk=1,5
7025             do lll=1,3
7026               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7027               call matvec2(auxmat(1,1),b1(1,iti),
7028      &          AEAb1derx(1,lll,kkk,iii,1,1))
7029               call matvec2(auxmat(1,1),Ub2(1,i),
7030      &          AEAb2derx(1,lll,kkk,iii,1,1))
7031               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7032      &          AEAb1derx(1,lll,kkk,iii,2,1))
7033               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7034      &          AEAb2derx(1,lll,kkk,iii,2,1))
7035               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7036               call matvec2(auxmat(1,1),b1(1,itj),
7037      &          AEAb1derx(1,lll,kkk,iii,1,2))
7038               call matvec2(auxmat(1,1),Ub2(1,j),
7039      &          AEAb2derx(1,lll,kkk,iii,1,2))
7040               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7041      &          AEAb1derx(1,lll,kkk,iii,2,2))
7042               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7043      &          AEAb2derx(1,lll,kkk,iii,2,2))
7044             enddo
7045           enddo
7046         enddo
7047         ENDIF
7048 C End vectors
7049       else
7050 C Antiparallel orientation of the two CA-CA-CA frames.
7051         if (i.gt.1) then
7052           iti=itortyp(itype(i))
7053         else
7054           iti=ntortyp+1
7055         endif
7056         itk1=itortyp(itype(k+1))
7057         itl=itortyp(itype(l))
7058         itj=itortyp(itype(j))
7059         if (j.lt.nres-1) then
7060           itj1=itortyp(itype(j+1))
7061         else
7062           itj1=ntortyp+1
7063         endif
7064 C A2 kernel(j-1)T A1T
7065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7066      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7067      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7068 C Following matrices are needed only for 6-th order cumulants
7069         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7070      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7071         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7072      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7073      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7074         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7075      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7076      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7077      &   ADtEAderx(1,1,1,1,1,1))
7078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7079      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7080      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7081      &   ADtEA1derx(1,1,1,1,1,1))
7082         ENDIF
7083 C End 6-th order cumulants
7084         call transpose2(EUgder(1,1,k),auxmat(1,1))
7085         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7086         call transpose2(EUg(1,1,k),auxmat(1,1))
7087         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7088         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7089         do iii=1,2
7090           do kkk=1,5
7091             do lll=1,3
7092               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7093      &          EAEAderx(1,1,lll,kkk,iii,1))
7094             enddo
7095           enddo
7096         enddo
7097 C A2T kernel(i+1)T A1
7098         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7099      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7100      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7101 C Following matrices are needed only for 6-th order cumulants
7102         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7103      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7104         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7105      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7106      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7107         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7108      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7109      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7110      &   ADtEAderx(1,1,1,1,1,2))
7111         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7112      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7113      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7114      &   ADtEA1derx(1,1,1,1,1,2))
7115         ENDIF
7116 C End 6-th order cumulants
7117         call transpose2(EUgder(1,1,j),auxmat(1,1))
7118         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7119         call transpose2(EUg(1,1,j),auxmat(1,1))
7120         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7121         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7122         do iii=1,2
7123           do kkk=1,5
7124             do lll=1,3
7125               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7126      &          EAEAderx(1,1,lll,kkk,iii,2))
7127             enddo
7128           enddo
7129         enddo
7130 C AEAb1 and AEAb2
7131 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7132 C They are needed only when the fifth- or the sixth-order cumulants are
7133 C indluded.
7134         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7135      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7136         call transpose2(AEA(1,1,1),auxmat(1,1))
7137         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7138         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7139         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7140         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7141         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7142         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7143         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7144         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7145         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7146         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7147         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7148         call transpose2(AEA(1,1,2),auxmat(1,1))
7149         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7150         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7151         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7152         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7153         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7154         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7155         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7156         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7157         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7158         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7159         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7160 C Calculate the Cartesian derivatives of the vectors.
7161         do iii=1,2
7162           do kkk=1,5
7163             do lll=1,3
7164               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7165               call matvec2(auxmat(1,1),b1(1,iti),
7166      &          AEAb1derx(1,lll,kkk,iii,1,1))
7167               call matvec2(auxmat(1,1),Ub2(1,i),
7168      &          AEAb2derx(1,lll,kkk,iii,1,1))
7169               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7170      &          AEAb1derx(1,lll,kkk,iii,2,1))
7171               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7172      &          AEAb2derx(1,lll,kkk,iii,2,1))
7173               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7174               call matvec2(auxmat(1,1),b1(1,itl),
7175      &          AEAb1derx(1,lll,kkk,iii,1,2))
7176               call matvec2(auxmat(1,1),Ub2(1,l),
7177      &          AEAb2derx(1,lll,kkk,iii,1,2))
7178               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7179      &          AEAb1derx(1,lll,kkk,iii,2,2))
7180               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7181      &          AEAb2derx(1,lll,kkk,iii,2,2))
7182             enddo
7183           enddo
7184         enddo
7185         ENDIF
7186 C End vectors
7187       endif
7188       return
7189       end
7190 C---------------------------------------------------------------------------
7191       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7192      &  KK,KKderg,AKA,AKAderg,AKAderx)
7193       implicit none
7194       integer nderg
7195       logical transp
7196       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7197      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7198      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7199       integer iii,kkk,lll
7200       integer jjj,mmm
7201       logical lprn
7202       common /kutas/ lprn
7203       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7204       do iii=1,nderg
7205         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7206      &    AKAderg(1,1,iii))
7207       enddo
7208 cd      if (lprn) write (2,*) 'In kernel'
7209       do kkk=1,5
7210 cd        if (lprn) write (2,*) 'kkk=',kkk
7211         do lll=1,3
7212           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7213      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7214 cd          if (lprn) then
7215 cd            write (2,*) 'lll=',lll
7216 cd            write (2,*) 'iii=1'
7217 cd            do jjj=1,2
7218 cd              write (2,'(3(2f10.5),5x)')
7219 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7220 cd            enddo
7221 cd          endif
7222           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7223      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7224 cd          if (lprn) then
7225 cd            write (2,*) 'lll=',lll
7226 cd            write (2,*) 'iii=2'
7227 cd            do jjj=1,2
7228 cd              write (2,'(3(2f10.5),5x)')
7229 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7230 cd            enddo
7231 cd          endif
7232         enddo
7233       enddo
7234       return
7235       end
7236 C---------------------------------------------------------------------------
7237       double precision function eello4(i,j,k,l,jj,kk)
7238       implicit real*8 (a-h,o-z)
7239       include 'DIMENSIONS'
7240       include 'COMMON.IOUNITS'
7241       include 'COMMON.CHAIN'
7242       include 'COMMON.DERIV'
7243       include 'COMMON.INTERACT'
7244       include 'COMMON.CONTACTS'
7245       include 'COMMON.TORSION'
7246       include 'COMMON.VAR'
7247       include 'COMMON.GEO'
7248       double precision pizda(2,2),ggg1(3),ggg2(3)
7249 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7250 cd        eello4=0.0d0
7251 cd        return
7252 cd      endif
7253 cd      print *,'eello4:',i,j,k,l,jj,kk
7254 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7255 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7256 cold      eij=facont_hb(jj,i)
7257 cold      ekl=facont_hb(kk,k)
7258 cold      ekont=eij*ekl
7259       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7260 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7261       gcorr_loc(k-1)=gcorr_loc(k-1)
7262      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7263       if (l.eq.j+1) then
7264         gcorr_loc(l-1)=gcorr_loc(l-1)
7265      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7266       else
7267         gcorr_loc(j-1)=gcorr_loc(j-1)
7268      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7269       endif
7270       do iii=1,2
7271         do kkk=1,5
7272           do lll=1,3
7273             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7274      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7275 cd            derx(lll,kkk,iii)=0.0d0
7276           enddo
7277         enddo
7278       enddo
7279 cd      gcorr_loc(l-1)=0.0d0
7280 cd      gcorr_loc(j-1)=0.0d0
7281 cd      gcorr_loc(k-1)=0.0d0
7282 cd      eel4=1.0d0
7283 cd      write (iout,*)'Contacts have occurred for peptide groups',
7284 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7285 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7286       if (j.lt.nres-1) then
7287         j1=j+1
7288         j2=j-1
7289       else
7290         j1=j-1
7291         j2=j-2
7292       endif
7293       if (l.lt.nres-1) then
7294         l1=l+1
7295         l2=l-1
7296       else
7297         l1=l-1
7298         l2=l-2
7299       endif
7300       do ll=1,3
7301 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7302 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7303         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7304         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7305 cgrad        ghalf=0.5d0*ggg1(ll)
7306         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7307         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7308         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7309         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7310         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7311         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7312 cgrad        ghalf=0.5d0*ggg2(ll)
7313         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7314         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7315         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7316         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7317         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7318         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7319       enddo
7320 cgrad      do m=i+1,j-1
7321 cgrad        do ll=1,3
7322 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7323 cgrad        enddo
7324 cgrad      enddo
7325 cgrad      do m=k+1,l-1
7326 cgrad        do ll=1,3
7327 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7328 cgrad        enddo
7329 cgrad      enddo
7330 cgrad      do m=i+2,j2
7331 cgrad        do ll=1,3
7332 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7333 cgrad        enddo
7334 cgrad      enddo
7335 cgrad      do m=k+2,l2
7336 cgrad        do ll=1,3
7337 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7338 cgrad        enddo
7339 cgrad      enddo
7340 cd      do iii=1,nres-3
7341 cd        write (2,*) iii,gcorr_loc(iii)
7342 cd      enddo
7343       eello4=ekont*eel4
7344 cd      write (2,*) 'ekont',ekont
7345 cd      write (iout,*) 'eello4',ekont*eel4
7346       return
7347       end
7348 C---------------------------------------------------------------------------
7349       double precision function eello5(i,j,k,l,jj,kk)
7350       implicit real*8 (a-h,o-z)
7351       include 'DIMENSIONS'
7352       include 'COMMON.IOUNITS'
7353       include 'COMMON.CHAIN'
7354       include 'COMMON.DERIV'
7355       include 'COMMON.INTERACT'
7356       include 'COMMON.CONTACTS'
7357       include 'COMMON.TORSION'
7358       include 'COMMON.VAR'
7359       include 'COMMON.GEO'
7360       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7361       double precision ggg1(3),ggg2(3)
7362 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7363 C                                                                              C
7364 C                            Parallel chains                                   C
7365 C                                                                              C
7366 C          o             o                   o             o                   C
7367 C         /l\           / \             \   / \           / \   /              C
7368 C        /   \         /   \             \ /   \         /   \ /               C
7369 C       j| o |l1       | o |              o| o |         | o |o                C
7370 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7371 C      \i/   \         /   \ /             /   \         /   \                 C
7372 C       o    k1             o                                                  C
7373 C         (I)          (II)                (III)          (IV)                 C
7374 C                                                                              C
7375 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7376 C                                                                              C
7377 C                            Antiparallel chains                               C
7378 C                                                                              C
7379 C          o             o                   o             o                   C
7380 C         /j\           / \             \   / \           / \   /              C
7381 C        /   \         /   \             \ /   \         /   \ /               C
7382 C      j1| o |l        | o |              o| o |         | o |o                C
7383 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7384 C      \i/   \         /   \ /             /   \         /   \                 C
7385 C       o     k1            o                                                  C
7386 C         (I)          (II)                (III)          (IV)                 C
7387 C                                                                              C
7388 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7389 C                                                                              C
7390 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7391 C                                                                              C
7392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7393 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7394 cd        eello5=0.0d0
7395 cd        return
7396 cd      endif
7397 cd      write (iout,*)
7398 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7399 cd     &   ' and',k,l
7400       itk=itortyp(itype(k))
7401       itl=itortyp(itype(l))
7402       itj=itortyp(itype(j))
7403       eello5_1=0.0d0
7404       eello5_2=0.0d0
7405       eello5_3=0.0d0
7406       eello5_4=0.0d0
7407 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7408 cd     &   eel5_3_num,eel5_4_num)
7409       do iii=1,2
7410         do kkk=1,5
7411           do lll=1,3
7412             derx(lll,kkk,iii)=0.0d0
7413           enddo
7414         enddo
7415       enddo
7416 cd      eij=facont_hb(jj,i)
7417 cd      ekl=facont_hb(kk,k)
7418 cd      ekont=eij*ekl
7419 cd      write (iout,*)'Contacts have occurred for peptide groups',
7420 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7421 cd      goto 1111
7422 C Contribution from the graph I.
7423 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7424 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7425       call transpose2(EUg(1,1,k),auxmat(1,1))
7426       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7427       vv(1)=pizda(1,1)-pizda(2,2)
7428       vv(2)=pizda(1,2)+pizda(2,1)
7429       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7430      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7431 C Explicit gradient in virtual-dihedral angles.
7432       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7433      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7434      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7435       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7436       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7437       vv(1)=pizda(1,1)-pizda(2,2)
7438       vv(2)=pizda(1,2)+pizda(2,1)
7439       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7440      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7441      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7442       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7443       vv(1)=pizda(1,1)-pizda(2,2)
7444       vv(2)=pizda(1,2)+pizda(2,1)
7445       if (l.eq.j+1) then
7446         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7447      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7448      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7449       else
7450         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7451      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7452      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7453       endif
7454 C Cartesian gradient
7455       do iii=1,2
7456         do kkk=1,5
7457           do lll=1,3
7458             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7459      &        pizda(1,1))
7460             vv(1)=pizda(1,1)-pizda(2,2)
7461             vv(2)=pizda(1,2)+pizda(2,1)
7462             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7463      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7464      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7465           enddo
7466         enddo
7467       enddo
7468 c      goto 1112
7469 c1111  continue
7470 C Contribution from graph II
7471       call transpose2(EE(1,1,itk),auxmat(1,1))
7472       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7473       vv(1)=pizda(1,1)+pizda(2,2)
7474       vv(2)=pizda(2,1)-pizda(1,2)
7475       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7476      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7477 C Explicit gradient in virtual-dihedral angles.
7478       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7479      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7480       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7481       vv(1)=pizda(1,1)+pizda(2,2)
7482       vv(2)=pizda(2,1)-pizda(1,2)
7483       if (l.eq.j+1) then
7484         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7485      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7486      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7487       else
7488         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7489      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7490      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7491       endif
7492 C Cartesian gradient
7493       do iii=1,2
7494         do kkk=1,5
7495           do lll=1,3
7496             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7497      &        pizda(1,1))
7498             vv(1)=pizda(1,1)+pizda(2,2)
7499             vv(2)=pizda(2,1)-pizda(1,2)
7500             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7501      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7502      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7503           enddo
7504         enddo
7505       enddo
7506 cd      goto 1112
7507 cd1111  continue
7508       if (l.eq.j+1) then
7509 cd        goto 1110
7510 C Parallel orientation
7511 C Contribution from graph III
7512         call transpose2(EUg(1,1,l),auxmat(1,1))
7513         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7514         vv(1)=pizda(1,1)-pizda(2,2)
7515         vv(2)=pizda(1,2)+pizda(2,1)
7516         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7517      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7518 C Explicit gradient in virtual-dihedral angles.
7519         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7520      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7521      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7522         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7523         vv(1)=pizda(1,1)-pizda(2,2)
7524         vv(2)=pizda(1,2)+pizda(2,1)
7525         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7526      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7527      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7528         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7529         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7530         vv(1)=pizda(1,1)-pizda(2,2)
7531         vv(2)=pizda(1,2)+pizda(2,1)
7532         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7533      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7534      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7535 C Cartesian gradient
7536         do iii=1,2
7537           do kkk=1,5
7538             do lll=1,3
7539               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7540      &          pizda(1,1))
7541               vv(1)=pizda(1,1)-pizda(2,2)
7542               vv(2)=pizda(1,2)+pizda(2,1)
7543               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7544      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7545      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7546             enddo
7547           enddo
7548         enddo
7549 cd        goto 1112
7550 C Contribution from graph IV
7551 cd1110    continue
7552         call transpose2(EE(1,1,itl),auxmat(1,1))
7553         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7554         vv(1)=pizda(1,1)+pizda(2,2)
7555         vv(2)=pizda(2,1)-pizda(1,2)
7556         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7557      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7558 C Explicit gradient in virtual-dihedral angles.
7559         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7560      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7561         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7562         vv(1)=pizda(1,1)+pizda(2,2)
7563         vv(2)=pizda(2,1)-pizda(1,2)
7564         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7565      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7566      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7567 C Cartesian gradient
7568         do iii=1,2
7569           do kkk=1,5
7570             do lll=1,3
7571               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7572      &          pizda(1,1))
7573               vv(1)=pizda(1,1)+pizda(2,2)
7574               vv(2)=pizda(2,1)-pizda(1,2)
7575               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7576      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7577      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7578             enddo
7579           enddo
7580         enddo
7581       else
7582 C Antiparallel orientation
7583 C Contribution from graph III
7584 c        goto 1110
7585         call transpose2(EUg(1,1,j),auxmat(1,1))
7586         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7587         vv(1)=pizda(1,1)-pizda(2,2)
7588         vv(2)=pizda(1,2)+pizda(2,1)
7589         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7591 C Explicit gradient in virtual-dihedral angles.
7592         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7593      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7594      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7595         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7596         vv(1)=pizda(1,1)-pizda(2,2)
7597         vv(2)=pizda(1,2)+pizda(2,1)
7598         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7599      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7600      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7601         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7602         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7603         vv(1)=pizda(1,1)-pizda(2,2)
7604         vv(2)=pizda(1,2)+pizda(2,1)
7605         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7606      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7607      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7608 C Cartesian gradient
7609         do iii=1,2
7610           do kkk=1,5
7611             do lll=1,3
7612               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7613      &          pizda(1,1))
7614               vv(1)=pizda(1,1)-pizda(2,2)
7615               vv(2)=pizda(1,2)+pizda(2,1)
7616               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7617      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7618      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7619             enddo
7620           enddo
7621         enddo
7622 cd        goto 1112
7623 C Contribution from graph IV
7624 1110    continue
7625         call transpose2(EE(1,1,itj),auxmat(1,1))
7626         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7627         vv(1)=pizda(1,1)+pizda(2,2)
7628         vv(2)=pizda(2,1)-pizda(1,2)
7629         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7630      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7631 C Explicit gradient in virtual-dihedral angles.
7632         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7633      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7634         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7635         vv(1)=pizda(1,1)+pizda(2,2)
7636         vv(2)=pizda(2,1)-pizda(1,2)
7637         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7638      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7639      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7640 C Cartesian gradient
7641         do iii=1,2
7642           do kkk=1,5
7643             do lll=1,3
7644               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7645      &          pizda(1,1))
7646               vv(1)=pizda(1,1)+pizda(2,2)
7647               vv(2)=pizda(2,1)-pizda(1,2)
7648               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7649      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7650      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7651             enddo
7652           enddo
7653         enddo
7654       endif
7655 1112  continue
7656       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7657 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7658 cd        write (2,*) 'ijkl',i,j,k,l
7659 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7660 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7661 cd      endif
7662 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7663 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7664 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7665 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7666       if (j.lt.nres-1) then
7667         j1=j+1
7668         j2=j-1
7669       else
7670         j1=j-1
7671         j2=j-2
7672       endif
7673       if (l.lt.nres-1) then
7674         l1=l+1
7675         l2=l-1
7676       else
7677         l1=l-1
7678         l2=l-2
7679       endif
7680 cd      eij=1.0d0
7681 cd      ekl=1.0d0
7682 cd      ekont=1.0d0
7683 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7684 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7685 C        summed up outside the subrouine as for the other subroutines
7686 C        handling long-range interactions. The old code is commented out
7687 C        with "cgrad" to keep track of changes.
7688       do ll=1,3
7689 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7690 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7691         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7692         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7693 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7694 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7695 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7696 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7697 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7698 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7699 c     &   gradcorr5ij,
7700 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7701 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7702 cgrad        ghalf=0.5d0*ggg1(ll)
7703 cd        ghalf=0.0d0
7704         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7705         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7706         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7707         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7708         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7709         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7710 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7711 cgrad        ghalf=0.5d0*ggg2(ll)
7712 cd        ghalf=0.0d0
7713         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7714         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7715         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7716         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7717         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7718         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7719       enddo
7720 cd      goto 1112
7721 cgrad      do m=i+1,j-1
7722 cgrad        do ll=1,3
7723 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7724 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7725 cgrad        enddo
7726 cgrad      enddo
7727 cgrad      do m=k+1,l-1
7728 cgrad        do ll=1,3
7729 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7730 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7731 cgrad        enddo
7732 cgrad      enddo
7733 c1112  continue
7734 cgrad      do m=i+2,j2
7735 cgrad        do ll=1,3
7736 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7737 cgrad        enddo
7738 cgrad      enddo
7739 cgrad      do m=k+2,l2
7740 cgrad        do ll=1,3
7741 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7742 cgrad        enddo
7743 cgrad      enddo
7744 cd      do iii=1,nres-3
7745 cd        write (2,*) iii,g_corr5_loc(iii)
7746 cd      enddo
7747       eello5=ekont*eel5
7748 cd      write (2,*) 'ekont',ekont
7749 cd      write (iout,*) 'eello5',ekont*eel5
7750       return
7751       end
7752 c--------------------------------------------------------------------------
7753       double precision function eello6(i,j,k,l,jj,kk)
7754       implicit real*8 (a-h,o-z)
7755       include 'DIMENSIONS'
7756       include 'COMMON.IOUNITS'
7757       include 'COMMON.CHAIN'
7758       include 'COMMON.DERIV'
7759       include 'COMMON.INTERACT'
7760       include 'COMMON.CONTACTS'
7761       include 'COMMON.TORSION'
7762       include 'COMMON.VAR'
7763       include 'COMMON.GEO'
7764       include 'COMMON.FFIELD'
7765       double precision ggg1(3),ggg2(3)
7766 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7767 cd        eello6=0.0d0
7768 cd        return
7769 cd      endif
7770 cd      write (iout,*)
7771 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7772 cd     &   ' and',k,l
7773       eello6_1=0.0d0
7774       eello6_2=0.0d0
7775       eello6_3=0.0d0
7776       eello6_4=0.0d0
7777       eello6_5=0.0d0
7778       eello6_6=0.0d0
7779 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7780 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7781       do iii=1,2
7782         do kkk=1,5
7783           do lll=1,3
7784             derx(lll,kkk,iii)=0.0d0
7785           enddo
7786         enddo
7787       enddo
7788 cd      eij=facont_hb(jj,i)
7789 cd      ekl=facont_hb(kk,k)
7790 cd      ekont=eij*ekl
7791 cd      eij=1.0d0
7792 cd      ekl=1.0d0
7793 cd      ekont=1.0d0
7794       if (l.eq.j+1) then
7795         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7796         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7797         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7798         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7799         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7800         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7801       else
7802         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7803         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7804         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7805         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7806         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7807           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7808         else
7809           eello6_5=0.0d0
7810         endif
7811         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7812       endif
7813 C If turn contributions are considered, they will be handled separately.
7814       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7815 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7816 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7817 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7818 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7819 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7820 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7821 cd      goto 1112
7822       if (j.lt.nres-1) then
7823         j1=j+1
7824         j2=j-1
7825       else
7826         j1=j-1
7827         j2=j-2
7828       endif
7829       if (l.lt.nres-1) then
7830         l1=l+1
7831         l2=l-1
7832       else
7833         l1=l-1
7834         l2=l-2
7835       endif
7836       do ll=1,3
7837 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7838 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7839 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7840 cgrad        ghalf=0.5d0*ggg1(ll)
7841 cd        ghalf=0.0d0
7842         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7843         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7844         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7845         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7846         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7847         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7848         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7849         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7850 cgrad        ghalf=0.5d0*ggg2(ll)
7851 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7852 cd        ghalf=0.0d0
7853         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7854         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7855         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7856         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7857         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7858         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7859       enddo
7860 cd      goto 1112
7861 cgrad      do m=i+1,j-1
7862 cgrad        do ll=1,3
7863 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7864 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7865 cgrad        enddo
7866 cgrad      enddo
7867 cgrad      do m=k+1,l-1
7868 cgrad        do ll=1,3
7869 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7870 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7871 cgrad        enddo
7872 cgrad      enddo
7873 cgrad1112  continue
7874 cgrad      do m=i+2,j2
7875 cgrad        do ll=1,3
7876 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7877 cgrad        enddo
7878 cgrad      enddo
7879 cgrad      do m=k+2,l2
7880 cgrad        do ll=1,3
7881 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7882 cgrad        enddo
7883 cgrad      enddo
7884 cd      do iii=1,nres-3
7885 cd        write (2,*) iii,g_corr6_loc(iii)
7886 cd      enddo
7887       eello6=ekont*eel6
7888 cd      write (2,*) 'ekont',ekont
7889 cd      write (iout,*) 'eello6',ekont*eel6
7890       return
7891       end
7892 c--------------------------------------------------------------------------
7893       double precision function eello6_graph1(i,j,k,l,imat,swap)
7894       implicit real*8 (a-h,o-z)
7895       include 'DIMENSIONS'
7896       include 'COMMON.IOUNITS'
7897       include 'COMMON.CHAIN'
7898       include 'COMMON.DERIV'
7899       include 'COMMON.INTERACT'
7900       include 'COMMON.CONTACTS'
7901       include 'COMMON.TORSION'
7902       include 'COMMON.VAR'
7903       include 'COMMON.GEO'
7904       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7905       logical swap
7906       logical lprn
7907       common /kutas/ lprn
7908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7909 C
7910 C      Parallel       Antiparallel
7911 C
7912 C          o             o
7913 C         /l\           /j\
7914 C        /   \         /   \
7915 C       /| o |         | o |\
7916 C     \ j|/k\|  /   \  |/k\|l /
7917 C      \ /   \ /     \ /   \ /
7918 C       o     o       o     o
7919 C       i             i
7920 C
7921 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7922       itk=itortyp(itype(k))
7923       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7924       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7925       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7926       call transpose2(EUgC(1,1,k),auxmat(1,1))
7927       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7928       vv1(1)=pizda1(1,1)-pizda1(2,2)
7929       vv1(2)=pizda1(1,2)+pizda1(2,1)
7930       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7931       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7932       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7933       s5=scalar2(vv(1),Dtobr2(1,i))
7934 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7935       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7936       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7937      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7938      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7939      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7940      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7941      & +scalar2(vv(1),Dtobr2der(1,i)))
7942       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7943       vv1(1)=pizda1(1,1)-pizda1(2,2)
7944       vv1(2)=pizda1(1,2)+pizda1(2,1)
7945       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7946       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7947       if (l.eq.j+1) then
7948         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7949      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7950      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7951      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7952      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7953       else
7954         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7955      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7956      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7957      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7958      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7959       endif
7960       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7961       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7962       vv1(1)=pizda1(1,1)-pizda1(2,2)
7963       vv1(2)=pizda1(1,2)+pizda1(2,1)
7964       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7965      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7966      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7967      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7968       do iii=1,2
7969         if (swap) then
7970           ind=3-iii
7971         else
7972           ind=iii
7973         endif
7974         do kkk=1,5
7975           do lll=1,3
7976             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7977             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7978             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7979             call transpose2(EUgC(1,1,k),auxmat(1,1))
7980             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7981      &        pizda1(1,1))
7982             vv1(1)=pizda1(1,1)-pizda1(2,2)
7983             vv1(2)=pizda1(1,2)+pizda1(2,1)
7984             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7985             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7986      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7987             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7988      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7989             s5=scalar2(vv(1),Dtobr2(1,i))
7990             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7991           enddo
7992         enddo
7993       enddo
7994       return
7995       end
7996 c----------------------------------------------------------------------------
7997       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7998       implicit real*8 (a-h,o-z)
7999       include 'DIMENSIONS'
8000       include 'COMMON.IOUNITS'
8001       include 'COMMON.CHAIN'
8002       include 'COMMON.DERIV'
8003       include 'COMMON.INTERACT'
8004       include 'COMMON.CONTACTS'
8005       include 'COMMON.TORSION'
8006       include 'COMMON.VAR'
8007       include 'COMMON.GEO'
8008       logical swap
8009       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8010      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8011       logical lprn
8012       common /kutas/ lprn
8013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8014 C
8015 C      Parallel       Antiparallel
8016 C
8017 C          o             o
8018 C     \   /l\           /j\   /
8019 C      \ /   \         /   \ /
8020 C       o| o |         | o |o
8021 C     \ j|/k\|      \  |/k\|l
8022 C      \ /   \       \ /   \
8023 C       o             o
8024 C       i             i
8025 C
8026 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8027 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8028 C AL 7/4/01 s1 would occur in the sixth-order moment,
8029 C           but not in a cluster cumulant
8030 #ifdef MOMENT
8031       s1=dip(1,jj,i)*dip(1,kk,k)
8032 #endif
8033       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8034       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8035       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8036       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8037       call transpose2(EUg(1,1,k),auxmat(1,1))
8038       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8039       vv(1)=pizda(1,1)-pizda(2,2)
8040       vv(2)=pizda(1,2)+pizda(2,1)
8041       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8042 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8043 #ifdef MOMENT
8044       eello6_graph2=-(s1+s2+s3+s4)
8045 #else
8046       eello6_graph2=-(s2+s3+s4)
8047 #endif
8048 c      eello6_graph2=-s3
8049 C Derivatives in gamma(i-1)
8050       if (i.gt.1) then
8051 #ifdef MOMENT
8052         s1=dipderg(1,jj,i)*dip(1,kk,k)
8053 #endif
8054         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8055         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8056         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8057         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8058 #ifdef MOMENT
8059         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8060 #else
8061         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8062 #endif
8063 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8064       endif
8065 C Derivatives in gamma(k-1)
8066 #ifdef MOMENT
8067       s1=dip(1,jj,i)*dipderg(1,kk,k)
8068 #endif
8069       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8070       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8071       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8072       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8073       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8074       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8075       vv(1)=pizda(1,1)-pizda(2,2)
8076       vv(2)=pizda(1,2)+pizda(2,1)
8077       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8078 #ifdef MOMENT
8079       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8080 #else
8081       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8082 #endif
8083 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8084 C Derivatives in gamma(j-1) or gamma(l-1)
8085       if (j.gt.1) then
8086 #ifdef MOMENT
8087         s1=dipderg(3,jj,i)*dip(1,kk,k)
8088 #endif
8089         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8090         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8091         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8092         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8093         vv(1)=pizda(1,1)-pizda(2,2)
8094         vv(2)=pizda(1,2)+pizda(2,1)
8095         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8096 #ifdef MOMENT
8097         if (swap) then
8098           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8099         else
8100           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8101         endif
8102 #endif
8103         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8104 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8105       endif
8106 C Derivatives in gamma(l-1) or gamma(j-1)
8107       if (l.gt.1) then
8108 #ifdef MOMENT
8109         s1=dip(1,jj,i)*dipderg(3,kk,k)
8110 #endif
8111         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8112         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8113         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8114         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8115         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8116         vv(1)=pizda(1,1)-pizda(2,2)
8117         vv(2)=pizda(1,2)+pizda(2,1)
8118         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8119 #ifdef MOMENT
8120         if (swap) then
8121           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8122         else
8123           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8124         endif
8125 #endif
8126         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8127 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8128       endif
8129 C Cartesian derivatives.
8130       if (lprn) then
8131         write (2,*) 'In eello6_graph2'
8132         do iii=1,2
8133           write (2,*) 'iii=',iii
8134           do kkk=1,5
8135             write (2,*) 'kkk=',kkk
8136             do jjj=1,2
8137               write (2,'(3(2f10.5),5x)')
8138      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8139             enddo
8140           enddo
8141         enddo
8142       endif
8143       do iii=1,2
8144         do kkk=1,5
8145           do lll=1,3
8146 #ifdef MOMENT
8147             if (iii.eq.1) then
8148               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8149             else
8150               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8151             endif
8152 #endif
8153             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8154      &        auxvec(1))
8155             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8156             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8157      &        auxvec(1))
8158             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8159             call transpose2(EUg(1,1,k),auxmat(1,1))
8160             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8161      &        pizda(1,1))
8162             vv(1)=pizda(1,1)-pizda(2,2)
8163             vv(2)=pizda(1,2)+pizda(2,1)
8164             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8165 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8166 #ifdef MOMENT
8167             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8168 #else
8169             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8170 #endif
8171             if (swap) then
8172               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8173             else
8174               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8175             endif
8176           enddo
8177         enddo
8178       enddo
8179       return
8180       end
8181 c----------------------------------------------------------------------------
8182       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8183       implicit real*8 (a-h,o-z)
8184       include 'DIMENSIONS'
8185       include 'COMMON.IOUNITS'
8186       include 'COMMON.CHAIN'
8187       include 'COMMON.DERIV'
8188       include 'COMMON.INTERACT'
8189       include 'COMMON.CONTACTS'
8190       include 'COMMON.TORSION'
8191       include 'COMMON.VAR'
8192       include 'COMMON.GEO'
8193       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8194       logical swap
8195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8196 C
8197 C      Parallel       Antiparallel
8198 C
8199 C          o             o
8200 C         /l\   /   \   /j\
8201 C        /   \ /     \ /   \
8202 C       /| o |o       o| o |\
8203 C       j|/k\|  /      |/k\|l /
8204 C        /   \ /       /   \ /
8205 C       /     o       /     o
8206 C       i             i
8207 C
8208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8209 C
8210 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8211 C           energy moment and not to the cluster cumulant.
8212       iti=itortyp(itype(i))
8213       if (j.lt.nres-1) then
8214         itj1=itortyp(itype(j+1))
8215       else
8216         itj1=ntortyp+1
8217       endif
8218       itk=itortyp(itype(k))
8219       itk1=itortyp(itype(k+1))
8220       if (l.lt.nres-1) then
8221         itl1=itortyp(itype(l+1))
8222       else
8223         itl1=ntortyp+1
8224       endif
8225 #ifdef MOMENT
8226       s1=dip(4,jj,i)*dip(4,kk,k)
8227 #endif
8228       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8229       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8230       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8231       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8232       call transpose2(EE(1,1,itk),auxmat(1,1))
8233       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8234       vv(1)=pizda(1,1)+pizda(2,2)
8235       vv(2)=pizda(2,1)-pizda(1,2)
8236       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8237 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8238 cd     & "sum",-(s2+s3+s4)
8239 #ifdef MOMENT
8240       eello6_graph3=-(s1+s2+s3+s4)
8241 #else
8242       eello6_graph3=-(s2+s3+s4)
8243 #endif
8244 c      eello6_graph3=-s4
8245 C Derivatives in gamma(k-1)
8246       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8247       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8248       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8249       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8250 C Derivatives in gamma(l-1)
8251       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8252       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8253       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8254       vv(1)=pizda(1,1)+pizda(2,2)
8255       vv(2)=pizda(2,1)-pizda(1,2)
8256       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8257       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8258 C Cartesian derivatives.
8259       do iii=1,2
8260         do kkk=1,5
8261           do lll=1,3
8262 #ifdef MOMENT
8263             if (iii.eq.1) then
8264               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8265             else
8266               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8267             endif
8268 #endif
8269             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8270      &        auxvec(1))
8271             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8272             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8273      &        auxvec(1))
8274             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8275             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8276      &        pizda(1,1))
8277             vv(1)=pizda(1,1)+pizda(2,2)
8278             vv(2)=pizda(2,1)-pizda(1,2)
8279             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8280 #ifdef MOMENT
8281             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8282 #else
8283             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8284 #endif
8285             if (swap) then
8286               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8287             else
8288               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8289             endif
8290 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8291           enddo
8292         enddo
8293       enddo
8294       return
8295       end
8296 c----------------------------------------------------------------------------
8297       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8298       implicit real*8 (a-h,o-z)
8299       include 'DIMENSIONS'
8300       include 'COMMON.IOUNITS'
8301       include 'COMMON.CHAIN'
8302       include 'COMMON.DERIV'
8303       include 'COMMON.INTERACT'
8304       include 'COMMON.CONTACTS'
8305       include 'COMMON.TORSION'
8306       include 'COMMON.VAR'
8307       include 'COMMON.GEO'
8308       include 'COMMON.FFIELD'
8309       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8310      & auxvec1(2),auxmat1(2,2)
8311       logical swap
8312 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8313 C
8314 C      Parallel       Antiparallel
8315 C
8316 C          o             o
8317 C         /l\   /   \   /j\
8318 C        /   \ /     \ /   \
8319 C       /| o |o       o| o |\
8320 C     \ j|/k\|      \  |/k\|l
8321 C      \ /   \       \ /   \
8322 C       o     \       o     \
8323 C       i             i
8324 C
8325 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8326 C
8327 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8328 C           energy moment and not to the cluster cumulant.
8329 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8330       iti=itortyp(itype(i))
8331       itj=itortyp(itype(j))
8332       if (j.lt.nres-1) then
8333         itj1=itortyp(itype(j+1))
8334       else
8335         itj1=ntortyp+1
8336       endif
8337       itk=itortyp(itype(k))
8338       if (k.lt.nres-1) then
8339         itk1=itortyp(itype(k+1))
8340       else
8341         itk1=ntortyp+1
8342       endif
8343       itl=itortyp(itype(l))
8344       if (l.lt.nres-1) then
8345         itl1=itortyp(itype(l+1))
8346       else
8347         itl1=ntortyp+1
8348       endif
8349 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8350 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8351 cd     & ' itl',itl,' itl1',itl1
8352 #ifdef MOMENT
8353       if (imat.eq.1) then
8354         s1=dip(3,jj,i)*dip(3,kk,k)
8355       else
8356         s1=dip(2,jj,j)*dip(2,kk,l)
8357       endif
8358 #endif
8359       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8360       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8361       if (j.eq.l+1) then
8362         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8363         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8364       else
8365         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8366         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8367       endif
8368       call transpose2(EUg(1,1,k),auxmat(1,1))
8369       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8370       vv(1)=pizda(1,1)-pizda(2,2)
8371       vv(2)=pizda(2,1)+pizda(1,2)
8372       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8373 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8374 #ifdef MOMENT
8375       eello6_graph4=-(s1+s2+s3+s4)
8376 #else
8377       eello6_graph4=-(s2+s3+s4)
8378 #endif
8379 C Derivatives in gamma(i-1)
8380       if (i.gt.1) then
8381 #ifdef MOMENT
8382         if (imat.eq.1) then
8383           s1=dipderg(2,jj,i)*dip(3,kk,k)
8384         else
8385           s1=dipderg(4,jj,j)*dip(2,kk,l)
8386         endif
8387 #endif
8388         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8389         if (j.eq.l+1) then
8390           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8391           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8392         else
8393           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8394           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8395         endif
8396         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8397         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8398 cd          write (2,*) 'turn6 derivatives'
8399 #ifdef MOMENT
8400           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8401 #else
8402           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8403 #endif
8404         else
8405 #ifdef MOMENT
8406           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8407 #else
8408           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8409 #endif
8410         endif
8411       endif
8412 C Derivatives in gamma(k-1)
8413 #ifdef MOMENT
8414       if (imat.eq.1) then
8415         s1=dip(3,jj,i)*dipderg(2,kk,k)
8416       else
8417         s1=dip(2,jj,j)*dipderg(4,kk,l)
8418       endif
8419 #endif
8420       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8421       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8422       if (j.eq.l+1) then
8423         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8424         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8425       else
8426         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8427         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8428       endif
8429       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8430       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8431       vv(1)=pizda(1,1)-pizda(2,2)
8432       vv(2)=pizda(2,1)+pizda(1,2)
8433       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8434       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8435 #ifdef MOMENT
8436         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8437 #else
8438         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8439 #endif
8440       else
8441 #ifdef MOMENT
8442         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8443 #else
8444         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8445 #endif
8446       endif
8447 C Derivatives in gamma(j-1) or gamma(l-1)
8448       if (l.eq.j+1 .and. l.gt.1) then
8449         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8450         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8451         call matmat2(AECAderg(1,1,imat),auxmat(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),Dtobr2(1,i))
8455         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8456       else if (j.gt.1) then
8457         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8458         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8459         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8460         vv(1)=pizda(1,1)-pizda(2,2)
8461         vv(2)=pizda(2,1)+pizda(1,2)
8462         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8463         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8464           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8465         else
8466           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8467         endif
8468       endif
8469 C Cartesian derivatives.
8470       do iii=1,2
8471         do kkk=1,5
8472           do lll=1,3
8473 #ifdef MOMENT
8474             if (iii.eq.1) then
8475               if (imat.eq.1) then
8476                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8477               else
8478                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8479               endif
8480             else
8481               if (imat.eq.1) then
8482                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8483               else
8484                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8485               endif
8486             endif
8487 #endif
8488             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8489      &        auxvec(1))
8490             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8491             if (j.eq.l+1) then
8492               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8493      &          b1(1,itj1),auxvec(1))
8494               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8495             else
8496               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8497      &          b1(1,itl1),auxvec(1))
8498               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8499             endif
8500             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8501      &        pizda(1,1))
8502             vv(1)=pizda(1,1)-pizda(2,2)
8503             vv(2)=pizda(2,1)+pizda(1,2)
8504             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8505             if (swap) then
8506               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8507 #ifdef MOMENT
8508                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8509      &             -(s1+s2+s4)
8510 #else
8511                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8512      &             -(s2+s4)
8513 #endif
8514                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8515               else
8516 #ifdef MOMENT
8517                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8518 #else
8519                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8520 #endif
8521                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8522               endif
8523             else
8524 #ifdef MOMENT
8525               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8526 #else
8527               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8528 #endif
8529               if (l.eq.j+1) then
8530                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8531               else
8532                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8533               endif
8534             endif
8535           enddo
8536         enddo
8537       enddo
8538       return
8539       end
8540 c----------------------------------------------------------------------------
8541       double precision function eello_turn6(i,jj,kk)
8542       implicit real*8 (a-h,o-z)
8543       include 'DIMENSIONS'
8544       include 'COMMON.IOUNITS'
8545       include 'COMMON.CHAIN'
8546       include 'COMMON.DERIV'
8547       include 'COMMON.INTERACT'
8548       include 'COMMON.CONTACTS'
8549       include 'COMMON.TORSION'
8550       include 'COMMON.VAR'
8551       include 'COMMON.GEO'
8552       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8553      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8554      &  ggg1(3),ggg2(3)
8555       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8556      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8557 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8558 C           the respective energy moment and not to the cluster cumulant.
8559       s1=0.0d0
8560       s8=0.0d0
8561       s13=0.0d0
8562 c
8563       eello_turn6=0.0d0
8564       j=i+4
8565       k=i+1
8566       l=i+3
8567       iti=itortyp(itype(i))
8568       itk=itortyp(itype(k))
8569       itk1=itortyp(itype(k+1))
8570       itl=itortyp(itype(l))
8571       itj=itortyp(itype(j))
8572 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8573 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8574 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8575 cd        eello6=0.0d0
8576 cd        return
8577 cd      endif
8578 cd      write (iout,*)
8579 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8580 cd     &   ' and',k,l
8581 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8582       do iii=1,2
8583         do kkk=1,5
8584           do lll=1,3
8585             derx_turn(lll,kkk,iii)=0.0d0
8586           enddo
8587         enddo
8588       enddo
8589 cd      eij=1.0d0
8590 cd      ekl=1.0d0
8591 cd      ekont=1.0d0
8592       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8593 cd      eello6_5=0.0d0
8594 cd      write (2,*) 'eello6_5',eello6_5
8595 #ifdef MOMENT
8596       call transpose2(AEA(1,1,1),auxmat(1,1))
8597       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8598       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8599       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8600 #endif
8601       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8602       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8603       s2 = scalar2(b1(1,itk),vtemp1(1))
8604 #ifdef MOMENT
8605       call transpose2(AEA(1,1,2),atemp(1,1))
8606       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8607       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8608       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8609 #endif
8610       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8611       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8612       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8613 #ifdef MOMENT
8614       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8615       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8616       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8617       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8618       ss13 = scalar2(b1(1,itk),vtemp4(1))
8619       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8620 #endif
8621 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8622 c      s1=0.0d0
8623 c      s2=0.0d0
8624 c      s8=0.0d0
8625 c      s12=0.0d0
8626 c      s13=0.0d0
8627       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8628 C Derivatives in gamma(i+2)
8629       s1d =0.0d0
8630       s8d =0.0d0
8631 #ifdef MOMENT
8632       call transpose2(AEA(1,1,1),auxmatd(1,1))
8633       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8634       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8635       call transpose2(AEAderg(1,1,2),atempd(1,1))
8636       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8637       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8638 #endif
8639       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8640       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8641       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8642 c      s1d=0.0d0
8643 c      s2d=0.0d0
8644 c      s8d=0.0d0
8645 c      s12d=0.0d0
8646 c      s13d=0.0d0
8647       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8648 C Derivatives in gamma(i+3)
8649 #ifdef MOMENT
8650       call transpose2(AEA(1,1,1),auxmatd(1,1))
8651       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8652       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8653       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8654 #endif
8655       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8656       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8657       s2d = scalar2(b1(1,itk),vtemp1d(1))
8658 #ifdef MOMENT
8659       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8660       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8661 #endif
8662       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8663 #ifdef MOMENT
8664       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8665       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8666       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8667 #endif
8668 c      s1d=0.0d0
8669 c      s2d=0.0d0
8670 c      s8d=0.0d0
8671 c      s12d=0.0d0
8672 c      s13d=0.0d0
8673 #ifdef MOMENT
8674       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8675      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8676 #else
8677       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8678      &               -0.5d0*ekont*(s2d+s12d)
8679 #endif
8680 C Derivatives in gamma(i+4)
8681       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8682       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8683       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8684 #ifdef MOMENT
8685       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8686       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8687       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8688 #endif
8689 c      s1d=0.0d0
8690 c      s2d=0.0d0
8691 c      s8d=0.0d0
8692 C      s12d=0.0d0
8693 c      s13d=0.0d0
8694 #ifdef MOMENT
8695       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8696 #else
8697       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8698 #endif
8699 C Derivatives in gamma(i+5)
8700 #ifdef MOMENT
8701       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8702       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8703       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8704 #endif
8705       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8706       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8707       s2d = scalar2(b1(1,itk),vtemp1d(1))
8708 #ifdef MOMENT
8709       call transpose2(AEA(1,1,2),atempd(1,1))
8710       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8711       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8712 #endif
8713       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8714       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8715 #ifdef MOMENT
8716       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8717       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8718       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8719 #endif
8720 c      s1d=0.0d0
8721 c      s2d=0.0d0
8722 c      s8d=0.0d0
8723 c      s12d=0.0d0
8724 c      s13d=0.0d0
8725 #ifdef MOMENT
8726       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8727      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8728 #else
8729       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8730      &               -0.5d0*ekont*(s2d+s12d)
8731 #endif
8732 C Cartesian derivatives
8733       do iii=1,2
8734         do kkk=1,5
8735           do lll=1,3
8736 #ifdef MOMENT
8737             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8738             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8739             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8740 #endif
8741             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8742             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8743      &          vtemp1d(1))
8744             s2d = scalar2(b1(1,itk),vtemp1d(1))
8745 #ifdef MOMENT
8746             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8747             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8748             s8d = -(atempd(1,1)+atempd(2,2))*
8749      &           scalar2(cc(1,1,itl),vtemp2(1))
8750 #endif
8751             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8752      &           auxmatd(1,1))
8753             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8754             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8755 c      s1d=0.0d0
8756 c      s2d=0.0d0
8757 c      s8d=0.0d0
8758 c      s12d=0.0d0
8759 c      s13d=0.0d0
8760 #ifdef MOMENT
8761             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8762      &        - 0.5d0*(s1d+s2d)
8763 #else
8764             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8765      &        - 0.5d0*s2d
8766 #endif
8767 #ifdef MOMENT
8768             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8769      &        - 0.5d0*(s8d+s12d)
8770 #else
8771             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8772      &        - 0.5d0*s12d
8773 #endif
8774           enddo
8775         enddo
8776       enddo
8777 #ifdef MOMENT
8778       do kkk=1,5
8779         do lll=1,3
8780           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8781      &      achuj_tempd(1,1))
8782           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8783           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8784           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8785           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8786           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8787      &      vtemp4d(1))
8788           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8789           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8790           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8791         enddo
8792       enddo
8793 #endif
8794 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8795 cd     &  16*eel_turn6_num
8796 cd      goto 1112
8797       if (j.lt.nres-1) then
8798         j1=j+1
8799         j2=j-1
8800       else
8801         j1=j-1
8802         j2=j-2
8803       endif
8804       if (l.lt.nres-1) then
8805         l1=l+1
8806         l2=l-1
8807       else
8808         l1=l-1
8809         l2=l-2
8810       endif
8811       do ll=1,3
8812 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8813 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8814 cgrad        ghalf=0.5d0*ggg1(ll)
8815 cd        ghalf=0.0d0
8816         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8817         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8818         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8819      &    +ekont*derx_turn(ll,2,1)
8820         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8821         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8822      &    +ekont*derx_turn(ll,4,1)
8823         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8824         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8825         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8826 cgrad        ghalf=0.5d0*ggg2(ll)
8827 cd        ghalf=0.0d0
8828         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8829      &    +ekont*derx_turn(ll,2,2)
8830         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8831         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8832      &    +ekont*derx_turn(ll,4,2)
8833         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8834         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8835         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8836       enddo
8837 cd      goto 1112
8838 cgrad      do m=i+1,j-1
8839 cgrad        do ll=1,3
8840 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8841 cgrad        enddo
8842 cgrad      enddo
8843 cgrad      do m=k+1,l-1
8844 cgrad        do ll=1,3
8845 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8846 cgrad        enddo
8847 cgrad      enddo
8848 cgrad1112  continue
8849 cgrad      do m=i+2,j2
8850 cgrad        do ll=1,3
8851 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8852 cgrad        enddo
8853 cgrad      enddo
8854 cgrad      do m=k+2,l2
8855 cgrad        do ll=1,3
8856 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8857 cgrad        enddo
8858 cgrad      enddo
8859 cd      do iii=1,nres-3
8860 cd        write (2,*) iii,g_corr6_loc(iii)
8861 cd      enddo
8862       eello_turn6=ekont*eel_turn6
8863 cd      write (2,*) 'ekont',ekont
8864 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8865       return
8866       end
8867
8868 C-----------------------------------------------------------------------------
8869       double precision function scalar(u,v)
8870 !DIR$ INLINEALWAYS scalar
8871 #ifndef OSF
8872 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8873 #endif
8874       implicit none
8875       double precision u(3),v(3)
8876 cd      double precision sc
8877 cd      integer i
8878 cd      sc=0.0d0
8879 cd      do i=1,3
8880 cd        sc=sc+u(i)*v(i)
8881 cd      enddo
8882 cd      scalar=sc
8883
8884       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8885       return
8886       end
8887 crc-------------------------------------------------
8888       SUBROUTINE MATVEC2(A1,V1,V2)
8889 !DIR$ INLINEALWAYS MATVEC2
8890 #ifndef OSF
8891 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8892 #endif
8893       implicit real*8 (a-h,o-z)
8894       include 'DIMENSIONS'
8895       DIMENSION A1(2,2),V1(2),V2(2)
8896 c      DO 1 I=1,2
8897 c        VI=0.0
8898 c        DO 3 K=1,2
8899 c    3     VI=VI+A1(I,K)*V1(K)
8900 c        Vaux(I)=VI
8901 c    1 CONTINUE
8902
8903       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8904       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8905
8906       v2(1)=vaux1
8907       v2(2)=vaux2
8908       END
8909 C---------------------------------------
8910       SUBROUTINE MATMAT2(A1,A2,A3)
8911 #ifndef OSF
8912 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8913 #endif
8914       implicit real*8 (a-h,o-z)
8915       include 'DIMENSIONS'
8916       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8917 c      DIMENSION AI3(2,2)
8918 c        DO  J=1,2
8919 c          A3IJ=0.0
8920 c          DO K=1,2
8921 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8922 c          enddo
8923 c          A3(I,J)=A3IJ
8924 c       enddo
8925 c      enddo
8926
8927       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8928       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8929       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8930       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8931
8932       A3(1,1)=AI3_11
8933       A3(2,1)=AI3_21
8934       A3(1,2)=AI3_12
8935       A3(2,2)=AI3_22
8936       END
8937
8938 c-------------------------------------------------------------------------
8939       double precision function scalar2(u,v)
8940 !DIR$ INLINEALWAYS scalar2
8941       implicit none
8942       double precision u(2),v(2)
8943       double precision sc
8944       integer i
8945       scalar2=u(1)*v(1)+u(2)*v(2)
8946       return
8947       end
8948
8949 C-----------------------------------------------------------------------------
8950
8951       subroutine transpose2(a,at)
8952 !DIR$ INLINEALWAYS transpose2
8953 #ifndef OSF
8954 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8955 #endif
8956       implicit none
8957       double precision a(2,2),at(2,2)
8958       at(1,1)=a(1,1)
8959       at(1,2)=a(2,1)
8960       at(2,1)=a(1,2)
8961       at(2,2)=a(2,2)
8962       return
8963       end
8964 c--------------------------------------------------------------------------
8965       subroutine transpose(n,a,at)
8966       implicit none
8967       integer n,i,j
8968       double precision a(n,n),at(n,n)
8969       do i=1,n
8970         do j=1,n
8971           at(j,i)=a(i,j)
8972         enddo
8973       enddo
8974       return
8975       end
8976 C---------------------------------------------------------------------------
8977       subroutine prodmat3(a1,a2,kk,transp,prod)
8978 !DIR$ INLINEALWAYS prodmat3
8979 #ifndef OSF
8980 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8981 #endif
8982       implicit none
8983       integer i,j
8984       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8985       logical transp
8986 crc      double precision auxmat(2,2),prod_(2,2)
8987
8988       if (transp) then
8989 crc        call transpose2(kk(1,1),auxmat(1,1))
8990 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8991 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8992
8993            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8994      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8995            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8996      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8997            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8998      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8999            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9000      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9001
9002       else
9003 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9004 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9005
9006            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9007      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9008            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9009      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9010            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9011      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9012            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9013      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9014
9015       endif
9016 c      call transpose2(a2(1,1),a2t(1,1))
9017
9018 crc      print *,transp
9019 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9020 crc      print *,((prod(i,j),i=1,2),j=1,2)
9021
9022       return
9023       end
9024