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      write(iout,*) '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         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4318      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4319         estr=estr+diff*diff
4320         do j=1,3
4321           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4322         enddo
4323 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4324       enddo
4325       estr=0.5d0*AKP*estr
4326 c
4327 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4328 c
4329       do i=ibond_start,ibond_end
4330         iti=itype(i)
4331         if (iti.ne.10) then
4332           nbi=nbondterm(iti)
4333           if (nbi.eq.1) then
4334             diff=vbld(i+nres)-vbldsc0(1,iti)
4335 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4336 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4337             if (energy_dec)  then
4338               write (iout,*)
4339      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4340      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4341               call flush(iout)
4342             endif
4343             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4344             do j=1,3
4345               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4346             enddo
4347           else
4348             do j=1,nbi
4349               diff=vbld(i+nres)-vbldsc0(j,iti)
4350               ud(j)=aksc(j,iti)*diff
4351               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4352             enddo
4353             uprod=u(1)
4354             do j=2,nbi
4355               uprod=uprod*u(j)
4356             enddo
4357             usum=0.0d0
4358             usumsqder=0.0d0
4359             do j=1,nbi
4360               uprod1=1.0d0
4361               uprod2=1.0d0
4362               do k=1,nbi
4363                 if (k.ne.j) then
4364                   uprod1=uprod1*u(k)
4365                   uprod2=uprod2*u(k)*u(k)
4366                 endif
4367               enddo
4368               usum=usum+uprod1
4369               usumsqder=usumsqder+ud(j)*uprod2
4370             enddo
4371             estr=estr+uprod/usum
4372             do j=1,3
4373              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4374             enddo
4375           endif
4376         endif
4377       enddo
4378       return
4379       end
4380 #ifdef CRYST_THETA
4381 C--------------------------------------------------------------------------
4382       subroutine ebend(etheta)
4383 C
4384 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4385 C angles gamma and its derivatives in consecutive thetas and gammas.
4386 C
4387       implicit real*8 (a-h,o-z)
4388       include 'DIMENSIONS'
4389       include 'COMMON.LOCAL'
4390       include 'COMMON.GEO'
4391       include 'COMMON.INTERACT'
4392       include 'COMMON.DERIV'
4393       include 'COMMON.VAR'
4394       include 'COMMON.CHAIN'
4395       include 'COMMON.IOUNITS'
4396       include 'COMMON.NAMES'
4397       include 'COMMON.FFIELD'
4398       include 'COMMON.CONTROL'
4399       common /calcthet/ term1,term2,termm,diffak,ratak,
4400      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4401      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4402       double precision y(2),z(2)
4403       delta=0.02d0*pi
4404 c      time11=dexp(-2*time)
4405 c      time12=1.0d0
4406       etheta=0.0D0
4407 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4408       do i=ithet_start,ithet_end
4409 C Zero the energy function and its derivative at 0 or pi.
4410         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4411         it=itype(i-1)
4412         if (i.gt.3) then
4413 #ifdef OSF
4414           phii=phi(i)
4415           if (phii.ne.phii) phii=150.0
4416 #else
4417           phii=phi(i)
4418 #endif
4419           y(1)=dcos(phii)
4420           y(2)=dsin(phii)
4421         else
4422           y(1)=0.0D0
4423           y(2)=0.0D0
4424         endif
4425         if (i.lt.nres) then
4426 #ifdef OSF
4427           phii1=phi(i+1)
4428           if (phii1.ne.phii1) phii1=150.0
4429           phii1=pinorm(phii1)
4430           z(1)=cos(phii1)
4431 #else
4432           phii1=phi(i+1)
4433           z(1)=dcos(phii1)
4434 #endif
4435           z(2)=dsin(phii1)
4436         else
4437           z(1)=0.0D0
4438           z(2)=0.0D0
4439         endif
4440 C Calculate the "mean" value of theta from the part of the distribution
4441 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4442 C In following comments this theta will be referred to as t_c.
4443         thet_pred_mean=0.0d0
4444         do k=1,2
4445           athetk=athet(k,it)
4446           bthetk=bthet(k,it)
4447           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4448         enddo
4449         dthett=thet_pred_mean*ssd
4450         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4451 C Derivatives of the "mean" values in gamma1 and gamma2.
4452         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4453         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4454         if (theta(i).gt.pi-delta) then
4455           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4456      &         E_tc0)
4457           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4458           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4459           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4460      &        E_theta)
4461           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4462      &        E_tc)
4463         else if (theta(i).lt.delta) then
4464           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4465           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4466           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4467      &        E_theta)
4468           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4469           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4470      &        E_tc)
4471         else
4472           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4473      &        E_theta,E_tc)
4474         endif
4475         etheta=etheta+ethetai
4476         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4477      &      'ebend',i,ethetai
4478         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4479         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4480         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4481       enddo
4482 C Ufff.... We've done all this!!!
4483       return
4484       end
4485 C---------------------------------------------------------------------------
4486       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4487      &     E_tc)
4488       implicit real*8 (a-h,o-z)
4489       include 'DIMENSIONS'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.IOUNITS'
4492       common /calcthet/ term1,term2,termm,diffak,ratak,
4493      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4494      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4495 C Calculate the contributions to both Gaussian lobes.
4496 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4497 C The "polynomial part" of the "standard deviation" of this part of
4498 C the distribution.
4499         sig=polthet(3,it)
4500         do j=2,0,-1
4501           sig=sig*thet_pred_mean+polthet(j,it)
4502         enddo
4503 C Derivative of the "interior part" of the "standard deviation of the"
4504 C gamma-dependent Gaussian lobe in t_c.
4505         sigtc=3*polthet(3,it)
4506         do j=2,1,-1
4507           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4508         enddo
4509         sigtc=sig*sigtc
4510 C Set the parameters of both Gaussian lobes of the distribution.
4511 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4512         fac=sig*sig+sigc0(it)
4513         sigcsq=fac+fac
4514         sigc=1.0D0/sigcsq
4515 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4516         sigsqtc=-4.0D0*sigcsq*sigtc
4517 c       print *,i,sig,sigtc,sigsqtc
4518 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4519         sigtc=-sigtc/(fac*fac)
4520 C Following variable is sigma(t_c)**(-2)
4521         sigcsq=sigcsq*sigcsq
4522         sig0i=sig0(it)
4523         sig0inv=1.0D0/sig0i**2
4524         delthec=thetai-thet_pred_mean
4525         delthe0=thetai-theta0i
4526         term1=-0.5D0*sigcsq*delthec*delthec
4527         term2=-0.5D0*sig0inv*delthe0*delthe0
4528 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4529 C NaNs in taking the logarithm. We extract the largest exponent which is added
4530 C to the energy (this being the log of the distribution) at the end of energy
4531 C term evaluation for this virtual-bond angle.
4532         if (term1.gt.term2) then
4533           termm=term1
4534           term2=dexp(term2-termm)
4535           term1=1.0d0
4536         else
4537           termm=term2
4538           term1=dexp(term1-termm)
4539           term2=1.0d0
4540         endif
4541 C The ratio between the gamma-independent and gamma-dependent lobes of
4542 C the distribution is a Gaussian function of thet_pred_mean too.
4543         diffak=gthet(2,it)-thet_pred_mean
4544         ratak=diffak/gthet(3,it)**2
4545         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4546 C Let's differentiate it in thet_pred_mean NOW.
4547         aktc=ak*ratak
4548 C Now put together the distribution terms to make complete distribution.
4549         termexp=term1+ak*term2
4550         termpre=sigc+ak*sig0i
4551 C Contribution of the bending energy from this theta is just the -log of
4552 C the sum of the contributions from the two lobes and the pre-exponential
4553 C factor. Simple enough, isn't it?
4554         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4555 C NOW the derivatives!!!
4556 C 6/6/97 Take into account the deformation.
4557         E_theta=(delthec*sigcsq*term1
4558      &       +ak*delthe0*sig0inv*term2)/termexp
4559         E_tc=((sigtc+aktc*sig0i)/termpre
4560      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4561      &       aktc*term2)/termexp)
4562       return
4563       end
4564 c-----------------------------------------------------------------------------
4565       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4566       implicit real*8 (a-h,o-z)
4567       include 'DIMENSIONS'
4568       include 'COMMON.LOCAL'
4569       include 'COMMON.IOUNITS'
4570       common /calcthet/ term1,term2,termm,diffak,ratak,
4571      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4572      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4573       delthec=thetai-thet_pred_mean
4574       delthe0=thetai-theta0i
4575 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4576       t3 = thetai-thet_pred_mean
4577       t6 = t3**2
4578       t9 = term1
4579       t12 = t3*sigcsq
4580       t14 = t12+t6*sigsqtc
4581       t16 = 1.0d0
4582       t21 = thetai-theta0i
4583       t23 = t21**2
4584       t26 = term2
4585       t27 = t21*t26
4586       t32 = termexp
4587       t40 = t32**2
4588       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4589      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4590      & *(-t12*t9-ak*sig0inv*t27)
4591       return
4592       end
4593 #else
4594 C--------------------------------------------------------------------------
4595       subroutine ebend(etheta)
4596 C
4597 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4598 C angles gamma and its derivatives in consecutive thetas and gammas.
4599 C ab initio-derived potentials from
4600 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4601 C
4602       implicit real*8 (a-h,o-z)
4603       include 'DIMENSIONS'
4604       include 'COMMON.LOCAL'
4605       include 'COMMON.GEO'
4606       include 'COMMON.INTERACT'
4607       include 'COMMON.DERIV'
4608       include 'COMMON.VAR'
4609       include 'COMMON.CHAIN'
4610       include 'COMMON.IOUNITS'
4611       include 'COMMON.NAMES'
4612       include 'COMMON.FFIELD'
4613       include 'COMMON.CONTROL'
4614       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4615      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4616      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4617      & sinph1ph2(maxdouble,maxdouble)
4618       logical lprn /.false./, lprn1 /.false./
4619       etheta=0.0D0
4620       do i=ithet_start,ithet_end
4621         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4622      &(itype(i).eq.ntyp1)) cycle
4623         dethetai=0.0d0
4624         dephii=0.0d0
4625         dephii1=0.0d0
4626         theti2=0.5d0*theta(i)
4627         ityp2=ithetyp(itype(i-1))
4628         do k=1,nntheterm
4629           coskt(k)=dcos(k*theti2)
4630           sinkt(k)=dsin(k*theti2)
4631         enddo
4632 C        if (i.gt.3) then
4633         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4634 #ifdef OSF
4635           phii=phi(i)
4636           if (phii.ne.phii) phii=150.0
4637 #else
4638           phii=phi(i)
4639 #endif
4640           ityp1=ithetyp(itype(i-2))
4641           do k=1,nsingle
4642             cosph1(k)=dcos(k*phii)
4643             sinph1(k)=dsin(k*phii)
4644           enddo
4645         else
4646           phii=0.0d0
4647           ityp1=ithetyp(itype(i-2))
4648           do k=1,nsingle
4649             cosph1(k)=0.0d0
4650             sinph1(k)=0.0d0
4651           enddo
4652         endif
4653         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4654 #ifdef OSF
4655           phii1=phi(i+1)
4656           if (phii1.ne.phii1) phii1=150.0
4657           phii1=pinorm(phii1)
4658 #else
4659           phii1=phi(i+1)
4660 #endif
4661           ityp3=ithetyp(itype(i))
4662           do k=1,nsingle
4663             cosph2(k)=dcos(k*phii1)
4664             sinph2(k)=dsin(k*phii1)
4665           enddo
4666         else
4667           phii1=0.0d0
4668           ityp3=ithetyp(itype(i))
4669           do k=1,nsingle
4670             cosph2(k)=0.0d0
4671             sinph2(k)=0.0d0
4672           enddo
4673         endif
4674         ethetai=aa0thet(ityp1,ityp2,ityp3)
4675         do k=1,ndouble
4676           do l=1,k-1
4677             ccl=cosph1(l)*cosph2(k-l)
4678             ssl=sinph1(l)*sinph2(k-l)
4679             scl=sinph1(l)*cosph2(k-l)
4680             csl=cosph1(l)*sinph2(k-l)
4681             cosph1ph2(l,k)=ccl-ssl
4682             cosph1ph2(k,l)=ccl+ssl
4683             sinph1ph2(l,k)=scl+csl
4684             sinph1ph2(k,l)=scl-csl
4685           enddo
4686         enddo
4687         if (lprn) then
4688         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4689      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4690         write (iout,*) "coskt and sinkt"
4691         do k=1,nntheterm
4692           write (iout,*) k,coskt(k),sinkt(k)
4693         enddo
4694         endif
4695         do k=1,ntheterm
4696           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4697           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4698      &      *coskt(k)
4699           if (lprn)
4700      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4701      &     " ethetai",ethetai
4702         enddo
4703         if (lprn) then
4704         write (iout,*) "cosph and sinph"
4705         do k=1,nsingle
4706           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4707         enddo
4708         write (iout,*) "cosph1ph2 and sinph2ph2"
4709         do k=2,ndouble
4710           do l=1,k-1
4711             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4712      &         sinph1ph2(l,k),sinph1ph2(k,l)
4713           enddo
4714         enddo
4715         write(iout,*) "ethetai",ethetai
4716         endif
4717         do m=1,ntheterm2
4718           do k=1,nsingle
4719             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4720      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4721      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4722      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4723             ethetai=ethetai+sinkt(m)*aux
4724             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4725             dephii=dephii+k*sinkt(m)*(
4726      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4727      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4728             dephii1=dephii1+k*sinkt(m)*(
4729      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4730      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4731             if (lprn)
4732      &      write (iout,*) "m",m," k",k," bbthet",
4733      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4734      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4735      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4736      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4737           enddo
4738         enddo
4739         if (lprn)
4740      &  write(iout,*) "ethetai",ethetai
4741         do m=1,ntheterm3
4742           do k=2,ndouble
4743             do l=1,k-1
4744               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4745      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4746      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4747      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4748               ethetai=ethetai+sinkt(m)*aux
4749               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4750               dephii=dephii+l*sinkt(m)*(
4751      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4752      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4753      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4754      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4755               dephii1=dephii1+(k-l)*sinkt(m)*(
4756      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4757      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4758      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4759      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4760               if (lprn) then
4761               write (iout,*) "m",m," k",k," l",l," ffthet",
4762      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4763      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4764      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4765      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4766               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4767      &            cosph1ph2(k,l)*sinkt(m),
4768      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4769               endif
4770             enddo
4771           enddo
4772         enddo
4773 10      continue
4774         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4775      &   i,theta(i)*rad2deg,phii*rad2deg,
4776      &   phii1*rad2deg,ethetai
4777         etheta=etheta+ethetai
4778         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4779      &      'ebend',i,ethetai
4780         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4781         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4782         gloc(nphi+i-2,icg)=wang*dethetai
4783       enddo
4784       return
4785       end
4786 #endif
4787 #ifdef CRYST_SC
4788 c-----------------------------------------------------------------------------
4789       subroutine esc(escloc)
4790 C Calculate the local energy of a side chain and its derivatives in the
4791 C corresponding virtual-bond valence angles THETA and the spherical angles
4792 C ALPHA and OMEGA.
4793       implicit real*8 (a-h,o-z)
4794       include 'DIMENSIONS'
4795       include 'COMMON.GEO'
4796       include 'COMMON.LOCAL'
4797       include 'COMMON.VAR'
4798       include 'COMMON.INTERACT'
4799       include 'COMMON.DERIV'
4800       include 'COMMON.CHAIN'
4801       include 'COMMON.IOUNITS'
4802       include 'COMMON.NAMES'
4803       include 'COMMON.FFIELD'
4804       include 'COMMON.CONTROL'
4805       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4806      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4807       common /sccalc/ time11,time12,time112,theti,it,nlobit
4808       delta=0.02d0*pi
4809       escloc=0.0D0
4810 c     write (iout,'(a)') 'ESC'
4811       do i=loc_start,loc_end
4812         it=itype(i)
4813         if (it.eq.10) goto 1
4814         nlobit=nlob(it)
4815 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4816 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4817         theti=theta(i+1)-pipol
4818         x(1)=dtan(theti)
4819         x(2)=alph(i)
4820         x(3)=omeg(i)
4821
4822         if (x(2).gt.pi-delta) then
4823           xtemp(1)=x(1)
4824           xtemp(2)=pi-delta
4825           xtemp(3)=x(3)
4826           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4827           xtemp(2)=pi
4828           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4829           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4830      &        escloci,dersc(2))
4831           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4832      &        ddersc0(1),dersc(1))
4833           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4834      &        ddersc0(3),dersc(3))
4835           xtemp(2)=pi-delta
4836           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4837           xtemp(2)=pi
4838           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4839           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4840      &            dersc0(2),esclocbi,dersc02)
4841           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4842      &            dersc12,dersc01)
4843           call splinthet(x(2),0.5d0*delta,ss,ssd)
4844           dersc0(1)=dersc01
4845           dersc0(2)=dersc02
4846           dersc0(3)=0.0d0
4847           do k=1,3
4848             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4849           enddo
4850           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4851 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4852 c    &             esclocbi,ss,ssd
4853           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4854 c         escloci=esclocbi
4855 c         write (iout,*) escloci
4856         else if (x(2).lt.delta) then
4857           xtemp(1)=x(1)
4858           xtemp(2)=delta
4859           xtemp(3)=x(3)
4860           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4861           xtemp(2)=0.0d0
4862           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4863           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4864      &        escloci,dersc(2))
4865           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4866      &        ddersc0(1),dersc(1))
4867           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4868      &        ddersc0(3),dersc(3))
4869           xtemp(2)=delta
4870           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4871           xtemp(2)=0.0d0
4872           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4873           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4874      &            dersc0(2),esclocbi,dersc02)
4875           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4876      &            dersc12,dersc01)
4877           dersc0(1)=dersc01
4878           dersc0(2)=dersc02
4879           dersc0(3)=0.0d0
4880           call splinthet(x(2),0.5d0*delta,ss,ssd)
4881           do k=1,3
4882             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4883           enddo
4884           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4885 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4886 c    &             esclocbi,ss,ssd
4887           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4888 c         write (iout,*) escloci
4889         else
4890           call enesc(x,escloci,dersc,ddummy,.false.)
4891         endif
4892
4893         escloc=escloc+escloci
4894         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4895      &     'escloc',i,escloci
4896 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4897
4898         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4899      &   wscloc*dersc(1)
4900         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4901         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4902     1   continue
4903       enddo
4904       return
4905       end
4906 C---------------------------------------------------------------------------
4907       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4908       implicit real*8 (a-h,o-z)
4909       include 'DIMENSIONS'
4910       include 'COMMON.GEO'
4911       include 'COMMON.LOCAL'
4912       include 'COMMON.IOUNITS'
4913       common /sccalc/ time11,time12,time112,theti,it,nlobit
4914       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4915       double precision contr(maxlob,-1:1)
4916       logical mixed
4917 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4918         escloc_i=0.0D0
4919         do j=1,3
4920           dersc(j)=0.0D0
4921           if (mixed) ddersc(j)=0.0d0
4922         enddo
4923         x3=x(3)
4924
4925 C Because of periodicity of the dependence of the SC energy in omega we have
4926 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4927 C To avoid underflows, first compute & store the exponents.
4928
4929         do iii=-1,1
4930
4931           x(3)=x3+iii*dwapi
4932
4933           do j=1,nlobit
4934             do k=1,3
4935               z(k)=x(k)-censc(k,j,it)
4936             enddo
4937             do k=1,3
4938               Axk=0.0D0
4939               do l=1,3
4940                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4941               enddo
4942               Ax(k,j,iii)=Axk
4943             enddo
4944             expfac=0.0D0
4945             do k=1,3
4946               expfac=expfac+Ax(k,j,iii)*z(k)
4947             enddo
4948             contr(j,iii)=expfac
4949           enddo ! j
4950
4951         enddo ! iii
4952
4953         x(3)=x3
4954 C As in the case of ebend, we want to avoid underflows in exponentiation and
4955 C subsequent NaNs and INFs in energy calculation.
4956 C Find the largest exponent
4957         emin=contr(1,-1)
4958         do iii=-1,1
4959           do j=1,nlobit
4960             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4961           enddo
4962         enddo
4963         emin=0.5D0*emin
4964 cd      print *,'it=',it,' emin=',emin
4965
4966 C Compute the contribution to SC energy and derivatives
4967         do iii=-1,1
4968
4969           do j=1,nlobit
4970 #ifdef OSF
4971             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4972             if(adexp.ne.adexp) adexp=1.0
4973             expfac=dexp(adexp)
4974 #else
4975             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4976 #endif
4977 cd          print *,'j=',j,' expfac=',expfac
4978             escloc_i=escloc_i+expfac
4979             do k=1,3
4980               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4981             enddo
4982             if (mixed) then
4983               do k=1,3,2
4984                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4985      &            +gaussc(k,2,j,it))*expfac
4986               enddo
4987             endif
4988           enddo
4989
4990         enddo ! iii
4991
4992         dersc(1)=dersc(1)/cos(theti)**2
4993         ddersc(1)=ddersc(1)/cos(theti)**2
4994         ddersc(3)=ddersc(3)
4995
4996         escloci=-(dlog(escloc_i)-emin)
4997         do j=1,3
4998           dersc(j)=dersc(j)/escloc_i
4999         enddo
5000         if (mixed) then
5001           do j=1,3,2
5002             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5003           enddo
5004         endif
5005       return
5006       end
5007 C------------------------------------------------------------------------------
5008       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5009       implicit real*8 (a-h,o-z)
5010       include 'DIMENSIONS'
5011       include 'COMMON.GEO'
5012       include 'COMMON.LOCAL'
5013       include 'COMMON.IOUNITS'
5014       common /sccalc/ time11,time12,time112,theti,it,nlobit
5015       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5016       double precision contr(maxlob)
5017       logical mixed
5018
5019       escloc_i=0.0D0
5020
5021       do j=1,3
5022         dersc(j)=0.0D0
5023       enddo
5024
5025       do j=1,nlobit
5026         do k=1,2
5027           z(k)=x(k)-censc(k,j,it)
5028         enddo
5029         z(3)=dwapi
5030         do k=1,3
5031           Axk=0.0D0
5032           do l=1,3
5033             Axk=Axk+gaussc(l,k,j,it)*z(l)
5034           enddo
5035           Ax(k,j)=Axk
5036         enddo
5037         expfac=0.0D0
5038         do k=1,3
5039           expfac=expfac+Ax(k,j)*z(k)
5040         enddo
5041         contr(j)=expfac
5042       enddo ! j
5043
5044 C As in the case of ebend, we want to avoid underflows in exponentiation and
5045 C subsequent NaNs and INFs in energy calculation.
5046 C Find the largest exponent
5047       emin=contr(1)
5048       do j=1,nlobit
5049         if (emin.gt.contr(j)) emin=contr(j)
5050       enddo
5051       emin=0.5D0*emin
5052
5053 C Compute the contribution to SC energy and derivatives
5054
5055       dersc12=0.0d0
5056       do j=1,nlobit
5057         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5058         escloc_i=escloc_i+expfac
5059         do k=1,2
5060           dersc(k)=dersc(k)+Ax(k,j)*expfac
5061         enddo
5062         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5063      &            +gaussc(1,2,j,it))*expfac
5064         dersc(3)=0.0d0
5065       enddo
5066
5067       dersc(1)=dersc(1)/cos(theti)**2
5068       dersc12=dersc12/cos(theti)**2
5069       escloci=-(dlog(escloc_i)-emin)
5070       do j=1,2
5071         dersc(j)=dersc(j)/escloc_i
5072       enddo
5073       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5074       return
5075       end
5076 #else
5077 c----------------------------------------------------------------------------------
5078       subroutine esc(escloc)
5079 C Calculate the local energy of a side chain and its derivatives in the
5080 C corresponding virtual-bond valence angles THETA and the spherical angles
5081 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5082 C added by Urszula Kozlowska. 07/11/2007
5083 C
5084       implicit real*8 (a-h,o-z)
5085       include 'DIMENSIONS'
5086       include 'COMMON.GEO'
5087       include 'COMMON.LOCAL'
5088       include 'COMMON.VAR'
5089       include 'COMMON.SCROT'
5090       include 'COMMON.INTERACT'
5091       include 'COMMON.DERIV'
5092       include 'COMMON.CHAIN'
5093       include 'COMMON.IOUNITS'
5094       include 'COMMON.NAMES'
5095       include 'COMMON.FFIELD'
5096       include 'COMMON.CONTROL'
5097       include 'COMMON.VECTORS'
5098       double precision x_prime(3),y_prime(3),z_prime(3)
5099      &    , sumene,dsc_i,dp2_i,x(65),
5100      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5101      &    de_dxx,de_dyy,de_dzz,de_dt
5102       double precision s1_t,s1_6_t,s2_t,s2_6_t
5103       double precision
5104      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5105      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5106      & dt_dCi(3),dt_dCi1(3)
5107       common /sccalc/ time11,time12,time112,theti,it,nlobit
5108       delta=0.02d0*pi
5109       escloc=0.0D0
5110       do i=loc_start,loc_end
5111         costtab(i+1) =dcos(theta(i+1))
5112         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5113         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5114         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5115         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5116         cosfac=dsqrt(cosfac2)
5117         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5118         sinfac=dsqrt(sinfac2)
5119         it=itype(i)
5120         if (it.eq.10) goto 1
5121 c
5122 C  Compute the axes of tghe local cartesian coordinates system; store in
5123 c   x_prime, y_prime and z_prime
5124 c
5125         do j=1,3
5126           x_prime(j) = 0.00
5127           y_prime(j) = 0.00
5128           z_prime(j) = 0.00
5129         enddo
5130 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5131 C     &   dc_norm(3,i+nres)
5132         do j = 1,3
5133           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5134           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5135         enddo
5136         do j = 1,3
5137           z_prime(j) = -uz(j,i-1)
5138         enddo
5139 c       write (2,*) "i",i
5140 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5141 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5142 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5143 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5144 c      & " xy",scalar(x_prime(1),y_prime(1)),
5145 c      & " xz",scalar(x_prime(1),z_prime(1)),
5146 c      & " yy",scalar(y_prime(1),y_prime(1)),
5147 c      & " yz",scalar(y_prime(1),z_prime(1)),
5148 c      & " zz",scalar(z_prime(1),z_prime(1))
5149 c
5150 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5151 C to local coordinate system. Store in xx, yy, zz.
5152 c
5153         xx=0.0d0
5154         yy=0.0d0
5155         zz=0.0d0
5156         do j = 1,3
5157           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5158           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5159           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5160         enddo
5161
5162         xxtab(i)=xx
5163         yytab(i)=yy
5164         zztab(i)=zz
5165 C
5166 C Compute the energy of the ith side cbain
5167 C
5168 c        write (2,*) "xx",xx," yy",yy," zz",zz
5169         it=itype(i)
5170         do j = 1,65
5171           x(j) = sc_parmin(j,it)
5172         enddo
5173 #ifdef CHECK_COORD
5174 Cc diagnostics - remove later
5175         xx1 = dcos(alph(2))
5176         yy1 = dsin(alph(2))*dcos(omeg(2))
5177         zz1 = -dsin(alph(2))*dsin(omeg(2))
5178         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5179      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5180      &    xx1,yy1,zz1
5181 C,"  --- ", xx_w,yy_w,zz_w
5182 c end diagnostics
5183 #endif
5184         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5185      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5186      &   + x(10)*yy*zz
5187         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5188      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5189      & + x(20)*yy*zz
5190         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5191      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5192      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5193      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5194      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5195      &  +x(40)*xx*yy*zz
5196         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5197      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5198      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5199      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5200      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5201      &  +x(60)*xx*yy*zz
5202         dsc_i   = 0.743d0+x(61)
5203         dp2_i   = 1.9d0+x(62)
5204         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5205      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5206         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5207      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5208         s1=(1+x(63))/(0.1d0 + dscp1)
5209         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5210         s2=(1+x(65))/(0.1d0 + dscp2)
5211         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5212         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5213      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5214 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5215 c     &   sumene4,
5216 c     &   dscp1,dscp2,sumene
5217 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5218         escloc = escloc + sumene
5219 c        write (2,*) "i",i," escloc",sumene,escloc
5220 #ifdef DEBUG
5221 C
5222 C This section to check the numerical derivatives of the energy of ith side
5223 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5224 C #define DEBUG in the code to turn it on.
5225 C
5226         write (2,*) "sumene               =",sumene
5227         aincr=1.0d-7
5228         xxsave=xx
5229         xx=xx+aincr
5230         write (2,*) xx,yy,zz
5231         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5232         de_dxx_num=(sumenep-sumene)/aincr
5233         xx=xxsave
5234         write (2,*) "xx+ sumene from enesc=",sumenep
5235         yysave=yy
5236         yy=yy+aincr
5237         write (2,*) xx,yy,zz
5238         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5239         de_dyy_num=(sumenep-sumene)/aincr
5240         yy=yysave
5241         write (2,*) "yy+ sumene from enesc=",sumenep
5242         zzsave=zz
5243         zz=zz+aincr
5244         write (2,*) xx,yy,zz
5245         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5246         de_dzz_num=(sumenep-sumene)/aincr
5247         zz=zzsave
5248         write (2,*) "zz+ sumene from enesc=",sumenep
5249         costsave=cost2tab(i+1)
5250         sintsave=sint2tab(i+1)
5251         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5252         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5253         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5254         de_dt_num=(sumenep-sumene)/aincr
5255         write (2,*) " t+ sumene from enesc=",sumenep
5256         cost2tab(i+1)=costsave
5257         sint2tab(i+1)=sintsave
5258 C End of diagnostics section.
5259 #endif
5260 C
5261 C Compute the gradient of esc
5262 C
5263         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5264         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5265         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5266         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5267         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5268         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5269         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5270         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5271         pom1=(sumene3*sint2tab(i+1)+sumene1)
5272      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5273         pom2=(sumene4*cost2tab(i+1)+sumene2)
5274      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5275         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5276         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5277      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5278      &  +x(40)*yy*zz
5279         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5280         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5281      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5282      &  +x(60)*yy*zz
5283         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5284      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5285      &        +(pom1+pom2)*pom_dx
5286 #ifdef DEBUG
5287         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5288 #endif
5289 C
5290         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5291         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5292      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5293      &  +x(40)*xx*zz
5294         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5295         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5296      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5297      &  +x(59)*zz**2 +x(60)*xx*zz
5298         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5299      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5300      &        +(pom1-pom2)*pom_dy
5301 #ifdef DEBUG
5302         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5303 #endif
5304 C
5305         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5306      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5307      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5308      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5309      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5310      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5311      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5312      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5313 #ifdef DEBUG
5314         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5315 #endif
5316 C
5317         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5318      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5319      &  +pom1*pom_dt1+pom2*pom_dt2
5320 #ifdef DEBUG
5321         write(2,*), "de_dt = ", de_dt,de_dt_num
5322 #endif
5323 c
5324 C
5325        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5326        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5327        cosfac2xx=cosfac2*xx
5328        sinfac2yy=sinfac2*yy
5329        do k = 1,3
5330          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5331      &      vbld_inv(i+1)
5332          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5333      &      vbld_inv(i)
5334          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5335          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5336 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5337 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5338 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5339 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5340          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5341          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5342          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5343          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5344          dZZ_Ci1(k)=0.0d0
5345          dZZ_Ci(k)=0.0d0
5346          do j=1,3
5347            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5348            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5349          enddo
5350
5351          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5352          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5353          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5354 c
5355          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5356          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5357        enddo
5358
5359        do k=1,3
5360          dXX_Ctab(k,i)=dXX_Ci(k)
5361          dXX_C1tab(k,i)=dXX_Ci1(k)
5362          dYY_Ctab(k,i)=dYY_Ci(k)
5363          dYY_C1tab(k,i)=dYY_Ci1(k)
5364          dZZ_Ctab(k,i)=dZZ_Ci(k)
5365          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5366          dXX_XYZtab(k,i)=dXX_XYZ(k)
5367          dYY_XYZtab(k,i)=dYY_XYZ(k)
5368          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5369        enddo
5370
5371        do k = 1,3
5372 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5373 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5374 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5375 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5376 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5377 c     &    dt_dci(k)
5378 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5379 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5380          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5381      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5382          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5383      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5384          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5385      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5386        enddo
5387 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5388 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5389
5390 C to check gradient call subroutine check_grad
5391
5392     1 continue
5393       enddo
5394       return
5395       end
5396 c------------------------------------------------------------------------------
5397       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5398       implicit none
5399       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5400      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5401       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5402      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5403      &   + x(10)*yy*zz
5404       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5405      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5406      & + x(20)*yy*zz
5407       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5408      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5409      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5410      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5411      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5412      &  +x(40)*xx*yy*zz
5413       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5414      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5415      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5416      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5417      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5418      &  +x(60)*xx*yy*zz
5419       dsc_i   = 0.743d0+x(61)
5420       dp2_i   = 1.9d0+x(62)
5421       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5422      &          *(xx*cost2+yy*sint2))
5423       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5424      &          *(xx*cost2-yy*sint2))
5425       s1=(1+x(63))/(0.1d0 + dscp1)
5426       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5427       s2=(1+x(65))/(0.1d0 + dscp2)
5428       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5429       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5430      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5431       enesc=sumene
5432       return
5433       end
5434 #endif
5435 c------------------------------------------------------------------------------
5436       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5437 C
5438 C This procedure calculates two-body contact function g(rij) and its derivative:
5439 C
5440 C           eps0ij                                     !       x < -1
5441 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5442 C            0                                         !       x > 1
5443 C
5444 C where x=(rij-r0ij)/delta
5445 C
5446 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5447 C
5448       implicit none
5449       double precision rij,r0ij,eps0ij,fcont,fprimcont
5450       double precision x,x2,x4,delta
5451 c     delta=0.02D0*r0ij
5452 c      delta=0.2D0*r0ij
5453       x=(rij-r0ij)/delta
5454       if (x.lt.-1.0D0) then
5455         fcont=eps0ij
5456         fprimcont=0.0D0
5457       else if (x.le.1.0D0) then
5458         x2=x*x
5459         x4=x2*x2
5460         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5461         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5462       else
5463         fcont=0.0D0
5464         fprimcont=0.0D0
5465       endif
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       subroutine splinthet(theti,delta,ss,ssder)
5470       implicit real*8 (a-h,o-z)
5471       include 'DIMENSIONS'
5472       include 'COMMON.VAR'
5473       include 'COMMON.GEO'
5474       thetup=pi-delta
5475       thetlow=delta
5476       if (theti.gt.pipol) then
5477         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5478       else
5479         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5480         ssder=-ssder
5481       endif
5482       return
5483       end
5484 c------------------------------------------------------------------------------
5485       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5486       implicit none
5487       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5488       double precision ksi,ksi2,ksi3,a1,a2,a3
5489       a1=fprim0*delta/(f1-f0)
5490       a2=3.0d0-2.0d0*a1
5491       a3=a1-2.0d0
5492       ksi=(x-x0)/delta
5493       ksi2=ksi*ksi
5494       ksi3=ksi2*ksi
5495       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5496       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5497       return
5498       end
5499 c------------------------------------------------------------------------------
5500       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5501       implicit none
5502       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5503       double precision ksi,ksi2,ksi3,a1,a2,a3
5504       ksi=(x-x0)/delta
5505       ksi2=ksi*ksi
5506       ksi3=ksi2*ksi
5507       a1=fprim0x*delta
5508       a2=3*(f1x-f0x)-2*fprim0x*delta
5509       a3=fprim0x*delta-2*(f1x-f0x)
5510       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5511       return
5512       end
5513 C-----------------------------------------------------------------------------
5514 #ifdef CRYST_TOR
5515 C-----------------------------------------------------------------------------
5516       subroutine etor(etors,edihcnstr)
5517       implicit real*8 (a-h,o-z)
5518       include 'DIMENSIONS'
5519       include 'COMMON.VAR'
5520       include 'COMMON.GEO'
5521       include 'COMMON.LOCAL'
5522       include 'COMMON.TORSION'
5523       include 'COMMON.INTERACT'
5524       include 'COMMON.DERIV'
5525       include 'COMMON.CHAIN'
5526       include 'COMMON.NAMES'
5527       include 'COMMON.IOUNITS'
5528       include 'COMMON.FFIELD'
5529       include 'COMMON.TORCNSTR'
5530       include 'COMMON.CONTROL'
5531       logical lprn
5532 C Set lprn=.true. for debugging
5533       lprn=.false.
5534 c      lprn=.true.
5535       etors=0.0D0
5536       do i=iphi_start,iphi_end
5537       etors_ii=0.0D0
5538         itori=itortyp(itype(i-2))
5539         itori1=itortyp(itype(i-1))
5540         phii=phi(i)
5541         gloci=0.0D0
5542 C Proline-Proline pair is a special case...
5543         if (itori.eq.3 .and. itori1.eq.3) then
5544           if (phii.gt.-dwapi3) then
5545             cosphi=dcos(3*phii)
5546             fac=1.0D0/(1.0D0-cosphi)
5547             etorsi=v1(1,3,3)*fac
5548             etorsi=etorsi+etorsi
5549             etors=etors+etorsi-v1(1,3,3)
5550             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5551             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5552           endif
5553           do j=1,3
5554             v1ij=v1(j+1,itori,itori1)
5555             v2ij=v2(j+1,itori,itori1)
5556             cosphi=dcos(j*phii)
5557             sinphi=dsin(j*phii)
5558             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5559             if (energy_dec) etors_ii=etors_ii+
5560      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5561             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5562           enddo
5563         else
5564           do j=1,nterm_old
5565             v1ij=v1(j,itori,itori1)
5566             v2ij=v2(j,itori,itori1)
5567             cosphi=dcos(j*phii)
5568             sinphi=dsin(j*phii)
5569             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5570             if (energy_dec) etors_ii=etors_ii+
5571      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5572             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5573           enddo
5574         endif
5575         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5576      &        'etor',i,etors_ii
5577         if (lprn)
5578      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5579      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5580      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5581         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5582 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5583       enddo
5584 ! 6/20/98 - dihedral angle constraints
5585       edihcnstr=0.0d0
5586       do i=1,ndih_constr
5587         itori=idih_constr(i)
5588         phii=phi(itori)
5589         difi=phii-phi0(i)
5590         if (difi.gt.drange(i)) then
5591           difi=difi-drange(i)
5592           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5593           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5594         else if (difi.lt.-drange(i)) then
5595           difi=difi+drange(i)
5596           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5597           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5598         endif
5599 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5600 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5601       enddo
5602 !      write (iout,*) 'edihcnstr',edihcnstr
5603       return
5604       end
5605 c------------------------------------------------------------------------------
5606       subroutine etor_d(etors_d)
5607       etors_d=0.0d0
5608       return
5609       end
5610 c----------------------------------------------------------------------------
5611 #else
5612       subroutine etor(etors,edihcnstr)
5613       implicit real*8 (a-h,o-z)
5614       include 'DIMENSIONS'
5615       include 'COMMON.VAR'
5616       include 'COMMON.GEO'
5617       include 'COMMON.LOCAL'
5618       include 'COMMON.TORSION'
5619       include 'COMMON.INTERACT'
5620       include 'COMMON.DERIV'
5621       include 'COMMON.CHAIN'
5622       include 'COMMON.NAMES'
5623       include 'COMMON.IOUNITS'
5624       include 'COMMON.FFIELD'
5625       include 'COMMON.TORCNSTR'
5626       include 'COMMON.CONTROL'
5627       logical lprn
5628 C Set lprn=.true. for debugging
5629       lprn=.false.
5630 c     lprn=.true.
5631       etors=0.0D0
5632       do i=iphi_start,iphi_end
5633       etors_ii=0.0D0
5634         itori=itortyp(itype(i-2))
5635         itori1=itortyp(itype(i-1))
5636         phii=phi(i)
5637         gloci=0.0D0
5638 C Regular cosine and sine terms
5639         do j=1,nterm(itori,itori1)
5640           v1ij=v1(j,itori,itori1)
5641           v2ij=v2(j,itori,itori1)
5642           cosphi=dcos(j*phii)
5643           sinphi=dsin(j*phii)
5644           etors=etors+v1ij*cosphi+v2ij*sinphi
5645           if (energy_dec) etors_ii=etors_ii+
5646      &                v1ij*cosphi+v2ij*sinphi
5647           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5648         enddo
5649 C Lorentz terms
5650 C                         v1
5651 C  E = SUM ----------------------------------- - v1
5652 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5653 C
5654         cosphi=dcos(0.5d0*phii)
5655         sinphi=dsin(0.5d0*phii)
5656         do j=1,nlor(itori,itori1)
5657           vl1ij=vlor1(j,itori,itori1)
5658           vl2ij=vlor2(j,itori,itori1)
5659           vl3ij=vlor3(j,itori,itori1)
5660           pom=vl2ij*cosphi+vl3ij*sinphi
5661           pom1=1.0d0/(pom*pom+1.0d0)
5662           etors=etors+vl1ij*pom1
5663           if (energy_dec) etors_ii=etors_ii+
5664      &                vl1ij*pom1
5665           pom=-pom*pom1*pom1
5666           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5667         enddo
5668 C Subtract the constant term
5669         etors=etors-v0(itori,itori1)
5670           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5671      &         'etor',i,etors_ii-v0(itori,itori1)
5672         if (lprn)
5673      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5674      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5675      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5676         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5677 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5678       enddo
5679 ! 6/20/98 - dihedral angle constraints
5680       edihcnstr=0.0d0
5681 c      do i=1,ndih_constr
5682       do i=idihconstr_start,idihconstr_end
5683         itori=idih_constr(i)
5684         phii=phi(itori)
5685         difi=pinorm(phii-phi0(i))
5686         if (difi.gt.drange(i)) then
5687           difi=difi-drange(i)
5688           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5689           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5690         else if (difi.lt.-drange(i)) then
5691           difi=difi+drange(i)
5692           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5693           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5694         else
5695           difi=0.0
5696         endif
5697 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5698 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5699 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5700       enddo
5701 cd       write (iout,*) 'edihcnstr',edihcnstr
5702       return
5703       end
5704 c----------------------------------------------------------------------------
5705       subroutine etor_d(etors_d)
5706 C 6/23/01 Compute double torsional energy
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.INTERACT'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.CHAIN'
5716       include 'COMMON.NAMES'
5717       include 'COMMON.IOUNITS'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.TORCNSTR'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c     lprn=.true.
5725       etors_d=0.0D0
5726       do i=iphid_start,iphid_end
5727         etors_d_ii=0.0D0
5728         itori=itortyp(itype(i-2))
5729         itori1=itortyp(itype(i-1))
5730         itori2=itortyp(itype(i))
5731         phii=phi(i)
5732         phii1=phi(i+1)
5733         gloci1=0.0D0
5734         gloci2=0.0D0
5735 C Regular cosine and sine terms
5736         do j=1,ntermd_1(itori,itori1,itori2)
5737           v1cij=v1c(1,j,itori,itori1,itori2)
5738           v1sij=v1s(1,j,itori,itori1,itori2)
5739           v2cij=v1c(2,j,itori,itori1,itori2)
5740           v2sij=v1s(2,j,itori,itori1,itori2)
5741           cosphi1=dcos(j*phii)
5742           sinphi1=dsin(j*phii)
5743           cosphi2=dcos(j*phii1)
5744           sinphi2=dsin(j*phii1)
5745           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5746      &     v2cij*cosphi2+v2sij*sinphi2
5747           if (energy_dec) etors_d_ii=etors_d_ii+
5748      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5749           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5750           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5751         enddo
5752         do k=2,ntermd_2(itori,itori1,itori2)
5753           do l=1,k-1
5754             v1cdij = v2c(k,l,itori,itori1,itori2)
5755             v2cdij = v2c(l,k,itori,itori1,itori2)
5756             v1sdij = v2s(k,l,itori,itori1,itori2)
5757             v2sdij = v2s(l,k,itori,itori1,itori2)
5758             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5759             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5760             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5761             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5762             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5763      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5764             if (energy_dec) etors_d_ii=etors_d_ii+
5765      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5766      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5767             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5768      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5769             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5770      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5771           enddo
5772         enddo
5773         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5774      &        'etor_d',i,etors_d_ii
5775         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5776         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5777       enddo
5778       return
5779       end
5780 #endif
5781 c------------------------------------------------------------------------------
5782       subroutine eback_sc_corr(esccor)
5783 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5784 c        conformational states; temporarily implemented as differences
5785 c        between UNRES torsional potentials (dependent on three types of
5786 c        residues) and the torsional potentials dependent on all 20 types
5787 c        of residues computed from AM1  energy surfaces of terminally-blocked
5788 c        amino-acid residues.
5789       implicit real*8 (a-h,o-z)
5790       include 'DIMENSIONS'
5791       include 'COMMON.VAR'
5792       include 'COMMON.GEO'
5793       include 'COMMON.LOCAL'
5794       include 'COMMON.TORSION'
5795       include 'COMMON.SCCOR'
5796       include 'COMMON.INTERACT'
5797       include 'COMMON.DERIV'
5798       include 'COMMON.CHAIN'
5799       include 'COMMON.NAMES'
5800       include 'COMMON.IOUNITS'
5801       include 'COMMON.FFIELD'
5802       include 'COMMON.CONTROL'
5803       logical lprn
5804 C Set lprn=.true. for debugging
5805 C Set lprn=.true. for debugging
5806       lprn=.false.
5807 c      lprn=.true.
5808 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5809       esccor=0.0D0
5810       do i=itau_start,itau_end
5811         esccor_ii=0.0D0
5812         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5813         isccori=isccortyp(itype(i-2))
5814         isccori1=isccortyp(itype(i-1))
5815 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5816         phii=phi(i)
5817
5818 cccc  Added 9 May 2012
5819 cc Tauangle is torsional engle depending on the value of first digit
5820 c(see comment below)
5821 cc Omicron is flat angle depending on the value of first digit
5822 c(see comment below)
5823 C        print *,i,tauangle(1,i)
5824
5825        do intertyp=1,3 !intertyp
5826 cc Added 09 May 2012 (Adasko)
5827 cc  Intertyp means interaction type of backbone mainchain correlation:
5828 c   1 = SC...Ca...Ca...Ca
5829 c   2 = Ca...Ca...Ca...SC
5830 c   3 = SC...Ca...Ca...SCi
5831         gloci=0.0D0
5832         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5833      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5834      &      (itype(i-1).eq.21)))
5835      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5836      &     .or.(itype(i-2).eq.21)))
5837      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5838      &      (itype(i-1).eq.21)))) cycle
5839         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5840         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5841      & cycle
5842         do j=1,nterm_sccor(isccori,isccori1)
5843           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5844           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5845           cosphi=dcos(j*tauangle(intertyp,i))
5846           sinphi=dsin(j*tauangle(intertyp,i))
5847           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5848           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5849         enddo
5850 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5851         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5852 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5853 c     &gloc_sc(intertyp,i-3,icg)
5854         if (lprn)
5855      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5856      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5857      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5858      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5859         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5860        enddo !intertyp
5861       enddo
5862 c        do i=1,nres
5863 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc_sc(2,i,icg),
5864 c     &   gloc_sc(3,i,icg)
5865 c        enddo
5866       return
5867       end
5868 c----------------------------------------------------------------------------
5869       subroutine multibody(ecorr)
5870 C This subroutine calculates multi-body contributions to energy following
5871 C the idea of Skolnick et al. If side chains I and J make a contact and
5872 C at the same time side chains I+1 and J+1 make a contact, an extra
5873 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5874       implicit real*8 (a-h,o-z)
5875       include 'DIMENSIONS'
5876       include 'COMMON.IOUNITS'
5877       include 'COMMON.DERIV'
5878       include 'COMMON.INTERACT'
5879       include 'COMMON.CONTACTS'
5880       double precision gx(3),gx1(3)
5881       logical lprn
5882
5883 C Set lprn=.true. for debugging
5884       lprn=.false.
5885
5886       if (lprn) then
5887         write (iout,'(a)') 'Contact function values:'
5888         do i=nnt,nct-2
5889           write (iout,'(i2,20(1x,i2,f10.5))')
5890      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5891         enddo
5892       endif
5893       ecorr=0.0D0
5894       do i=nnt,nct
5895         do j=1,3
5896           gradcorr(j,i)=0.0D0
5897           gradxorr(j,i)=0.0D0
5898         enddo
5899       enddo
5900       do i=nnt,nct-2
5901
5902         DO ISHIFT = 3,4
5903
5904         i1=i+ishift
5905         num_conti=num_cont(i)
5906         num_conti1=num_cont(i1)
5907         do jj=1,num_conti
5908           j=jcont(jj,i)
5909           do kk=1,num_conti1
5910             j1=jcont(kk,i1)
5911             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5912 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5913 cd   &                   ' ishift=',ishift
5914 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5915 C The system gains extra energy.
5916               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5917             endif   ! j1==j+-ishift
5918           enddo     ! kk
5919         enddo       ! jj
5920
5921         ENDDO ! ISHIFT
5922
5923       enddo         ! i
5924       return
5925       end
5926 c------------------------------------------------------------------------------
5927       double precision function esccorr(i,j,k,l,jj,kk)
5928       implicit real*8 (a-h,o-z)
5929       include 'DIMENSIONS'
5930       include 'COMMON.IOUNITS'
5931       include 'COMMON.DERIV'
5932       include 'COMMON.INTERACT'
5933       include 'COMMON.CONTACTS'
5934       double precision gx(3),gx1(3)
5935       logical lprn
5936       lprn=.false.
5937       eij=facont(jj,i)
5938       ekl=facont(kk,k)
5939 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5940 C Calculate the multi-body contribution to energy.
5941 C Calculate multi-body contributions to the gradient.
5942 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5943 cd   & k,l,(gacont(m,kk,k),m=1,3)
5944       do m=1,3
5945         gx(m) =ekl*gacont(m,jj,i)
5946         gx1(m)=eij*gacont(m,kk,k)
5947         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5948         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5949         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5950         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5951       enddo
5952       do m=i,j-1
5953         do ll=1,3
5954           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5955         enddo
5956       enddo
5957       do m=k,l-1
5958         do ll=1,3
5959           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5960         enddo
5961       enddo
5962       esccorr=-eij*ekl
5963       return
5964       end
5965 c------------------------------------------------------------------------------
5966       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5967 C This subroutine calculates multi-body contributions to hydrogen-bonding
5968       implicit real*8 (a-h,o-z)
5969       include 'DIMENSIONS'
5970       include 'COMMON.IOUNITS'
5971 #ifdef MPI
5972       include "mpif.h"
5973       parameter (max_cont=maxconts)
5974       parameter (max_dim=26)
5975       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5976       double precision zapas(max_dim,maxconts,max_fg_procs),
5977      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5978       common /przechowalnia/ zapas
5979       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5980      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5981 #endif
5982       include 'COMMON.SETUP'
5983       include 'COMMON.FFIELD'
5984       include 'COMMON.DERIV'
5985       include 'COMMON.INTERACT'
5986       include 'COMMON.CONTACTS'
5987       include 'COMMON.CONTROL'
5988       include 'COMMON.LOCAL'
5989       double precision gx(3),gx1(3),time00
5990       logical lprn,ldone
5991
5992 C Set lprn=.true. for debugging
5993       lprn=.false.
5994 #ifdef MPI
5995       n_corr=0
5996       n_corr1=0
5997       if (nfgtasks.le.1) goto 30
5998       if (lprn) then
5999         write (iout,'(a)') 'Contact function values before RECEIVE:'
6000         do i=nnt,nct-2
6001           write (iout,'(2i3,50(1x,i2,f5.2))')
6002      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6003      &    j=1,num_cont_hb(i))
6004         enddo
6005       endif
6006       call flush(iout)
6007       do i=1,ntask_cont_from
6008         ncont_recv(i)=0
6009       enddo
6010       do i=1,ntask_cont_to
6011         ncont_sent(i)=0
6012       enddo
6013 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6014 c     & ntask_cont_to
6015 C Make the list of contacts to send to send to other procesors
6016 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6017 c      call flush(iout)
6018       do i=iturn3_start,iturn3_end
6019 c        write (iout,*) "make contact list turn3",i," num_cont",
6020 c     &    num_cont_hb(i)
6021         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6022       enddo
6023       do i=iturn4_start,iturn4_end
6024 c        write (iout,*) "make contact list turn4",i," num_cont",
6025 c     &   num_cont_hb(i)
6026         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6027       enddo
6028       do ii=1,nat_sent
6029         i=iat_sent(ii)
6030 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6031 c     &    num_cont_hb(i)
6032         do j=1,num_cont_hb(i)
6033         do k=1,4
6034           jjc=jcont_hb(j,i)
6035           iproc=iint_sent_local(k,jjc,ii)
6036 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6037           if (iproc.gt.0) then
6038             ncont_sent(iproc)=ncont_sent(iproc)+1
6039             nn=ncont_sent(iproc)
6040             zapas(1,nn,iproc)=i
6041             zapas(2,nn,iproc)=jjc
6042             zapas(3,nn,iproc)=facont_hb(j,i)
6043             zapas(4,nn,iproc)=ees0p(j,i)
6044             zapas(5,nn,iproc)=ees0m(j,i)
6045             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6046             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6047             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6048             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6049             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6050             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6051             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6052             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6053             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6054             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6055             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6056             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6057             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6058             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6059             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6060             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6061             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6062             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6063             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6064             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6065             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6066           endif
6067         enddo
6068         enddo
6069       enddo
6070       if (lprn) then
6071       write (iout,*)
6072      &  "Numbers of contacts to be sent to other processors",
6073      &  (ncont_sent(i),i=1,ntask_cont_to)
6074       write (iout,*) "Contacts sent"
6075       do ii=1,ntask_cont_to
6076         nn=ncont_sent(ii)
6077         iproc=itask_cont_to(ii)
6078         write (iout,*) nn," contacts to processor",iproc,
6079      &   " of CONT_TO_COMM group"
6080         do i=1,nn
6081           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6082         enddo
6083       enddo
6084       call flush(iout)
6085       endif
6086       CorrelType=477
6087       CorrelID=fg_rank+1
6088       CorrelType1=478
6089       CorrelID1=nfgtasks+fg_rank+1
6090       ireq=0
6091 C Receive the numbers of needed contacts from other processors
6092       do ii=1,ntask_cont_from
6093         iproc=itask_cont_from(ii)
6094         ireq=ireq+1
6095         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6096      &    FG_COMM,req(ireq),IERR)
6097       enddo
6098 c      write (iout,*) "IRECV ended"
6099 c      call flush(iout)
6100 C Send the number of contacts needed by other processors
6101       do ii=1,ntask_cont_to
6102         iproc=itask_cont_to(ii)
6103         ireq=ireq+1
6104         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6105      &    FG_COMM,req(ireq),IERR)
6106       enddo
6107 c      write (iout,*) "ISEND ended"
6108 c      write (iout,*) "number of requests (nn)",ireq
6109       call flush(iout)
6110       if (ireq.gt.0)
6111      &  call MPI_Waitall(ireq,req,status_array,ierr)
6112 c      write (iout,*)
6113 c     &  "Numbers of contacts to be received from other processors",
6114 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6115 c      call flush(iout)
6116 C Receive contacts
6117       ireq=0
6118       do ii=1,ntask_cont_from
6119         iproc=itask_cont_from(ii)
6120         nn=ncont_recv(ii)
6121 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6122 c     &   " of CONT_TO_COMM group"
6123         call flush(iout)
6124         if (nn.gt.0) then
6125           ireq=ireq+1
6126           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6127      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6128 c          write (iout,*) "ireq,req",ireq,req(ireq)
6129         endif
6130       enddo
6131 C Send the contacts to processors that need them
6132       do ii=1,ntask_cont_to
6133         iproc=itask_cont_to(ii)
6134         nn=ncont_sent(ii)
6135 c        write (iout,*) nn," contacts to processor",iproc,
6136 c     &   " of CONT_TO_COMM group"
6137         if (nn.gt.0) then
6138           ireq=ireq+1
6139           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6140      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6141 c          write (iout,*) "ireq,req",ireq,req(ireq)
6142 c          do i=1,nn
6143 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6144 c          enddo
6145         endif
6146       enddo
6147 c      write (iout,*) "number of requests (contacts)",ireq
6148 c      write (iout,*) "req",(req(i),i=1,4)
6149 c      call flush(iout)
6150       if (ireq.gt.0)
6151      & call MPI_Waitall(ireq,req,status_array,ierr)
6152       do iii=1,ntask_cont_from
6153         iproc=itask_cont_from(iii)
6154         nn=ncont_recv(iii)
6155         if (lprn) then
6156         write (iout,*) "Received",nn," contacts from processor",iproc,
6157      &   " of CONT_FROM_COMM group"
6158         call flush(iout)
6159         do i=1,nn
6160           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6161         enddo
6162         call flush(iout)
6163         endif
6164         do i=1,nn
6165           ii=zapas_recv(1,i,iii)
6166 c Flag the received contacts to prevent double-counting
6167           jj=-zapas_recv(2,i,iii)
6168 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6169 c          call flush(iout)
6170           nnn=num_cont_hb(ii)+1
6171           num_cont_hb(ii)=nnn
6172           jcont_hb(nnn,ii)=jj
6173           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6174           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6175           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6176           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6177           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6178           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6179           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6180           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6181           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6182           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6183           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6184           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6185           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6186           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6187           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6188           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6189           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6190           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6191           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6192           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6193           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6194           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6195           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6196           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6197         enddo
6198       enddo
6199       call flush(iout)
6200       if (lprn) then
6201         write (iout,'(a)') 'Contact function values after receive:'
6202         do i=nnt,nct-2
6203           write (iout,'(2i3,50(1x,i3,f5.2))')
6204      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6205      &    j=1,num_cont_hb(i))
6206         enddo
6207         call flush(iout)
6208       endif
6209    30 continue
6210 #endif
6211       if (lprn) then
6212         write (iout,'(a)') 'Contact function values:'
6213         do i=nnt,nct-2
6214           write (iout,'(2i3,50(1x,i3,f5.2))')
6215      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6216      &    j=1,num_cont_hb(i))
6217         enddo
6218       endif
6219       ecorr=0.0D0
6220 C Remove the loop below after debugging !!!
6221       do i=nnt,nct
6222         do j=1,3
6223           gradcorr(j,i)=0.0D0
6224           gradxorr(j,i)=0.0D0
6225         enddo
6226       enddo
6227 C Calculate the local-electrostatic correlation terms
6228       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6229         i1=i+1
6230         num_conti=num_cont_hb(i)
6231         num_conti1=num_cont_hb(i+1)
6232         do jj=1,num_conti
6233           j=jcont_hb(jj,i)
6234           jp=iabs(j)
6235           do kk=1,num_conti1
6236             j1=jcont_hb(kk,i1)
6237             jp1=iabs(j1)
6238 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6239 c     &         ' jj=',jj,' kk=',kk
6240             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6241      &          .or. j.lt.0 .and. j1.gt.0) .and.
6242      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6243 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6244 C The system gains extra energy.
6245               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6246               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6247      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6248               n_corr=n_corr+1
6249             else if (j1.eq.j) then
6250 C Contacts I-J and I-(J+1) occur simultaneously.
6251 C The system loses extra energy.
6252 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6253             endif
6254           enddo ! kk
6255           do kk=1,num_conti
6256             j1=jcont_hb(kk,i)
6257 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6258 c    &         ' jj=',jj,' kk=',kk
6259             if (j1.eq.j+1) then
6260 C Contacts I-J and (I+1)-J occur simultaneously.
6261 C The system loses extra energy.
6262 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6263             endif ! j1==j+1
6264           enddo ! kk
6265         enddo ! jj
6266       enddo ! i
6267       return
6268       end
6269 c------------------------------------------------------------------------------
6270       subroutine add_hb_contact(ii,jj,itask)
6271       implicit real*8 (a-h,o-z)
6272       include "DIMENSIONS"
6273       include "COMMON.IOUNITS"
6274       integer max_cont
6275       integer max_dim
6276       parameter (max_cont=maxconts)
6277       parameter (max_dim=26)
6278       include "COMMON.CONTACTS"
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 i,j,ii,jj,iproc,itask(4),nn
6283 c      write (iout,*) "itask",itask
6284       do i=1,2
6285         iproc=itask(i)
6286         if (iproc.gt.0) then
6287           do j=1,num_cont_hb(ii)
6288             jjc=jcont_hb(j,ii)
6289 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6290             if (jjc.eq.jj) then
6291               ncont_sent(iproc)=ncont_sent(iproc)+1
6292               nn=ncont_sent(iproc)
6293               zapas(1,nn,iproc)=ii
6294               zapas(2,nn,iproc)=jjc
6295               zapas(3,nn,iproc)=facont_hb(j,ii)
6296               zapas(4,nn,iproc)=ees0p(j,ii)
6297               zapas(5,nn,iproc)=ees0m(j,ii)
6298               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6299               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6300               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6301               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6302               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6303               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6304               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6305               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6306               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6307               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6308               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6309               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6310               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6311               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6312               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6313               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6314               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6315               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6316               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6317               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6318               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6319               exit
6320             endif
6321           enddo
6322         endif
6323       enddo
6324       return
6325       end
6326 c------------------------------------------------------------------------------
6327       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6328      &  n_corr1)
6329 C This subroutine calculates multi-body contributions to hydrogen-bonding
6330       implicit real*8 (a-h,o-z)
6331       include 'DIMENSIONS'
6332       include 'COMMON.IOUNITS'
6333 #ifdef MPI
6334       include "mpif.h"
6335       parameter (max_cont=maxconts)
6336       parameter (max_dim=70)
6337       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6338       double precision zapas(max_dim,maxconts,max_fg_procs),
6339      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6340       common /przechowalnia/ zapas
6341       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6342      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6343 #endif
6344       include 'COMMON.SETUP'
6345       include 'COMMON.FFIELD'
6346       include 'COMMON.DERIV'
6347       include 'COMMON.LOCAL'
6348       include 'COMMON.INTERACT'
6349       include 'COMMON.CONTACTS'
6350       include 'COMMON.CHAIN'
6351       include 'COMMON.CONTROL'
6352       double precision gx(3),gx1(3)
6353       integer num_cont_hb_old(maxres)
6354       logical lprn,ldone
6355       double precision eello4,eello5,eelo6,eello_turn6
6356       external eello4,eello5,eello6,eello_turn6
6357 C Set lprn=.true. for debugging
6358       lprn=.false.
6359       eturn6=0.0d0
6360 #ifdef MPI
6361       do i=1,nres
6362         num_cont_hb_old(i)=num_cont_hb(i)
6363       enddo
6364       n_corr=0
6365       n_corr1=0
6366       if (nfgtasks.le.1) goto 30
6367       if (lprn) then
6368         write (iout,'(a)') 'Contact function values before RECEIVE:'
6369         do i=nnt,nct-2
6370           write (iout,'(2i3,50(1x,i2,f5.2))')
6371      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6372      &    j=1,num_cont_hb(i))
6373         enddo
6374       endif
6375       call flush(iout)
6376       do i=1,ntask_cont_from
6377         ncont_recv(i)=0
6378       enddo
6379       do i=1,ntask_cont_to
6380         ncont_sent(i)=0
6381       enddo
6382 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6383 c     & ntask_cont_to
6384 C Make the list of contacts to send to send to other procesors
6385       do i=iturn3_start,iturn3_end
6386 c        write (iout,*) "make contact list turn3",i," num_cont",
6387 c     &    num_cont_hb(i)
6388         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6389       enddo
6390       do i=iturn4_start,iturn4_end
6391 c        write (iout,*) "make contact list turn4",i," num_cont",
6392 c     &   num_cont_hb(i)
6393         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6394       enddo
6395       do ii=1,nat_sent
6396         i=iat_sent(ii)
6397 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6398 c     &    num_cont_hb(i)
6399         do j=1,num_cont_hb(i)
6400         do k=1,4
6401           jjc=jcont_hb(j,i)
6402           iproc=iint_sent_local(k,jjc,ii)
6403 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6404           if (iproc.ne.0) then
6405             ncont_sent(iproc)=ncont_sent(iproc)+1
6406             nn=ncont_sent(iproc)
6407             zapas(1,nn,iproc)=i
6408             zapas(2,nn,iproc)=jjc
6409             zapas(3,nn,iproc)=d_cont(j,i)
6410             ind=3
6411             do kk=1,3
6412               ind=ind+1
6413               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6414             enddo
6415             do kk=1,2
6416               do ll=1,2
6417                 ind=ind+1
6418                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6419               enddo
6420             enddo
6421             do jj=1,5
6422               do kk=1,3
6423                 do ll=1,2
6424                   do mm=1,2
6425                     ind=ind+1
6426                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6427                   enddo
6428                 enddo
6429               enddo
6430             enddo
6431           endif
6432         enddo
6433         enddo
6434       enddo
6435       if (lprn) then
6436       write (iout,*)
6437      &  "Numbers of contacts to be sent to other processors",
6438      &  (ncont_sent(i),i=1,ntask_cont_to)
6439       write (iout,*) "Contacts sent"
6440       do ii=1,ntask_cont_to
6441         nn=ncont_sent(ii)
6442         iproc=itask_cont_to(ii)
6443         write (iout,*) nn," contacts to processor",iproc,
6444      &   " of CONT_TO_COMM group"
6445         do i=1,nn
6446           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6447         enddo
6448       enddo
6449       call flush(iout)
6450       endif
6451       CorrelType=477
6452       CorrelID=fg_rank+1
6453       CorrelType1=478
6454       CorrelID1=nfgtasks+fg_rank+1
6455       ireq=0
6456 C Receive the numbers of needed contacts from other processors
6457       do ii=1,ntask_cont_from
6458         iproc=itask_cont_from(ii)
6459         ireq=ireq+1
6460         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6461      &    FG_COMM,req(ireq),IERR)
6462       enddo
6463 c      write (iout,*) "IRECV ended"
6464 c      call flush(iout)
6465 C Send the number of contacts needed by other processors
6466       do ii=1,ntask_cont_to
6467         iproc=itask_cont_to(ii)
6468         ireq=ireq+1
6469         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6470      &    FG_COMM,req(ireq),IERR)
6471       enddo
6472 c      write (iout,*) "ISEND ended"
6473 c      write (iout,*) "number of requests (nn)",ireq
6474       call flush(iout)
6475       if (ireq.gt.0)
6476      &  call MPI_Waitall(ireq,req,status_array,ierr)
6477 c      write (iout,*)
6478 c     &  "Numbers of contacts to be received from other processors",
6479 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6480 c      call flush(iout)
6481 C Receive contacts
6482       ireq=0
6483       do ii=1,ntask_cont_from
6484         iproc=itask_cont_from(ii)
6485         nn=ncont_recv(ii)
6486 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6487 c     &   " of CONT_TO_COMM group"
6488         call flush(iout)
6489         if (nn.gt.0) then
6490           ireq=ireq+1
6491           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6492      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6493 c          write (iout,*) "ireq,req",ireq,req(ireq)
6494         endif
6495       enddo
6496 C Send the contacts to processors that need them
6497       do ii=1,ntask_cont_to
6498         iproc=itask_cont_to(ii)
6499         nn=ncont_sent(ii)
6500 c        write (iout,*) nn," contacts to processor",iproc,
6501 c     &   " of CONT_TO_COMM group"
6502         if (nn.gt.0) then
6503           ireq=ireq+1
6504           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6505      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6506 c          write (iout,*) "ireq,req",ireq,req(ireq)
6507 c          do i=1,nn
6508 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6509 c          enddo
6510         endif
6511       enddo
6512 c      write (iout,*) "number of requests (contacts)",ireq
6513 c      write (iout,*) "req",(req(i),i=1,4)
6514 c      call flush(iout)
6515       if (ireq.gt.0)
6516      & call MPI_Waitall(ireq,req,status_array,ierr)
6517       do iii=1,ntask_cont_from
6518         iproc=itask_cont_from(iii)
6519         nn=ncont_recv(iii)
6520         if (lprn) then
6521         write (iout,*) "Received",nn," contacts from processor",iproc,
6522      &   " of CONT_FROM_COMM group"
6523         call flush(iout)
6524         do i=1,nn
6525           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6526         enddo
6527         call flush(iout)
6528         endif
6529         do i=1,nn
6530           ii=zapas_recv(1,i,iii)
6531 c Flag the received contacts to prevent double-counting
6532           jj=-zapas_recv(2,i,iii)
6533 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6534 c          call flush(iout)
6535           nnn=num_cont_hb(ii)+1
6536           num_cont_hb(ii)=nnn
6537           jcont_hb(nnn,ii)=jj
6538           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6539           ind=3
6540           do kk=1,3
6541             ind=ind+1
6542             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6543           enddo
6544           do kk=1,2
6545             do ll=1,2
6546               ind=ind+1
6547               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6548             enddo
6549           enddo
6550           do jj=1,5
6551             do kk=1,3
6552               do ll=1,2
6553                 do mm=1,2
6554                   ind=ind+1
6555                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6556                 enddo
6557               enddo
6558             enddo
6559           enddo
6560         enddo
6561       enddo
6562       call flush(iout)
6563       if (lprn) then
6564         write (iout,'(a)') 'Contact function values after receive:'
6565         do i=nnt,nct-2
6566           write (iout,'(2i3,50(1x,i3,5f6.3))')
6567      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6568      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6569         enddo
6570         call flush(iout)
6571       endif
6572    30 continue
6573 #endif
6574       if (lprn) then
6575         write (iout,'(a)') 'Contact function values:'
6576         do i=nnt,nct-2
6577           write (iout,'(2i3,50(1x,i2,5f6.3))')
6578      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6579      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6580         enddo
6581       endif
6582       ecorr=0.0D0
6583       ecorr5=0.0d0
6584       ecorr6=0.0d0
6585 C Remove the loop below after debugging !!!
6586       do i=nnt,nct
6587         do j=1,3
6588           gradcorr(j,i)=0.0D0
6589           gradxorr(j,i)=0.0D0
6590         enddo
6591       enddo
6592 C Calculate the dipole-dipole interaction energies
6593       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6594       do i=iatel_s,iatel_e+1
6595         num_conti=num_cont_hb(i)
6596         do jj=1,num_conti
6597           j=jcont_hb(jj,i)
6598 #ifdef MOMENT
6599           call dipole(i,j,jj)
6600 #endif
6601         enddo
6602       enddo
6603       endif
6604 C Calculate the local-electrostatic correlation terms
6605 c                write (iout,*) "gradcorr5 in eello5 before loop"
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       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6611 c        write (iout,*) "corr loop i",i
6612         i1=i+1
6613         num_conti=num_cont_hb(i)
6614         num_conti1=num_cont_hb(i+1)
6615         do jj=1,num_conti
6616           j=jcont_hb(jj,i)
6617           jp=iabs(j)
6618           do kk=1,num_conti1
6619             j1=jcont_hb(kk,i1)
6620             jp1=iabs(j1)
6621 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6622 c     &         ' jj=',jj,' kk=',kk
6623 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6624             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6625      &          .or. j.lt.0 .and. j1.gt.0) .and.
6626      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6627 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6628 C The system gains extra energy.
6629               n_corr=n_corr+1
6630               sqd1=dsqrt(d_cont(jj,i))
6631               sqd2=dsqrt(d_cont(kk,i1))
6632               sred_geom = sqd1*sqd2
6633               IF (sred_geom.lt.cutoff_corr) THEN
6634                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6635      &            ekont,fprimcont)
6636 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6637 cd     &         ' jj=',jj,' kk=',kk
6638                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6639                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6640                 do l=1,3
6641                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6642                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6643                 enddo
6644                 n_corr1=n_corr1+1
6645 cd               write (iout,*) 'sred_geom=',sred_geom,
6646 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6647 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6648 cd               write (iout,*) "g_contij",g_contij
6649 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6650 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6651                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6652                 if (wcorr4.gt.0.0d0)
6653      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6654                   if (energy_dec.and.wcorr4.gt.0.0d0)
6655      1                 write (iout,'(a6,4i5,0pf7.3)')
6656      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6657 c                write (iout,*) "gradcorr5 before eello5"
6658 c                do iii=1,nres
6659 c                  write (iout,'(i5,3f10.5)')
6660 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6661 c                enddo
6662                 if (wcorr5.gt.0.0d0)
6663      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6664 c                write (iout,*) "gradcorr5 after eello5"
6665 c                do iii=1,nres
6666 c                  write (iout,'(i5,3f10.5)')
6667 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6668 c                enddo
6669                   if (energy_dec.and.wcorr5.gt.0.0d0)
6670      1                 write (iout,'(a6,4i5,0pf7.3)')
6671      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6672 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6673 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6674                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6675      &               .or. wturn6.eq.0.0d0))then
6676 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6677                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6678                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6679      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6680 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6681 cd     &            'ecorr6=',ecorr6
6682 cd                write (iout,'(4e15.5)') sred_geom,
6683 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6684 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6685 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6686                 else if (wturn6.gt.0.0d0
6687      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6688 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6689                   eturn6=eturn6+eello_turn6(i,jj,kk)
6690                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6691      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6692 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6693                 endif
6694               ENDIF
6695 1111          continue
6696             endif
6697           enddo ! kk
6698         enddo ! jj
6699       enddo ! i
6700       do i=1,nres
6701         num_cont_hb(i)=num_cont_hb_old(i)
6702       enddo
6703 c                write (iout,*) "gradcorr5 in eello5"
6704 c                do iii=1,nres
6705 c                  write (iout,'(i5,3f10.5)')
6706 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6707 c                enddo
6708       return
6709       end
6710 c------------------------------------------------------------------------------
6711       subroutine add_hb_contact_eello(ii,jj,itask)
6712       implicit real*8 (a-h,o-z)
6713       include "DIMENSIONS"
6714       include "COMMON.IOUNITS"
6715       integer max_cont
6716       integer max_dim
6717       parameter (max_cont=maxconts)
6718       parameter (max_dim=70)
6719       include "COMMON.CONTACTS"
6720       double precision zapas(max_dim,maxconts,max_fg_procs),
6721      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6722       common /przechowalnia/ zapas
6723       integer i,j,ii,jj,iproc,itask(4),nn
6724 c      write (iout,*) "itask",itask
6725       do i=1,2
6726         iproc=itask(i)
6727         if (iproc.gt.0) then
6728           do j=1,num_cont_hb(ii)
6729             jjc=jcont_hb(j,ii)
6730 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6731             if (jjc.eq.jj) then
6732               ncont_sent(iproc)=ncont_sent(iproc)+1
6733               nn=ncont_sent(iproc)
6734               zapas(1,nn,iproc)=ii
6735               zapas(2,nn,iproc)=jjc
6736               zapas(3,nn,iproc)=d_cont(j,ii)
6737               ind=3
6738               do kk=1,3
6739                 ind=ind+1
6740                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6741               enddo
6742               do kk=1,2
6743                 do ll=1,2
6744                   ind=ind+1
6745                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6746                 enddo
6747               enddo
6748               do jj=1,5
6749                 do kk=1,3
6750                   do ll=1,2
6751                     do mm=1,2
6752                       ind=ind+1
6753                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6754                     enddo
6755                   enddo
6756                 enddo
6757               enddo
6758               exit
6759             endif
6760           enddo
6761         endif
6762       enddo
6763       return
6764       end
6765 c------------------------------------------------------------------------------
6766       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6767       implicit real*8 (a-h,o-z)
6768       include 'DIMENSIONS'
6769       include 'COMMON.IOUNITS'
6770       include 'COMMON.DERIV'
6771       include 'COMMON.INTERACT'
6772       include 'COMMON.CONTACTS'
6773       double precision gx(3),gx1(3)
6774       logical lprn
6775       lprn=.false.
6776       eij=facont_hb(jj,i)
6777       ekl=facont_hb(kk,k)
6778       ees0pij=ees0p(jj,i)
6779       ees0pkl=ees0p(kk,k)
6780       ees0mij=ees0m(jj,i)
6781       ees0mkl=ees0m(kk,k)
6782       ekont=eij*ekl
6783       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6784 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6785 C Following 4 lines for diagnostics.
6786 cd    ees0pkl=0.0D0
6787 cd    ees0pij=1.0D0
6788 cd    ees0mkl=0.0D0
6789 cd    ees0mij=1.0D0
6790 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6791 c     & 'Contacts ',i,j,
6792 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6793 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6794 c     & 'gradcorr_long'
6795 C Calculate the multi-body contribution to energy.
6796 c      ecorr=ecorr+ekont*ees
6797 C Calculate multi-body contributions to the gradient.
6798       coeffpees0pij=coeffp*ees0pij
6799       coeffmees0mij=coeffm*ees0mij
6800       coeffpees0pkl=coeffp*ees0pkl
6801       coeffmees0mkl=coeffm*ees0mkl
6802       do ll=1,3
6803 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6804         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6805      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6806      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6807         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6808      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6809      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6810 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6811         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6812      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6813      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6814         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6815      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6816      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6817         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6818      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6819      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6820         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6821         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6822         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6823      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6824      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6825         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6826         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6827 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6828       enddo
6829 c      write (iout,*)
6830 cgrad      do m=i+1,j-1
6831 cgrad        do ll=1,3
6832 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6833 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6834 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6835 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6836 cgrad        enddo
6837 cgrad      enddo
6838 cgrad      do m=k+1,l-1
6839 cgrad        do ll=1,3
6840 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6841 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6842 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6843 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6844 cgrad        enddo
6845 cgrad      enddo
6846 c      write (iout,*) "ehbcorr",ekont*ees
6847       ehbcorr=ekont*ees
6848       return
6849       end
6850 #ifdef MOMENT
6851 C---------------------------------------------------------------------------
6852       subroutine dipole(i,j,jj)
6853       implicit real*8 (a-h,o-z)
6854       include 'DIMENSIONS'
6855       include 'COMMON.IOUNITS'
6856       include 'COMMON.CHAIN'
6857       include 'COMMON.FFIELD'
6858       include 'COMMON.DERIV'
6859       include 'COMMON.INTERACT'
6860       include 'COMMON.CONTACTS'
6861       include 'COMMON.TORSION'
6862       include 'COMMON.VAR'
6863       include 'COMMON.GEO'
6864       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6865      &  auxmat(2,2)
6866       iti1 = itortyp(itype(i+1))
6867       if (j.lt.nres-1) then
6868         itj1 = itortyp(itype(j+1))
6869       else
6870         itj1=ntortyp+1
6871       endif
6872       do iii=1,2
6873         dipi(iii,1)=Ub2(iii,i)
6874         dipderi(iii)=Ub2der(iii,i)
6875         dipi(iii,2)=b1(iii,iti1)
6876         dipj(iii,1)=Ub2(iii,j)
6877         dipderj(iii)=Ub2der(iii,j)
6878         dipj(iii,2)=b1(iii,itj1)
6879       enddo
6880       kkk=0
6881       do iii=1,2
6882         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6883         do jjj=1,2
6884           kkk=kkk+1
6885           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6886         enddo
6887       enddo
6888       do kkk=1,5
6889         do lll=1,3
6890           mmm=0
6891           do iii=1,2
6892             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6893      &        auxvec(1))
6894             do jjj=1,2
6895               mmm=mmm+1
6896               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6897             enddo
6898           enddo
6899         enddo
6900       enddo
6901       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6902       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6903       do iii=1,2
6904         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6905       enddo
6906       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6907       do iii=1,2
6908         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6909       enddo
6910       return
6911       end
6912 #endif
6913 C---------------------------------------------------------------------------
6914       subroutine calc_eello(i,j,k,l,jj,kk)
6915 C
6916 C This subroutine computes matrices and vectors needed to calculate
6917 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6918 C
6919       implicit real*8 (a-h,o-z)
6920       include 'DIMENSIONS'
6921       include 'COMMON.IOUNITS'
6922       include 'COMMON.CHAIN'
6923       include 'COMMON.DERIV'
6924       include 'COMMON.INTERACT'
6925       include 'COMMON.CONTACTS'
6926       include 'COMMON.TORSION'
6927       include 'COMMON.VAR'
6928       include 'COMMON.GEO'
6929       include 'COMMON.FFIELD'
6930       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6931      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6932       logical lprn
6933       common /kutas/ lprn
6934 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6935 cd     & ' jj=',jj,' kk=',kk
6936 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6937 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6938 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6939       do iii=1,2
6940         do jjj=1,2
6941           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6942           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6943         enddo
6944       enddo
6945       call transpose2(aa1(1,1),aa1t(1,1))
6946       call transpose2(aa2(1,1),aa2t(1,1))
6947       do kkk=1,5
6948         do lll=1,3
6949           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6950      &      aa1tder(1,1,lll,kkk))
6951           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6952      &      aa2tder(1,1,lll,kkk))
6953         enddo
6954       enddo
6955       if (l.eq.j+1) then
6956 C parallel orientation of the two CA-CA-CA frames.
6957         if (i.gt.1) then
6958           iti=itortyp(itype(i))
6959         else
6960           iti=ntortyp+1
6961         endif
6962         itk1=itortyp(itype(k+1))
6963         itj=itortyp(itype(j))
6964         if (l.lt.nres-1) then
6965           itl1=itortyp(itype(l+1))
6966         else
6967           itl1=ntortyp+1
6968         endif
6969 C A1 kernel(j+1) A2T
6970 cd        do iii=1,2
6971 cd          write (iout,'(3f10.5,5x,3f10.5)')
6972 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6973 cd        enddo
6974         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6975      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6976      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6977 C Following matrices are needed only for 6-th order cumulants
6978         IF (wcorr6.gt.0.0d0) THEN
6979         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6980      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6981      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6982         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6983      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6984      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6985      &   ADtEAderx(1,1,1,1,1,1))
6986         lprn=.false.
6987         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6988      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6989      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6990      &   ADtEA1derx(1,1,1,1,1,1))
6991         ENDIF
6992 C End 6-th order cumulants
6993 cd        lprn=.false.
6994 cd        if (lprn) then
6995 cd        write (2,*) 'In calc_eello6'
6996 cd        do iii=1,2
6997 cd          write (2,*) 'iii=',iii
6998 cd          do kkk=1,5
6999 cd            write (2,*) 'kkk=',kkk
7000 cd            do jjj=1,2
7001 cd              write (2,'(3(2f10.5),5x)')
7002 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7003 cd            enddo
7004 cd          enddo
7005 cd        enddo
7006 cd        endif
7007         call transpose2(EUgder(1,1,k),auxmat(1,1))
7008         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7009         call transpose2(EUg(1,1,k),auxmat(1,1))
7010         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7011         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7012         do iii=1,2
7013           do kkk=1,5
7014             do lll=1,3
7015               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7016      &          EAEAderx(1,1,lll,kkk,iii,1))
7017             enddo
7018           enddo
7019         enddo
7020 C A1T kernel(i+1) A2
7021         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7022      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7023      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7024 C Following matrices are needed only for 6-th order cumulants
7025         IF (wcorr6.gt.0.0d0) THEN
7026         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7027      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7028      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7029         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7030      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7031      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7032      &   ADtEAderx(1,1,1,1,1,2))
7033         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7034      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7035      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7036      &   ADtEA1derx(1,1,1,1,1,2))
7037         ENDIF
7038 C End 6-th order cumulants
7039         call transpose2(EUgder(1,1,l),auxmat(1,1))
7040         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7041         call transpose2(EUg(1,1,l),auxmat(1,1))
7042         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7043         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7044         do iii=1,2
7045           do kkk=1,5
7046             do lll=1,3
7047               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7048      &          EAEAderx(1,1,lll,kkk,iii,2))
7049             enddo
7050           enddo
7051         enddo
7052 C AEAb1 and AEAb2
7053 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7054 C They are needed only when the fifth- or the sixth-order cumulants are
7055 C indluded.
7056         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7057         call transpose2(AEA(1,1,1),auxmat(1,1))
7058         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7059         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7060         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7061         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7062         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7063         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7064         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7065         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7066         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7067         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7068         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7069         call transpose2(AEA(1,1,2),auxmat(1,1))
7070         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7071         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7072         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7073         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7074         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7075         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7076         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7077         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7078         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7079         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7080         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7081 C Calculate the Cartesian derivatives of the vectors.
7082         do iii=1,2
7083           do kkk=1,5
7084             do lll=1,3
7085               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7086               call matvec2(auxmat(1,1),b1(1,iti),
7087      &          AEAb1derx(1,lll,kkk,iii,1,1))
7088               call matvec2(auxmat(1,1),Ub2(1,i),
7089      &          AEAb2derx(1,lll,kkk,iii,1,1))
7090               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7091      &          AEAb1derx(1,lll,kkk,iii,2,1))
7092               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7093      &          AEAb2derx(1,lll,kkk,iii,2,1))
7094               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7095               call matvec2(auxmat(1,1),b1(1,itj),
7096      &          AEAb1derx(1,lll,kkk,iii,1,2))
7097               call matvec2(auxmat(1,1),Ub2(1,j),
7098      &          AEAb2derx(1,lll,kkk,iii,1,2))
7099               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7100      &          AEAb1derx(1,lll,kkk,iii,2,2))
7101               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7102      &          AEAb2derx(1,lll,kkk,iii,2,2))
7103             enddo
7104           enddo
7105         enddo
7106         ENDIF
7107 C End vectors
7108       else
7109 C Antiparallel orientation of the two CA-CA-CA frames.
7110         if (i.gt.1) then
7111           iti=itortyp(itype(i))
7112         else
7113           iti=ntortyp+1
7114         endif
7115         itk1=itortyp(itype(k+1))
7116         itl=itortyp(itype(l))
7117         itj=itortyp(itype(j))
7118         if (j.lt.nres-1) then
7119           itj1=itortyp(itype(j+1))
7120         else
7121           itj1=ntortyp+1
7122         endif
7123 C A2 kernel(j-1)T A1T
7124         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7125      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7126      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7127 C Following matrices are needed only for 6-th order cumulants
7128         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7129      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7130         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7131      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7132      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7133         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7134      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7135      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7136      &   ADtEAderx(1,1,1,1,1,1))
7137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7138      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7139      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7140      &   ADtEA1derx(1,1,1,1,1,1))
7141         ENDIF
7142 C End 6-th order cumulants
7143         call transpose2(EUgder(1,1,k),auxmat(1,1))
7144         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7145         call transpose2(EUg(1,1,k),auxmat(1,1))
7146         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7147         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7148         do iii=1,2
7149           do kkk=1,5
7150             do lll=1,3
7151               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7152      &          EAEAderx(1,1,lll,kkk,iii,1))
7153             enddo
7154           enddo
7155         enddo
7156 C A2T kernel(i+1)T A1
7157         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7158      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7159      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7160 C Following matrices are needed only for 6-th order cumulants
7161         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7162      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7163         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7164      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7165      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7166         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7167      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7168      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7169      &   ADtEAderx(1,1,1,1,1,2))
7170         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7171      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7172      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7173      &   ADtEA1derx(1,1,1,1,1,2))
7174         ENDIF
7175 C End 6-th order cumulants
7176         call transpose2(EUgder(1,1,j),auxmat(1,1))
7177         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7178         call transpose2(EUg(1,1,j),auxmat(1,1))
7179         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7180         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7181         do iii=1,2
7182           do kkk=1,5
7183             do lll=1,3
7184               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7185      &          EAEAderx(1,1,lll,kkk,iii,2))
7186             enddo
7187           enddo
7188         enddo
7189 C AEAb1 and AEAb2
7190 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7191 C They are needed only when the fifth- or the sixth-order cumulants are
7192 C indluded.
7193         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7194      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7195         call transpose2(AEA(1,1,1),auxmat(1,1))
7196         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7197         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7198         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7199         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7200         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7201         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7202         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7203         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7204         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7205         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7206         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7207         call transpose2(AEA(1,1,2),auxmat(1,1))
7208         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7209         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7210         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7211         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7212         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7213         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7214         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7215         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7216         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7217         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7218         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7219 C Calculate the Cartesian derivatives of the vectors.
7220         do iii=1,2
7221           do kkk=1,5
7222             do lll=1,3
7223               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7224               call matvec2(auxmat(1,1),b1(1,iti),
7225      &          AEAb1derx(1,lll,kkk,iii,1,1))
7226               call matvec2(auxmat(1,1),Ub2(1,i),
7227      &          AEAb2derx(1,lll,kkk,iii,1,1))
7228               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7229      &          AEAb1derx(1,lll,kkk,iii,2,1))
7230               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7231      &          AEAb2derx(1,lll,kkk,iii,2,1))
7232               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7233               call matvec2(auxmat(1,1),b1(1,itl),
7234      &          AEAb1derx(1,lll,kkk,iii,1,2))
7235               call matvec2(auxmat(1,1),Ub2(1,l),
7236      &          AEAb2derx(1,lll,kkk,iii,1,2))
7237               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7238      &          AEAb1derx(1,lll,kkk,iii,2,2))
7239               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7240      &          AEAb2derx(1,lll,kkk,iii,2,2))
7241             enddo
7242           enddo
7243         enddo
7244         ENDIF
7245 C End vectors
7246       endif
7247       return
7248       end
7249 C---------------------------------------------------------------------------
7250       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7251      &  KK,KKderg,AKA,AKAderg,AKAderx)
7252       implicit none
7253       integer nderg
7254       logical transp
7255       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7256      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7257      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7258       integer iii,kkk,lll
7259       integer jjj,mmm
7260       logical lprn
7261       common /kutas/ lprn
7262       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7263       do iii=1,nderg
7264         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7265      &    AKAderg(1,1,iii))
7266       enddo
7267 cd      if (lprn) write (2,*) 'In kernel'
7268       do kkk=1,5
7269 cd        if (lprn) write (2,*) 'kkk=',kkk
7270         do lll=1,3
7271           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7272      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7273 cd          if (lprn) then
7274 cd            write (2,*) 'lll=',lll
7275 cd            write (2,*) 'iii=1'
7276 cd            do jjj=1,2
7277 cd              write (2,'(3(2f10.5),5x)')
7278 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7279 cd            enddo
7280 cd          endif
7281           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7282      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7283 cd          if (lprn) then
7284 cd            write (2,*) 'lll=',lll
7285 cd            write (2,*) 'iii=2'
7286 cd            do jjj=1,2
7287 cd              write (2,'(3(2f10.5),5x)')
7288 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7289 cd            enddo
7290 cd          endif
7291         enddo
7292       enddo
7293       return
7294       end
7295 C---------------------------------------------------------------------------
7296       double precision function eello4(i,j,k,l,jj,kk)
7297       implicit real*8 (a-h,o-z)
7298       include 'DIMENSIONS'
7299       include 'COMMON.IOUNITS'
7300       include 'COMMON.CHAIN'
7301       include 'COMMON.DERIV'
7302       include 'COMMON.INTERACT'
7303       include 'COMMON.CONTACTS'
7304       include 'COMMON.TORSION'
7305       include 'COMMON.VAR'
7306       include 'COMMON.GEO'
7307       double precision pizda(2,2),ggg1(3),ggg2(3)
7308 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7309 cd        eello4=0.0d0
7310 cd        return
7311 cd      endif
7312 cd      print *,'eello4:',i,j,k,l,jj,kk
7313 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7314 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7315 cold      eij=facont_hb(jj,i)
7316 cold      ekl=facont_hb(kk,k)
7317 cold      ekont=eij*ekl
7318       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7319 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7320       gcorr_loc(k-1)=gcorr_loc(k-1)
7321      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7322       if (l.eq.j+1) then
7323         gcorr_loc(l-1)=gcorr_loc(l-1)
7324      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7325       else
7326         gcorr_loc(j-1)=gcorr_loc(j-1)
7327      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7328       endif
7329       do iii=1,2
7330         do kkk=1,5
7331           do lll=1,3
7332             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7333      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7334 cd            derx(lll,kkk,iii)=0.0d0
7335           enddo
7336         enddo
7337       enddo
7338 cd      gcorr_loc(l-1)=0.0d0
7339 cd      gcorr_loc(j-1)=0.0d0
7340 cd      gcorr_loc(k-1)=0.0d0
7341 cd      eel4=1.0d0
7342 cd      write (iout,*)'Contacts have occurred for peptide groups',
7343 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7344 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7345       if (j.lt.nres-1) then
7346         j1=j+1
7347         j2=j-1
7348       else
7349         j1=j-1
7350         j2=j-2
7351       endif
7352       if (l.lt.nres-1) then
7353         l1=l+1
7354         l2=l-1
7355       else
7356         l1=l-1
7357         l2=l-2
7358       endif
7359       do ll=1,3
7360 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7361 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7362         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7363         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7364 cgrad        ghalf=0.5d0*ggg1(ll)
7365         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7366         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7367         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7368         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7369         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7370         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7371 cgrad        ghalf=0.5d0*ggg2(ll)
7372         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7373         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7374         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7375         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7376         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7377         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7378       enddo
7379 cgrad      do m=i+1,j-1
7380 cgrad        do ll=1,3
7381 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7382 cgrad        enddo
7383 cgrad      enddo
7384 cgrad      do m=k+1,l-1
7385 cgrad        do ll=1,3
7386 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7387 cgrad        enddo
7388 cgrad      enddo
7389 cgrad      do m=i+2,j2
7390 cgrad        do ll=1,3
7391 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7392 cgrad        enddo
7393 cgrad      enddo
7394 cgrad      do m=k+2,l2
7395 cgrad        do ll=1,3
7396 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7397 cgrad        enddo
7398 cgrad      enddo
7399 cd      do iii=1,nres-3
7400 cd        write (2,*) iii,gcorr_loc(iii)
7401 cd      enddo
7402       eello4=ekont*eel4
7403 cd      write (2,*) 'ekont',ekont
7404 cd      write (iout,*) 'eello4',ekont*eel4
7405       return
7406       end
7407 C---------------------------------------------------------------------------
7408       double precision function eello5(i,j,k,l,jj,kk)
7409       implicit real*8 (a-h,o-z)
7410       include 'DIMENSIONS'
7411       include 'COMMON.IOUNITS'
7412       include 'COMMON.CHAIN'
7413       include 'COMMON.DERIV'
7414       include 'COMMON.INTERACT'
7415       include 'COMMON.CONTACTS'
7416       include 'COMMON.TORSION'
7417       include 'COMMON.VAR'
7418       include 'COMMON.GEO'
7419       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7420       double precision ggg1(3),ggg2(3)
7421 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7422 C                                                                              C
7423 C                            Parallel chains                                   C
7424 C                                                                              C
7425 C          o             o                   o             o                   C
7426 C         /l\           / \             \   / \           / \   /              C
7427 C        /   \         /   \             \ /   \         /   \ /               C
7428 C       j| o |l1       | o |              o| o |         | o |o                C
7429 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7430 C      \i/   \         /   \ /             /   \         /   \                 C
7431 C       o    k1             o                                                  C
7432 C         (I)          (II)                (III)          (IV)                 C
7433 C                                                                              C
7434 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7435 C                                                                              C
7436 C                            Antiparallel chains                               C
7437 C                                                                              C
7438 C          o             o                   o             o                   C
7439 C         /j\           / \             \   / \           / \   /              C
7440 C        /   \         /   \             \ /   \         /   \ /               C
7441 C      j1| o |l        | o |              o| o |         | o |o                C
7442 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7443 C      \i/   \         /   \ /             /   \         /   \                 C
7444 C       o     k1            o                                                  C
7445 C         (I)          (II)                (III)          (IV)                 C
7446 C                                                                              C
7447 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7448 C                                                                              C
7449 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7450 C                                                                              C
7451 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7452 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7453 cd        eello5=0.0d0
7454 cd        return
7455 cd      endif
7456 cd      write (iout,*)
7457 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7458 cd     &   ' and',k,l
7459       itk=itortyp(itype(k))
7460       itl=itortyp(itype(l))
7461       itj=itortyp(itype(j))
7462       eello5_1=0.0d0
7463       eello5_2=0.0d0
7464       eello5_3=0.0d0
7465       eello5_4=0.0d0
7466 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7467 cd     &   eel5_3_num,eel5_4_num)
7468       do iii=1,2
7469         do kkk=1,5
7470           do lll=1,3
7471             derx(lll,kkk,iii)=0.0d0
7472           enddo
7473         enddo
7474       enddo
7475 cd      eij=facont_hb(jj,i)
7476 cd      ekl=facont_hb(kk,k)
7477 cd      ekont=eij*ekl
7478 cd      write (iout,*)'Contacts have occurred for peptide groups',
7479 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7480 cd      goto 1111
7481 C Contribution from the graph I.
7482 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7483 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7484       call transpose2(EUg(1,1,k),auxmat(1,1))
7485       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7486       vv(1)=pizda(1,1)-pizda(2,2)
7487       vv(2)=pizda(1,2)+pizda(2,1)
7488       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7489      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7490 C Explicit gradient in virtual-dihedral angles.
7491       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7492      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7493      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7494       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7495       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7496       vv(1)=pizda(1,1)-pizda(2,2)
7497       vv(2)=pizda(1,2)+pizda(2,1)
7498       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7499      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7500      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7501       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7502       vv(1)=pizda(1,1)-pizda(2,2)
7503       vv(2)=pizda(1,2)+pizda(2,1)
7504       if (l.eq.j+1) then
7505         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7506      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7507      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7508       else
7509         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7510      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7511      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7512       endif
7513 C Cartesian gradient
7514       do iii=1,2
7515         do kkk=1,5
7516           do lll=1,3
7517             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7518      &        pizda(1,1))
7519             vv(1)=pizda(1,1)-pizda(2,2)
7520             vv(2)=pizda(1,2)+pizda(2,1)
7521             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7522      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7523      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7524           enddo
7525         enddo
7526       enddo
7527 c      goto 1112
7528 c1111  continue
7529 C Contribution from graph II
7530       call transpose2(EE(1,1,itk),auxmat(1,1))
7531       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7532       vv(1)=pizda(1,1)+pizda(2,2)
7533       vv(2)=pizda(2,1)-pizda(1,2)
7534       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7535      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7536 C Explicit gradient in virtual-dihedral angles.
7537       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7538      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7539       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7540       vv(1)=pizda(1,1)+pizda(2,2)
7541       vv(2)=pizda(2,1)-pizda(1,2)
7542       if (l.eq.j+1) then
7543         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7544      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7545      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7546       else
7547         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7548      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7549      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7550       endif
7551 C Cartesian gradient
7552       do iii=1,2
7553         do kkk=1,5
7554           do lll=1,3
7555             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7556      &        pizda(1,1))
7557             vv(1)=pizda(1,1)+pizda(2,2)
7558             vv(2)=pizda(2,1)-pizda(1,2)
7559             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7560      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7561      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7562           enddo
7563         enddo
7564       enddo
7565 cd      goto 1112
7566 cd1111  continue
7567       if (l.eq.j+1) then
7568 cd        goto 1110
7569 C Parallel orientation
7570 C Contribution from graph III
7571         call transpose2(EUg(1,1,l),auxmat(1,1))
7572         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7573         vv(1)=pizda(1,1)-pizda(2,2)
7574         vv(2)=pizda(1,2)+pizda(2,1)
7575         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7576      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7577 C Explicit gradient in virtual-dihedral angles.
7578         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7579      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7580      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7581         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7582         vv(1)=pizda(1,1)-pizda(2,2)
7583         vv(2)=pizda(1,2)+pizda(2,1)
7584         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7585      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7587         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7588         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7589         vv(1)=pizda(1,1)-pizda(2,2)
7590         vv(2)=pizda(1,2)+pizda(2,1)
7591         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7592      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7593      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7594 C Cartesian gradient
7595         do iii=1,2
7596           do kkk=1,5
7597             do lll=1,3
7598               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7599      &          pizda(1,1))
7600               vv(1)=pizda(1,1)-pizda(2,2)
7601               vv(2)=pizda(1,2)+pizda(2,1)
7602               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7603      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7604      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7605             enddo
7606           enddo
7607         enddo
7608 cd        goto 1112
7609 C Contribution from graph IV
7610 cd1110    continue
7611         call transpose2(EE(1,1,itl),auxmat(1,1))
7612         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7613         vv(1)=pizda(1,1)+pizda(2,2)
7614         vv(2)=pizda(2,1)-pizda(1,2)
7615         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7616      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7617 C Explicit gradient in virtual-dihedral angles.
7618         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7619      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7620         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7621         vv(1)=pizda(1,1)+pizda(2,2)
7622         vv(2)=pizda(2,1)-pizda(1,2)
7623         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7624      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7625      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7626 C Cartesian gradient
7627         do iii=1,2
7628           do kkk=1,5
7629             do lll=1,3
7630               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7631      &          pizda(1,1))
7632               vv(1)=pizda(1,1)+pizda(2,2)
7633               vv(2)=pizda(2,1)-pizda(1,2)
7634               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7635      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7636      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7637             enddo
7638           enddo
7639         enddo
7640       else
7641 C Antiparallel orientation
7642 C Contribution from graph III
7643 c        goto 1110
7644         call transpose2(EUg(1,1,j),auxmat(1,1))
7645         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7646         vv(1)=pizda(1,1)-pizda(2,2)
7647         vv(2)=pizda(1,2)+pizda(2,1)
7648         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7649      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7650 C Explicit gradient in virtual-dihedral angles.
7651         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7652      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7653      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7654         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7655         vv(1)=pizda(1,1)-pizda(2,2)
7656         vv(2)=pizda(1,2)+pizda(2,1)
7657         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7658      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7659      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7660         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7661         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7662         vv(1)=pizda(1,1)-pizda(2,2)
7663         vv(2)=pizda(1,2)+pizda(2,1)
7664         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7665      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7666      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7667 C Cartesian gradient
7668         do iii=1,2
7669           do kkk=1,5
7670             do lll=1,3
7671               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7672      &          pizda(1,1))
7673               vv(1)=pizda(1,1)-pizda(2,2)
7674               vv(2)=pizda(1,2)+pizda(2,1)
7675               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7676      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7677      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7678             enddo
7679           enddo
7680         enddo
7681 cd        goto 1112
7682 C Contribution from graph IV
7683 1110    continue
7684         call transpose2(EE(1,1,itj),auxmat(1,1))
7685         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7686         vv(1)=pizda(1,1)+pizda(2,2)
7687         vv(2)=pizda(2,1)-pizda(1,2)
7688         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7689      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7690 C Explicit gradient in virtual-dihedral angles.
7691         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7692      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7693         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7694         vv(1)=pizda(1,1)+pizda(2,2)
7695         vv(2)=pizda(2,1)-pizda(1,2)
7696         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7697      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7698      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7699 C Cartesian gradient
7700         do iii=1,2
7701           do kkk=1,5
7702             do lll=1,3
7703               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7704      &          pizda(1,1))
7705               vv(1)=pizda(1,1)+pizda(2,2)
7706               vv(2)=pizda(2,1)-pizda(1,2)
7707               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7708      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7709      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7710             enddo
7711           enddo
7712         enddo
7713       endif
7714 1112  continue
7715       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7716 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7717 cd        write (2,*) 'ijkl',i,j,k,l
7718 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7719 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7720 cd      endif
7721 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7722 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7723 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7724 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7725       if (j.lt.nres-1) then
7726         j1=j+1
7727         j2=j-1
7728       else
7729         j1=j-1
7730         j2=j-2
7731       endif
7732       if (l.lt.nres-1) then
7733         l1=l+1
7734         l2=l-1
7735       else
7736         l1=l-1
7737         l2=l-2
7738       endif
7739 cd      eij=1.0d0
7740 cd      ekl=1.0d0
7741 cd      ekont=1.0d0
7742 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7743 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7744 C        summed up outside the subrouine as for the other subroutines
7745 C        handling long-range interactions. The old code is commented out
7746 C        with "cgrad" to keep track of changes.
7747       do ll=1,3
7748 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7749 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7750         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7751         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7752 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7753 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7754 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7755 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7756 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7757 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7758 c     &   gradcorr5ij,
7759 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7760 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7761 cgrad        ghalf=0.5d0*ggg1(ll)
7762 cd        ghalf=0.0d0
7763         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7764         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7765         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7766         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7767         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7768         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7769 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7770 cgrad        ghalf=0.5d0*ggg2(ll)
7771 cd        ghalf=0.0d0
7772         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7773         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7774         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7775         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7776         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7777         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7778       enddo
7779 cd      goto 1112
7780 cgrad      do m=i+1,j-1
7781 cgrad        do ll=1,3
7782 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7783 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7784 cgrad        enddo
7785 cgrad      enddo
7786 cgrad      do m=k+1,l-1
7787 cgrad        do ll=1,3
7788 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7789 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7790 cgrad        enddo
7791 cgrad      enddo
7792 c1112  continue
7793 cgrad      do m=i+2,j2
7794 cgrad        do ll=1,3
7795 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7796 cgrad        enddo
7797 cgrad      enddo
7798 cgrad      do m=k+2,l2
7799 cgrad        do ll=1,3
7800 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7801 cgrad        enddo
7802 cgrad      enddo
7803 cd      do iii=1,nres-3
7804 cd        write (2,*) iii,g_corr5_loc(iii)
7805 cd      enddo
7806       eello5=ekont*eel5
7807 cd      write (2,*) 'ekont',ekont
7808 cd      write (iout,*) 'eello5',ekont*eel5
7809       return
7810       end
7811 c--------------------------------------------------------------------------
7812       double precision function eello6(i,j,k,l,jj,kk)
7813       implicit real*8 (a-h,o-z)
7814       include 'DIMENSIONS'
7815       include 'COMMON.IOUNITS'
7816       include 'COMMON.CHAIN'
7817       include 'COMMON.DERIV'
7818       include 'COMMON.INTERACT'
7819       include 'COMMON.CONTACTS'
7820       include 'COMMON.TORSION'
7821       include 'COMMON.VAR'
7822       include 'COMMON.GEO'
7823       include 'COMMON.FFIELD'
7824       double precision ggg1(3),ggg2(3)
7825 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7826 cd        eello6=0.0d0
7827 cd        return
7828 cd      endif
7829 cd      write (iout,*)
7830 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7831 cd     &   ' and',k,l
7832       eello6_1=0.0d0
7833       eello6_2=0.0d0
7834       eello6_3=0.0d0
7835       eello6_4=0.0d0
7836       eello6_5=0.0d0
7837       eello6_6=0.0d0
7838 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7839 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7840       do iii=1,2
7841         do kkk=1,5
7842           do lll=1,3
7843             derx(lll,kkk,iii)=0.0d0
7844           enddo
7845         enddo
7846       enddo
7847 cd      eij=facont_hb(jj,i)
7848 cd      ekl=facont_hb(kk,k)
7849 cd      ekont=eij*ekl
7850 cd      eij=1.0d0
7851 cd      ekl=1.0d0
7852 cd      ekont=1.0d0
7853       if (l.eq.j+1) then
7854         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7855         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7856         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7857         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7858         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7859         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7860       else
7861         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7862         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7863         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7864         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7865         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7866           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7867         else
7868           eello6_5=0.0d0
7869         endif
7870         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7871       endif
7872 C If turn contributions are considered, they will be handled separately.
7873       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7874 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7875 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7876 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7877 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7878 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7879 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7880 cd      goto 1112
7881       if (j.lt.nres-1) then
7882         j1=j+1
7883         j2=j-1
7884       else
7885         j1=j-1
7886         j2=j-2
7887       endif
7888       if (l.lt.nres-1) then
7889         l1=l+1
7890         l2=l-1
7891       else
7892         l1=l-1
7893         l2=l-2
7894       endif
7895       do ll=1,3
7896 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7897 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7898 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7899 cgrad        ghalf=0.5d0*ggg1(ll)
7900 cd        ghalf=0.0d0
7901         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7902         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7903         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7904         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7905         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7906         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7907         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7908         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7909 cgrad        ghalf=0.5d0*ggg2(ll)
7910 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7911 cd        ghalf=0.0d0
7912         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7913         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7914         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7915         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7916         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7917         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7918       enddo
7919 cd      goto 1112
7920 cgrad      do m=i+1,j-1
7921 cgrad        do ll=1,3
7922 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7923 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7924 cgrad        enddo
7925 cgrad      enddo
7926 cgrad      do m=k+1,l-1
7927 cgrad        do ll=1,3
7928 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7929 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7930 cgrad        enddo
7931 cgrad      enddo
7932 cgrad1112  continue
7933 cgrad      do m=i+2,j2
7934 cgrad        do ll=1,3
7935 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7936 cgrad        enddo
7937 cgrad      enddo
7938 cgrad      do m=k+2,l2
7939 cgrad        do ll=1,3
7940 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7941 cgrad        enddo
7942 cgrad      enddo
7943 cd      do iii=1,nres-3
7944 cd        write (2,*) iii,g_corr6_loc(iii)
7945 cd      enddo
7946       eello6=ekont*eel6
7947 cd      write (2,*) 'ekont',ekont
7948 cd      write (iout,*) 'eello6',ekont*eel6
7949       return
7950       end
7951 c--------------------------------------------------------------------------
7952       double precision function eello6_graph1(i,j,k,l,imat,swap)
7953       implicit real*8 (a-h,o-z)
7954       include 'DIMENSIONS'
7955       include 'COMMON.IOUNITS'
7956       include 'COMMON.CHAIN'
7957       include 'COMMON.DERIV'
7958       include 'COMMON.INTERACT'
7959       include 'COMMON.CONTACTS'
7960       include 'COMMON.TORSION'
7961       include 'COMMON.VAR'
7962       include 'COMMON.GEO'
7963       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7964       logical swap
7965       logical lprn
7966       common /kutas/ lprn
7967 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7968 C                                                                              C
7969 C      Parallel       Antiparallel                                             C
7970 C                                                                              C
7971 C          o             o                                                     C
7972 C         /l\           /j\                                                    C
7973 C        /   \         /   \                                                   C
7974 C       /| o |         | o |\                                                  C
7975 C     \ j|/k\|  /   \  |/k\|l /                                                C
7976 C      \ /   \ /     \ /   \ /                                                 C
7977 C       o     o       o     o                                                  C
7978 C       i             i                                                        C
7979 C                                                                              C
7980 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7981       itk=itortyp(itype(k))
7982       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7983       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7984       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7985       call transpose2(EUgC(1,1,k),auxmat(1,1))
7986       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7987       vv1(1)=pizda1(1,1)-pizda1(2,2)
7988       vv1(2)=pizda1(1,2)+pizda1(2,1)
7989       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7990       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7991       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7992       s5=scalar2(vv(1),Dtobr2(1,i))
7993 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7994       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7995       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7996      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7997      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7998      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7999      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8000      & +scalar2(vv(1),Dtobr2der(1,i)))
8001       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8002       vv1(1)=pizda1(1,1)-pizda1(2,2)
8003       vv1(2)=pizda1(1,2)+pizda1(2,1)
8004       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8005       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8006       if (l.eq.j+1) then
8007         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8008      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8009      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8010      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8011      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8012       else
8013         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8014      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8015      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8016      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8017      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8018       endif
8019       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8020       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8021       vv1(1)=pizda1(1,1)-pizda1(2,2)
8022       vv1(2)=pizda1(1,2)+pizda1(2,1)
8023       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8024      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8025      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8026      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8027       do iii=1,2
8028         if (swap) then
8029           ind=3-iii
8030         else
8031           ind=iii
8032         endif
8033         do kkk=1,5
8034           do lll=1,3
8035             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8036             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8037             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8038             call transpose2(EUgC(1,1,k),auxmat(1,1))
8039             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8040      &        pizda1(1,1))
8041             vv1(1)=pizda1(1,1)-pizda1(2,2)
8042             vv1(2)=pizda1(1,2)+pizda1(2,1)
8043             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8044             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8045      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8046             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8047      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8048             s5=scalar2(vv(1),Dtobr2(1,i))
8049             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8050           enddo
8051         enddo
8052       enddo
8053       return
8054       end
8055 c----------------------------------------------------------------------------
8056       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8057       implicit real*8 (a-h,o-z)
8058       include 'DIMENSIONS'
8059       include 'COMMON.IOUNITS'
8060       include 'COMMON.CHAIN'
8061       include 'COMMON.DERIV'
8062       include 'COMMON.INTERACT'
8063       include 'COMMON.CONTACTS'
8064       include 'COMMON.TORSION'
8065       include 'COMMON.VAR'
8066       include 'COMMON.GEO'
8067       logical swap
8068       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8069      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8070       logical lprn
8071       common /kutas/ lprn
8072 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8073 C                                                                              C
8074 C      Parallel       Antiparallel                                             C
8075 C                                                                              C
8076 C          o             o                                                     C
8077 C     \   /l\           /j\   /                                                C
8078 C      \ /   \         /   \ /                                                 C
8079 C       o| o |         | o |o                                                  C
8080 C     \ j|/k\|      \  |/k\|l                                                  C
8081 C      \ /   \       \ /   \                                                   C
8082 C       o             o                                                        C
8083 C       i             i                                                        C
8084 C                                                                              C
8085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8086 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8087 C AL 7/4/01 s1 would occur in the sixth-order moment,
8088 C           but not in a cluster cumulant
8089 #ifdef MOMENT
8090       s1=dip(1,jj,i)*dip(1,kk,k)
8091 #endif
8092       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8093       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8094       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8095       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8096       call transpose2(EUg(1,1,k),auxmat(1,1))
8097       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8098       vv(1)=pizda(1,1)-pizda(2,2)
8099       vv(2)=pizda(1,2)+pizda(2,1)
8100       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8101 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8102 #ifdef MOMENT
8103       eello6_graph2=-(s1+s2+s3+s4)
8104 #else
8105       eello6_graph2=-(s2+s3+s4)
8106 #endif
8107 c      eello6_graph2=-s3
8108 C Derivatives in gamma(i-1)
8109       if (i.gt.1) then
8110 #ifdef MOMENT
8111         s1=dipderg(1,jj,i)*dip(1,kk,k)
8112 #endif
8113         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8114         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8115         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8116         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8117 #ifdef MOMENT
8118         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8119 #else
8120         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8121 #endif
8122 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8123       endif
8124 C Derivatives in gamma(k-1)
8125 #ifdef MOMENT
8126       s1=dip(1,jj,i)*dipderg(1,kk,k)
8127 #endif
8128       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8129       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8130       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8131       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8132       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8133       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8134       vv(1)=pizda(1,1)-pizda(2,2)
8135       vv(2)=pizda(1,2)+pizda(2,1)
8136       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8137 #ifdef MOMENT
8138       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8139 #else
8140       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8141 #endif
8142 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8143 C Derivatives in gamma(j-1) or gamma(l-1)
8144       if (j.gt.1) then
8145 #ifdef MOMENT
8146         s1=dipderg(3,jj,i)*dip(1,kk,k)
8147 #endif
8148         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8149         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8150         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8151         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8152         vv(1)=pizda(1,1)-pizda(2,2)
8153         vv(2)=pizda(1,2)+pizda(2,1)
8154         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8155 #ifdef MOMENT
8156         if (swap) then
8157           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8158         else
8159           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8160         endif
8161 #endif
8162         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8163 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8164       endif
8165 C Derivatives in gamma(l-1) or gamma(j-1)
8166       if (l.gt.1) then
8167 #ifdef MOMENT
8168         s1=dip(1,jj,i)*dipderg(3,kk,k)
8169 #endif
8170         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8171         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8172         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8173         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8174         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8175         vv(1)=pizda(1,1)-pizda(2,2)
8176         vv(2)=pizda(1,2)+pizda(2,1)
8177         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8178 #ifdef MOMENT
8179         if (swap) then
8180           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8181         else
8182           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8183         endif
8184 #endif
8185         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8186 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8187       endif
8188 C Cartesian derivatives.
8189       if (lprn) then
8190         write (2,*) 'In eello6_graph2'
8191         do iii=1,2
8192           write (2,*) 'iii=',iii
8193           do kkk=1,5
8194             write (2,*) 'kkk=',kkk
8195             do jjj=1,2
8196               write (2,'(3(2f10.5),5x)')
8197      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8198             enddo
8199           enddo
8200         enddo
8201       endif
8202       do iii=1,2
8203         do kkk=1,5
8204           do lll=1,3
8205 #ifdef MOMENT
8206             if (iii.eq.1) then
8207               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8208             else
8209               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8210             endif
8211 #endif
8212             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8213      &        auxvec(1))
8214             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8215             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8216      &        auxvec(1))
8217             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8218             call transpose2(EUg(1,1,k),auxmat(1,1))
8219             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8220      &        pizda(1,1))
8221             vv(1)=pizda(1,1)-pizda(2,2)
8222             vv(2)=pizda(1,2)+pizda(2,1)
8223             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8224 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8225 #ifdef MOMENT
8226             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8227 #else
8228             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8229 #endif
8230             if (swap) then
8231               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8232             else
8233               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8234             endif
8235           enddo
8236         enddo
8237       enddo
8238       return
8239       end
8240 c----------------------------------------------------------------------------
8241       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8242       implicit real*8 (a-h,o-z)
8243       include 'DIMENSIONS'
8244       include 'COMMON.IOUNITS'
8245       include 'COMMON.CHAIN'
8246       include 'COMMON.DERIV'
8247       include 'COMMON.INTERACT'
8248       include 'COMMON.CONTACTS'
8249       include 'COMMON.TORSION'
8250       include 'COMMON.VAR'
8251       include 'COMMON.GEO'
8252       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8253       logical swap
8254 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8255 C                                                                              C
8256 C      Parallel       Antiparallel                                             C
8257 C                                                                              C
8258 C          o             o                                                     C
8259 C         /l\   /   \   /j\                                                    C
8260 C        /   \ /     \ /   \                                                   C
8261 C       /| o |o       o| o |\                                                  C
8262 C       j|/k\|  /      |/k\|l /                                                C
8263 C        /   \ /       /   \ /                                                 C
8264 C       /     o       /     o                                                  C
8265 C       i             i                                                        C
8266 C                                                                              C
8267 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8268 C
8269 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8270 C           energy moment and not to the cluster cumulant.
8271       iti=itortyp(itype(i))
8272       if (j.lt.nres-1) then
8273         itj1=itortyp(itype(j+1))
8274       else
8275         itj1=ntortyp+1
8276       endif
8277       itk=itortyp(itype(k))
8278       itk1=itortyp(itype(k+1))
8279       if (l.lt.nres-1) then
8280         itl1=itortyp(itype(l+1))
8281       else
8282         itl1=ntortyp+1
8283       endif
8284 #ifdef MOMENT
8285       s1=dip(4,jj,i)*dip(4,kk,k)
8286 #endif
8287       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8288       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8289       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8290       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8291       call transpose2(EE(1,1,itk),auxmat(1,1))
8292       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8293       vv(1)=pizda(1,1)+pizda(2,2)
8294       vv(2)=pizda(2,1)-pizda(1,2)
8295       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8296 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8297 cd     & "sum",-(s2+s3+s4)
8298 #ifdef MOMENT
8299       eello6_graph3=-(s1+s2+s3+s4)
8300 #else
8301       eello6_graph3=-(s2+s3+s4)
8302 #endif
8303 c      eello6_graph3=-s4
8304 C Derivatives in gamma(k-1)
8305       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8306       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8307       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8308       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8309 C Derivatives in gamma(l-1)
8310       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8311       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8312       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8313       vv(1)=pizda(1,1)+pizda(2,2)
8314       vv(2)=pizda(2,1)-pizda(1,2)
8315       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8316       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8317 C Cartesian derivatives.
8318       do iii=1,2
8319         do kkk=1,5
8320           do lll=1,3
8321 #ifdef MOMENT
8322             if (iii.eq.1) then
8323               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8324             else
8325               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8326             endif
8327 #endif
8328             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8329      &        auxvec(1))
8330             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8331             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8332      &        auxvec(1))
8333             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8334             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8335      &        pizda(1,1))
8336             vv(1)=pizda(1,1)+pizda(2,2)
8337             vv(2)=pizda(2,1)-pizda(1,2)
8338             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8339 #ifdef MOMENT
8340             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8341 #else
8342             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8343 #endif
8344             if (swap) then
8345               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8346             else
8347               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8348             endif
8349 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8350           enddo
8351         enddo
8352       enddo
8353       return
8354       end
8355 c----------------------------------------------------------------------------
8356       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8357       implicit real*8 (a-h,o-z)
8358       include 'DIMENSIONS'
8359       include 'COMMON.IOUNITS'
8360       include 'COMMON.CHAIN'
8361       include 'COMMON.DERIV'
8362       include 'COMMON.INTERACT'
8363       include 'COMMON.CONTACTS'
8364       include 'COMMON.TORSION'
8365       include 'COMMON.VAR'
8366       include 'COMMON.GEO'
8367       include 'COMMON.FFIELD'
8368       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8369      & auxvec1(2),auxmat1(2,2)
8370       logical swap
8371 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8372 C                                                                              C
8373 C      Parallel       Antiparallel                                             C
8374 C                                                                              C
8375 C          o             o                                                     C
8376 C         /l\   /   \   /j\                                                    C
8377 C        /   \ /     \ /   \                                                   C
8378 C       /| o |o       o| o |\                                                  C
8379 C     \ j|/k\|      \  |/k\|l                                                  C
8380 C      \ /   \       \ /   \                                                   C
8381 C       o     \       o     \                                                  C
8382 C       i             i                                                        C
8383 C                                                                              C
8384 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8385 C
8386 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8387 C           energy moment and not to the cluster cumulant.
8388 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8389       iti=itortyp(itype(i))
8390       itj=itortyp(itype(j))
8391       if (j.lt.nres-1) then
8392         itj1=itortyp(itype(j+1))
8393       else
8394         itj1=ntortyp+1
8395       endif
8396       itk=itortyp(itype(k))
8397       if (k.lt.nres-1) then
8398         itk1=itortyp(itype(k+1))
8399       else
8400         itk1=ntortyp+1
8401       endif
8402       itl=itortyp(itype(l))
8403       if (l.lt.nres-1) then
8404         itl1=itortyp(itype(l+1))
8405       else
8406         itl1=ntortyp+1
8407       endif
8408 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8409 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8410 cd     & ' itl',itl,' itl1',itl1
8411 #ifdef MOMENT
8412       if (imat.eq.1) then
8413         s1=dip(3,jj,i)*dip(3,kk,k)
8414       else
8415         s1=dip(2,jj,j)*dip(2,kk,l)
8416       endif
8417 #endif
8418       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8419       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8420       if (j.eq.l+1) then
8421         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8422         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8423       else
8424         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8425         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8426       endif
8427       call transpose2(EUg(1,1,k),auxmat(1,1))
8428       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8429       vv(1)=pizda(1,1)-pizda(2,2)
8430       vv(2)=pizda(2,1)+pizda(1,2)
8431       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8432 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8433 #ifdef MOMENT
8434       eello6_graph4=-(s1+s2+s3+s4)
8435 #else
8436       eello6_graph4=-(s2+s3+s4)
8437 #endif
8438 C Derivatives in gamma(i-1)
8439       if (i.gt.1) then
8440 #ifdef MOMENT
8441         if (imat.eq.1) then
8442           s1=dipderg(2,jj,i)*dip(3,kk,k)
8443         else
8444           s1=dipderg(4,jj,j)*dip(2,kk,l)
8445         endif
8446 #endif
8447         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8448         if (j.eq.l+1) then
8449           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8450           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8451         else
8452           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8453           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8454         endif
8455         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8456         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8457 cd          write (2,*) 'turn6 derivatives'
8458 #ifdef MOMENT
8459           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8460 #else
8461           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8462 #endif
8463         else
8464 #ifdef MOMENT
8465           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8466 #else
8467           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8468 #endif
8469         endif
8470       endif
8471 C Derivatives in gamma(k-1)
8472 #ifdef MOMENT
8473       if (imat.eq.1) then
8474         s1=dip(3,jj,i)*dipderg(2,kk,k)
8475       else
8476         s1=dip(2,jj,j)*dipderg(4,kk,l)
8477       endif
8478 #endif
8479       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8480       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8481       if (j.eq.l+1) then
8482         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8483         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8484       else
8485         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8486         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8487       endif
8488       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8489       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8490       vv(1)=pizda(1,1)-pizda(2,2)
8491       vv(2)=pizda(2,1)+pizda(1,2)
8492       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8493       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8494 #ifdef MOMENT
8495         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8496 #else
8497         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8498 #endif
8499       else
8500 #ifdef MOMENT
8501         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8502 #else
8503         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8504 #endif
8505       endif
8506 C Derivatives in gamma(j-1) or gamma(l-1)
8507       if (l.eq.j+1 .and. l.gt.1) then
8508         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8509         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8510         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8511         vv(1)=pizda(1,1)-pizda(2,2)
8512         vv(2)=pizda(2,1)+pizda(1,2)
8513         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8514         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8515       else if (j.gt.1) then
8516         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8517         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8518         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8519         vv(1)=pizda(1,1)-pizda(2,2)
8520         vv(2)=pizda(2,1)+pizda(1,2)
8521         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8522         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8523           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8524         else
8525           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8526         endif
8527       endif
8528 C Cartesian derivatives.
8529       do iii=1,2
8530         do kkk=1,5
8531           do lll=1,3
8532 #ifdef MOMENT
8533             if (iii.eq.1) then
8534               if (imat.eq.1) then
8535                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8536               else
8537                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8538               endif
8539             else
8540               if (imat.eq.1) then
8541                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8542               else
8543                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8544               endif
8545             endif
8546 #endif
8547             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8548      &        auxvec(1))
8549             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8550             if (j.eq.l+1) then
8551               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8552      &          b1(1,itj1),auxvec(1))
8553               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8554             else
8555               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8556      &          b1(1,itl1),auxvec(1))
8557               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8558             endif
8559             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8560      &        pizda(1,1))
8561             vv(1)=pizda(1,1)-pizda(2,2)
8562             vv(2)=pizda(2,1)+pizda(1,2)
8563             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8564             if (swap) then
8565               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8566 #ifdef MOMENT
8567                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8568      &             -(s1+s2+s4)
8569 #else
8570                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8571      &             -(s2+s4)
8572 #endif
8573                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8574               else
8575 #ifdef MOMENT
8576                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8577 #else
8578                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8579 #endif
8580                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8581               endif
8582             else
8583 #ifdef MOMENT
8584               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8585 #else
8586               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8587 #endif
8588               if (l.eq.j+1) then
8589                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8590               else
8591                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8592               endif
8593             endif
8594           enddo
8595         enddo
8596       enddo
8597       return
8598       end
8599 c----------------------------------------------------------------------------
8600       double precision function eello_turn6(i,jj,kk)
8601       implicit real*8 (a-h,o-z)
8602       include 'DIMENSIONS'
8603       include 'COMMON.IOUNITS'
8604       include 'COMMON.CHAIN'
8605       include 'COMMON.DERIV'
8606       include 'COMMON.INTERACT'
8607       include 'COMMON.CONTACTS'
8608       include 'COMMON.TORSION'
8609       include 'COMMON.VAR'
8610       include 'COMMON.GEO'
8611       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8612      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8613      &  ggg1(3),ggg2(3)
8614       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8615      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8616 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8617 C           the respective energy moment and not to the cluster cumulant.
8618       s1=0.0d0
8619       s8=0.0d0
8620       s13=0.0d0
8621 c
8622       eello_turn6=0.0d0
8623       j=i+4
8624       k=i+1
8625       l=i+3
8626       iti=itortyp(itype(i))
8627       itk=itortyp(itype(k))
8628       itk1=itortyp(itype(k+1))
8629       itl=itortyp(itype(l))
8630       itj=itortyp(itype(j))
8631 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8632 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8633 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8634 cd        eello6=0.0d0
8635 cd        return
8636 cd      endif
8637 cd      write (iout,*)
8638 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8639 cd     &   ' and',k,l
8640 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8641       do iii=1,2
8642         do kkk=1,5
8643           do lll=1,3
8644             derx_turn(lll,kkk,iii)=0.0d0
8645           enddo
8646         enddo
8647       enddo
8648 cd      eij=1.0d0
8649 cd      ekl=1.0d0
8650 cd      ekont=1.0d0
8651       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8652 cd      eello6_5=0.0d0
8653 cd      write (2,*) 'eello6_5',eello6_5
8654 #ifdef MOMENT
8655       call transpose2(AEA(1,1,1),auxmat(1,1))
8656       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8657       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8658       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8659 #endif
8660       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8661       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8662       s2 = scalar2(b1(1,itk),vtemp1(1))
8663 #ifdef MOMENT
8664       call transpose2(AEA(1,1,2),atemp(1,1))
8665       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8666       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8667       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8668 #endif
8669       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8670       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8671       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8672 #ifdef MOMENT
8673       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8674       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8675       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8676       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8677       ss13 = scalar2(b1(1,itk),vtemp4(1))
8678       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8679 #endif
8680 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8681 c      s1=0.0d0
8682 c      s2=0.0d0
8683 c      s8=0.0d0
8684 c      s12=0.0d0
8685 c      s13=0.0d0
8686       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8687 C Derivatives in gamma(i+2)
8688       s1d =0.0d0
8689       s8d =0.0d0
8690 #ifdef MOMENT
8691       call transpose2(AEA(1,1,1),auxmatd(1,1))
8692       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8693       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8694       call transpose2(AEAderg(1,1,2),atempd(1,1))
8695       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8696       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8697 #endif
8698       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8699       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8700       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8701 c      s1d=0.0d0
8702 c      s2d=0.0d0
8703 c      s8d=0.0d0
8704 c      s12d=0.0d0
8705 c      s13d=0.0d0
8706       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8707 C Derivatives in gamma(i+3)
8708 #ifdef MOMENT
8709       call transpose2(AEA(1,1,1),auxmatd(1,1))
8710       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8711       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8712       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8713 #endif
8714       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8715       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8716       s2d = scalar2(b1(1,itk),vtemp1d(1))
8717 #ifdef MOMENT
8718       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8719       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8720 #endif
8721       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8722 #ifdef MOMENT
8723       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8724       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8725       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8726 #endif
8727 c      s1d=0.0d0
8728 c      s2d=0.0d0
8729 c      s8d=0.0d0
8730 c      s12d=0.0d0
8731 c      s13d=0.0d0
8732 #ifdef MOMENT
8733       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8734      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8735 #else
8736       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8737      &               -0.5d0*ekont*(s2d+s12d)
8738 #endif
8739 C Derivatives in gamma(i+4)
8740       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8741       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8742       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8743 #ifdef MOMENT
8744       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8745       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8746       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8747 #endif
8748 c      s1d=0.0d0
8749 c      s2d=0.0d0
8750 c      s8d=0.0d0
8751 C      s12d=0.0d0
8752 c      s13d=0.0d0
8753 #ifdef MOMENT
8754       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8755 #else
8756       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8757 #endif
8758 C Derivatives in gamma(i+5)
8759 #ifdef MOMENT
8760       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8761       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8762       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8763 #endif
8764       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8765       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8766       s2d = scalar2(b1(1,itk),vtemp1d(1))
8767 #ifdef MOMENT
8768       call transpose2(AEA(1,1,2),atempd(1,1))
8769       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8770       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8771 #endif
8772       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8773       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8774 #ifdef MOMENT
8775       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8776       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8777       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8778 #endif
8779 c      s1d=0.0d0
8780 c      s2d=0.0d0
8781 c      s8d=0.0d0
8782 c      s12d=0.0d0
8783 c      s13d=0.0d0
8784 #ifdef MOMENT
8785       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8786      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8787 #else
8788       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8789      &               -0.5d0*ekont*(s2d+s12d)
8790 #endif
8791 C Cartesian derivatives
8792       do iii=1,2
8793         do kkk=1,5
8794           do lll=1,3
8795 #ifdef MOMENT
8796             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8797             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8798             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8799 #endif
8800             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8801             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8802      &          vtemp1d(1))
8803             s2d = scalar2(b1(1,itk),vtemp1d(1))
8804 #ifdef MOMENT
8805             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8806             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8807             s8d = -(atempd(1,1)+atempd(2,2))*
8808      &           scalar2(cc(1,1,itl),vtemp2(1))
8809 #endif
8810             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8811      &           auxmatd(1,1))
8812             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8813             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8814 c      s1d=0.0d0
8815 c      s2d=0.0d0
8816 c      s8d=0.0d0
8817 c      s12d=0.0d0
8818 c      s13d=0.0d0
8819 #ifdef MOMENT
8820             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8821      &        - 0.5d0*(s1d+s2d)
8822 #else
8823             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8824      &        - 0.5d0*s2d
8825 #endif
8826 #ifdef MOMENT
8827             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8828      &        - 0.5d0*(s8d+s12d)
8829 #else
8830             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8831      &        - 0.5d0*s12d
8832 #endif
8833           enddo
8834         enddo
8835       enddo
8836 #ifdef MOMENT
8837       do kkk=1,5
8838         do lll=1,3
8839           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8840      &      achuj_tempd(1,1))
8841           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8842           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8843           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8844           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8845           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8846      &      vtemp4d(1))
8847           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8848           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8849           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8850         enddo
8851       enddo
8852 #endif
8853 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8854 cd     &  16*eel_turn6_num
8855 cd      goto 1112
8856       if (j.lt.nres-1) then
8857         j1=j+1
8858         j2=j-1
8859       else
8860         j1=j-1
8861         j2=j-2
8862       endif
8863       if (l.lt.nres-1) then
8864         l1=l+1
8865         l2=l-1
8866       else
8867         l1=l-1
8868         l2=l-2
8869       endif
8870       do ll=1,3
8871 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8872 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8873 cgrad        ghalf=0.5d0*ggg1(ll)
8874 cd        ghalf=0.0d0
8875         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8876         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8877         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8878      &    +ekont*derx_turn(ll,2,1)
8879         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8880         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8881      &    +ekont*derx_turn(ll,4,1)
8882         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8883         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8884         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8885 cgrad        ghalf=0.5d0*ggg2(ll)
8886 cd        ghalf=0.0d0
8887         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8888      &    +ekont*derx_turn(ll,2,2)
8889         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8890         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8891      &    +ekont*derx_turn(ll,4,2)
8892         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8893         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8894         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8895       enddo
8896 cd      goto 1112
8897 cgrad      do m=i+1,j-1
8898 cgrad        do ll=1,3
8899 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8900 cgrad        enddo
8901 cgrad      enddo
8902 cgrad      do m=k+1,l-1
8903 cgrad        do ll=1,3
8904 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8905 cgrad        enddo
8906 cgrad      enddo
8907 cgrad1112  continue
8908 cgrad      do m=i+2,j2
8909 cgrad        do ll=1,3
8910 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8911 cgrad        enddo
8912 cgrad      enddo
8913 cgrad      do m=k+2,l2
8914 cgrad        do ll=1,3
8915 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8916 cgrad        enddo
8917 cgrad      enddo
8918 cd      do iii=1,nres-3
8919 cd        write (2,*) iii,g_corr6_loc(iii)
8920 cd      enddo
8921       eello_turn6=ekont*eel_turn6
8922 cd      write (2,*) 'ekont',ekont
8923 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8924       return
8925       end
8926
8927 C-----------------------------------------------------------------------------
8928       double precision function scalar(u,v)
8929 !DIR$ INLINEALWAYS scalar
8930 #ifndef OSF
8931 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8932 #endif
8933       implicit none
8934       double precision u(3),v(3)
8935 cd      double precision sc
8936 cd      integer i
8937 cd      sc=0.0d0
8938 cd      do i=1,3
8939 cd        sc=sc+u(i)*v(i)
8940 cd      enddo
8941 cd      scalar=sc
8942
8943       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8944       return
8945       end
8946 crc-------------------------------------------------
8947       SUBROUTINE MATVEC2(A1,V1,V2)
8948 !DIR$ INLINEALWAYS MATVEC2
8949 #ifndef OSF
8950 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8951 #endif
8952       implicit real*8 (a-h,o-z)
8953       include 'DIMENSIONS'
8954       DIMENSION A1(2,2),V1(2),V2(2)
8955 c      DO 1 I=1,2
8956 c        VI=0.0
8957 c        DO 3 K=1,2
8958 c    3     VI=VI+A1(I,K)*V1(K)
8959 c        Vaux(I)=VI
8960 c    1 CONTINUE
8961
8962       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8963       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8964
8965       v2(1)=vaux1
8966       v2(2)=vaux2
8967       END
8968 C---------------------------------------
8969       SUBROUTINE MATMAT2(A1,A2,A3)
8970 #ifndef OSF
8971 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8972 #endif
8973       implicit real*8 (a-h,o-z)
8974       include 'DIMENSIONS'
8975       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8976 c      DIMENSION AI3(2,2)
8977 c        DO  J=1,2
8978 c          A3IJ=0.0
8979 c          DO K=1,2
8980 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8981 c          enddo
8982 c          A3(I,J)=A3IJ
8983 c       enddo
8984 c      enddo
8985
8986       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8987       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8988       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8989       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8990
8991       A3(1,1)=AI3_11
8992       A3(2,1)=AI3_21
8993       A3(1,2)=AI3_12
8994       A3(2,2)=AI3_22
8995       END
8996
8997 c-------------------------------------------------------------------------
8998       double precision function scalar2(u,v)
8999 !DIR$ INLINEALWAYS scalar2
9000       implicit none
9001       double precision u(2),v(2)
9002       double precision sc
9003       integer i
9004       scalar2=u(1)*v(1)+u(2)*v(2)
9005       return
9006       end
9007
9008 C-----------------------------------------------------------------------------
9009
9010       subroutine transpose2(a,at)
9011 !DIR$ INLINEALWAYS transpose2
9012 #ifndef OSF
9013 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9014 #endif
9015       implicit none
9016       double precision a(2,2),at(2,2)
9017       at(1,1)=a(1,1)
9018       at(1,2)=a(2,1)
9019       at(2,1)=a(1,2)
9020       at(2,2)=a(2,2)
9021       return
9022       end
9023 c--------------------------------------------------------------------------
9024       subroutine transpose(n,a,at)
9025       implicit none
9026       integer n,i,j
9027       double precision a(n,n),at(n,n)
9028       do i=1,n
9029         do j=1,n
9030           at(j,i)=a(i,j)
9031         enddo
9032       enddo
9033       return
9034       end
9035 C---------------------------------------------------------------------------
9036       subroutine prodmat3(a1,a2,kk,transp,prod)
9037 !DIR$ INLINEALWAYS prodmat3
9038 #ifndef OSF
9039 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9040 #endif
9041       implicit none
9042       integer i,j
9043       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9044       logical transp
9045 crc      double precision auxmat(2,2),prod_(2,2)
9046
9047       if (transp) then
9048 crc        call transpose2(kk(1,1),auxmat(1,1))
9049 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9050 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9051
9052            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9053      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9054            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9055      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9056            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9057      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9058            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9059      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9060
9061       else
9062 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9063 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9064
9065            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9066      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9067            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9068      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9069            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9070      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9071            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9072      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9073
9074       endif
9075 c      call transpose2(a2(1,1),a2t(1,1))
9076
9077 crc      print *,transp
9078 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9079 crc      print *,((prod(i,j),i=1,2),j=1,2)
9080
9081       return
9082       end
9083