source/unres/src_CSA_DiL/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
 127 C     JUYONG for dfa test!
 128       if (wdfa_dist.gt.0) call edfad(edfadis)
 129 c      print*, 'edfad is finished!', edfadis
 130       if (wdfa_tor.gt.0) call edfat(edfator)
 131 c      print*, 'edfat is finished!', edfator
 132       if (wdfa_nei.gt.0) call edfan(edfanei)
 133 c      print*, 'edfan is finished!', edfanei
 134       if (wdfa_beta.gt.0) call edfab(edfabet)
 135 c      print*, 'edfab is finished!', edfabet
 136 C      stop
 137 C     JUYONG
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141       time01=MPI_Wtime()
 142 #endif
 143       call vec_and_deriv
 144 #ifdef TIMING
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #endif
 147 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 148       if (ipot.lt.6) then
 149 #ifdef SPLITELE
 150          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #else
 155          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 156      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 157      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 158      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 159 #endif
 160             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 161          else
 162             ees=0.0d0
 163             evdw1=0.0d0
 164             eel_loc=0.0d0
 165             eello_turn3=0.0d0
 166             eello_turn4=0.0d0
 167          endif
 168       else
 169 c        write (iout,*) "Soft-spheer ELEC potential"
 170         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 171      &   eello_turn4)
 172       endif
 173 c      print *,"Processor",myrank," computed UELEC"
 174 C
 175 C Calculate excluded-volume interaction energy between peptide groups
 176 C and side chains.
 177 C
 178       if (ipot.lt.6) then
 179        if(wscp.gt.0d0) then
 180         call escp(evdw2,evdw2_14)
 181        else
 182         evdw2=0
 183         evdw2_14=0
 184        endif
 185       else
 186 c        write (iout,*) "Soft-sphere SCP potential"
 187         call escp_soft_sphere(evdw2,evdw2_14)
 188       endif
 189 c
 190 c Calculate the bond-stretching energy
 191 c
 192       call ebond(estr)
 193 C
 194 C Calculate the disulfide-bridge and other energy and the contributions
 195 C from other distance constraints.
 196 cd    print *,'Calling EHPB'
 197       call edis(ehpb)
 198 cd    print *,'EHPB exitted succesfully.'
 199 C
 200 C Calculate the virtual-bond-angle energy.
 201 C
 202       if (wang.gt.0d0) then
 203         call ebend(ebe)
 204       else
 205         ebe=0
 206       endif
 207 c      print *,"Processor",myrank," computed UB"
 208 C
 209 C Calculate the SC local energy.
 210 C
 211       call esc(escloc)
 212 c      print *,"Processor",myrank," computed USC"
 213 C
 214 C Calculate the virtual-bond torsional energy.
 215 C
 216 cd    print *,'nterm=',nterm
 217       if (wtor.gt.0) then
 218        call etor(etors,edihcnstr)
 219       else
 220        etors=0
 221        edihcnstr=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utor"
 224 C
 225 C 6/23/01 Calculate double-torsional energy
 226 C
 227       if (wtor_d.gt.0) then
 228        call etor_d(etors_d)
 229       else
 230        etors_d=0
 231       endif
 232 c      print *,"Processor",myrank," computed Utord"
 233 C
 234 C 21/5/07 Calculate local sicdechain correlation energy
 235 C
 236       if (wsccor.gt.0.0d0) then
 237         call eback_sc_corr(esccor)
 238       else
 239         esccor=0.0d0
 240       endif
 241 c      print *,"Processor",myrank," computed Usccorr"
 242 C
 243 C 12/1/95 Multi-body terms
 244 C
 245       n_corr=0
 246       n_corr1=0
 247       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 248      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 250 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 251 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 252       else
 253          ecorr=0.0d0
 254          ecorr5=0.0d0
 255          ecorr6=0.0d0
 256          eturn6=0.0d0
 257       endif
 258       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 259          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 260 cd         write (iout,*) "multibody_hb ecorr",ecorr
 261       endif
 262 c      print *,"Processor",myrank," computed Ucorr"
 263 C
 264 C If performing constraint dynamics, call the constraint energy
 265 C  after the equilibration time
 266       if(usampl.and.totT.gt.eq_time) then
 267 c         call EconstrQ
 268          call Econstr_back
 269       else
 270          Uconst=0.0d0
 271          Uconst_back=0.0d0
 272       endif
 273 #ifdef TIMING
 274       time_enecalc=time_enecalc+MPI_Wtime()-time00
 275 #endif
 276 c      print *,"Processor",myrank," computed Uconstr"
 277 #ifdef TIMING
 278       time00=MPI_Wtime()
 279 #endif
 280 c
 281 C Sum the energies
 282 C
 283       energia(1)=evdw
 284 #ifdef SCP14
 285       energia(2)=evdw2-evdw2_14
 286       energia(18)=evdw2_14
 287 #else
 288       energia(2)=evdw2
 289       energia(18)=0.0d0
 290 #endif
 291 #ifdef SPLITELE
 292       energia(3)=ees
 293       energia(16)=evdw1
 294 #else
 295       energia(3)=ees+evdw1
 296       energia(16)=0.0d0
 297 #endif
 298       energia(4)=ecorr
 299       energia(5)=ecorr5
 300       energia(6)=ecorr6
 301       energia(7)=eel_loc
 302       energia(8)=eello_turn3
 303       energia(9)=eello_turn4
 304       energia(10)=eturn6
 305       energia(11)=ebe
 306       energia(12)=escloc
 307       energia(13)=etors
 308       energia(14)=etors_d
 309       energia(15)=ehpb
 310       energia(19)=edihcnstr
 311       energia(17)=estr
 312       energia(20)=Uconst+Uconst_back
 313       energia(21)=esccor
 314       energia(22)=evdw_p
 315       energia(23)=evdw_m
 316       energia(24)=edfadis
 317       energia(25)=edfator
 318       energia(26)=edfanei
 319       energia(27)=edfabet
 320 c      print *," Processor",myrank," calls SUM_ENERGY"
 321       call sum_energy(energia,.true.)
 322 c      print *," Processor",myrank," left SUM_ENERGY"
 323 #ifdef TIMING
 324       time_sumene=time_sumene+MPI_Wtime()-time00
 325 #endif
 326
 327 c      print*, 'etot:',energia(0)
 328
 329       return
 330       end
 331 c-------------------------------------------------------------------------------
 332       subroutine sum_energy(energia,reduce)
 333       implicit real*8 (a-h,o-z)
 334       include 'DIMENSIONS'
 335 #ifndef ISNAN
 336       external proc_proc
 337 #ifdef WINPGI
 338 cMS$ATTRIBUTES C ::  proc_proc
 339 #endif
 340 #endif
 341 #ifdef MPI
 342       include "mpif.h"
 343 #endif
 344       include 'COMMON.SETUP'
 345       include 'COMMON.IOUNITS'
 346       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 347       include 'COMMON.FFIELD'
 348       include 'COMMON.DERIV'
 349       include 'COMMON.INTERACT'
 350       include 'COMMON.SBRIDGE'
 351       include 'COMMON.CHAIN'
 352       include 'COMMON.VAR'
 353       include 'COMMON.CONTROL'
 354       include 'COMMON.TIME1'
 355       logical reduce
 356 #ifdef MPI
 357       if (nfgtasks.gt.1 .and. reduce) then
 358 #ifdef DEBUG
 359         write (iout,*) "energies before REDUCE"
 360         call enerprint(energia)
 361         call flush(iout)
 362 #endif
 363         do i=0,n_ene
 364           enebuff(i)=energia(i)
 365         enddo
 366         time00=MPI_Wtime()
 367         call MPI_Barrier(FG_COMM,IERR)
 368         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 369         time00=MPI_Wtime()
 370         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 371      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 372 #ifdef DEBUG
 373         write (iout,*) "energies after REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         time_Reduce=time_Reduce+MPI_Wtime()-time00
 378       endif
 379       if (fg_rank.eq.0) then
 380 #endif
 381 #ifdef TSCSC
 382       evdw=energia(22)+wsct*energia(23)
 383 #else
 384       evdw=energia(1)
 385 #endif
 386 #ifdef SCP14
 387       evdw2=energia(2)+energia(18)
 388       evdw2_14=energia(18)
 389 #else
 390       evdw2=energia(2)
 391 #endif
 392 #ifdef SPLITELE
 393       ees=energia(3)
 394       evdw1=energia(16)
 395 #else
 396       ees=energia(3)
 397       evdw1=0.0d0
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eturn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       edihcnstr=energia(19)
 412       estr=energia(17)
 413       Uconst=energia(20)
 414       esccor=energia(21)
 415       edfadis=energia(24)
 416       edfator=energia(25)
 417       edfanei=energia(26)
 418       edfabet=energia(27)
 419 #ifdef SPLITELE
 420       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 421      & +wang*ebe+wtor*etors+wscloc*escloc
 422      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 423      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 424      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 425      & +wbond*estr+Uconst+wsccor*esccor
 426      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 427      & +wdfa_beta*edfabet
 428 #else
 429       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 436      & +wdfa_beta*edfabet
 437
 438 #endif
 439       energia(0)=etot
 440 c detecting NaNQ
 441 #ifdef ISNAN
 442 #ifdef AIX
 443       if (isnan(etot).ne.0) energia(0)=1.0d+99
 444 #else
 445       if (isnan(etot)) energia(0)=1.0d+99
 446 #endif
 447 #else
 448       i=0
 449 #ifdef WINPGI
 450       idumm=proc_proc(etot,i)
 451 #else
 452       call proc_proc(etot,i)
 453 #endif
 454       if(i.eq.1)energia(0)=1.0d+99
 455 #endif
 456 #ifdef MPI
 457       endif
 458 #endif
 459       return
 460       end
 461 c-------------------------------------------------------------------------------
 462       subroutine sum_gradient
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465 #ifndef ISNAN
 466       external proc_proc
 467 #ifdef WINPGI
 468 cMS$ATTRIBUTES C ::  proc_proc
 469 #endif
 470 #endif
 471 #ifdef MPI
 472       include 'mpif.h'
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 475 #else
 476       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 477      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 478 #endif
 479       include 'COMMON.SETUP'
 480       include 'COMMON.IOUNITS'
 481       include 'COMMON.FFIELD'
 482       include 'COMMON.DERIV'
 483       include 'COMMON.INTERACT'
 484       include 'COMMON.SBRIDGE'
 485       include 'COMMON.CHAIN'
 486       include 'COMMON.VAR'
 487       include 'COMMON.CONTROL'
 488       include 'COMMON.TIME1'
 489       include 'COMMON.MAXGRAD'
 490 #ifdef TIMING
 491       time01=MPI_Wtime()
 492 #endif
 493 #ifdef DEBUG
 494       write (iout,*) "sum_gradient gvdwc, gvdwx"
 495       do i=1,nres
 496         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 497      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 498      &   (gvdwcT(j,i),j=1,3)
 499       enddo
 500       call flush(iout)
 501 #endif
 502 #ifdef MPI
 503 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 504         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 505      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 506 #endif
 507 C
 508 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 509 C            in virtual-bond-vector coordinates
 510 C
 511 #ifdef DEBUG
 512 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 513 c      do i=1,nres-1
 514 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 515 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 516 c      enddo
 517 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 520 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 521 c      enddo
 522       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 523       do i=1,nres
 524         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 525      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 526      &   g_corr5_loc(i)
 527       enddo
 528       call flush(iout)
 529 #endif
 530 #ifdef SPLITELE
 531 #ifdef TSCSC
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 537      &                wel_loc*gel_loc_long(j,i)+
 538      &                wcorr*gradcorr_long(j,i)+
 539      &                wcorr5*gradcorr5_long(j,i)+
 540      &                wcorr6*gradcorr6_long(j,i)+
 541      &                wturn6*gcorr6_turn_long(j,i)+
 542      &                wstrain*ghpbc(j,i)+
 543      &                wdfa_dist*gdfad(j,i)+
 544      &                wdfa_tor*gdfat(j,i)+
 545      &                wdfa_nei*gdfan(j,i)+
 546      &                wdfa_beta*gdfab(j,i)
 547
 548         enddo
 549       enddo
 550 #else
 551       do i=1,nct
 552         do j=1,3
 553           gradbufc(j,i)=wsc*gvdwc(j,i)+
 554      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 555      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 556      &                wel_loc*gel_loc_long(j,i)+
 557      &                wcorr*gradcorr_long(j,i)+
 558      &                wcorr5*gradcorr5_long(j,i)+
 559      &                wcorr6*gradcorr6_long(j,i)+
 560      &                wturn6*gcorr6_turn_long(j,i)+
 561      &                wstrain*ghpbc(j,i)+
 562      &                wdfa_dist*gdfad(j,i)+
 563      &                wdfa_tor*gdfat(j,i)+
 564      &                wdfa_nei*gdfan(j,i)+
 565      &                wdfa_beta*gdfab(j,i)
 566
 567         enddo
 568       enddo
 569 #endif
 570 #else
 571       do i=1,nct
 572         do j=1,3
 573           gradbufc(j,i)=wsc*gvdwc(j,i)+
 574      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 575      &                welec*gelc_long(j,i)+
 576      &                wbond*gradb(j,i)+
 577      &                wel_loc*gel_loc_long(j,i)+
 578      &                wcorr*gradcorr_long(j,i)+
 579      &                wcorr5*gradcorr5_long(j,i)+
 580      &                wcorr6*gradcorr6_long(j,i)+
 581      &                wturn6*gcorr6_turn_long(j,i)+
 582      &                wstrain*ghpbc(j,i)+
 583      &                wdfa_dist*gdfad(j,i)+
 584      &                wdfa_tor*gdfat(j,i)+
 585      &                wdfa_nei*gdfan(j,i)+
 586      &                wdfa_beta*gdfab(j,i)
 587
 588
 589         enddo
 590       enddo
 591 #endif
 592 #ifdef MPI
 593       if (nfgtasks.gt.1) then
 594       time00=MPI_Wtime()
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc before allreduce"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 603      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 604       time_reduce=time_reduce+MPI_Wtime()-time00
 605 #ifdef DEBUG
 606       write (iout,*) "gradbufc_sum after allreduce"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612 #ifdef TIMING
 613       time_allreduce=time_allreduce+MPI_Wtime()-time00
 614 #endif
 615       do i=nnt,nres
 616         do k=1,3
 617           gradbufc(k,i)=0.0d0
 618         enddo
 619       enddo
 620       do i=igrad_start,igrad_end
 621         do j=jgrad_start(i),jgrad_end(i)
 622           do k=1,3
 623             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624           enddo
 625         enddo
 626       enddo
 627       else
 628 #endif
 629 #ifdef DEBUG
 630       write (iout,*) "gradbufc"
 631       do i=1,nres
 632         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 633       enddo
 634       call flush(iout)
 635 #endif
 636       do i=nnt,nres-1
 637         do k=1,3
 638           gradbufc(k,i)=0.0d0
 639         enddo
 640         do j=i+1,nres
 641           do k=1,3
 642             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 643           enddo
 644         enddo
 645       enddo
 646 #ifdef MPI
 647       endif
 648 #endif
 649       do k=1,3
 650         gradbufc(k,nres)=0.0d0
 651       enddo
 652       do i=1,nct
 653         do j=1,3
 654 #ifdef SPLITELE
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gradcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #else
 674           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 675      &                wel_loc*gel_loc(j,i)+
 676      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 677      &                welec*gelc_long(j,i)
 678      &                wel_loc*gel_loc_long(j,i)+
 679      &                wcorr*gcorr_long(j,i)+
 680      &                wcorr5*gradcorr5_long(j,i)+
 681      &                wcorr6*gradcorr6_long(j,i)+
 682      &                wturn6*gcorr6_turn_long(j,i))+
 683      &                wbond*gradb(j,i)+
 684      &                wcorr*gradcorr(j,i)+
 685      &                wturn3*gcorr3_turn(j,i)+
 686      &                wturn4*gcorr4_turn(j,i)+
 687      &                wcorr5*gradcorr5(j,i)+
 688      &                wcorr6*gradcorr6(j,i)+
 689      &                wturn6*gcorr6_turn(j,i)+
 690      &                wsccor*gsccorc(j,i)
 691      &               +wscloc*gscloc(j,i)
 692 #endif
 693 #ifdef TSCSC
 694           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 695      &                  wscp*gradx_scp(j,i)+
 696      &                  wbond*gradbx(j,i)+
 697      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 698      &                  wsccor*gsccorx(j,i)
 699      &                 +wscloc*gsclocx(j,i)
 700 #else
 701           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 702      &                  wbond*gradbx(j,i)+
 703      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 704      &                  wsccor*gsccorx(j,i)
 705      &                 +wscloc*gsclocx(j,i)
 706 #endif
 707         enddo
 708       enddo
 709 #ifdef DEBUG
 710       write (iout,*) "gloc before adding corr"
 711       do i=1,4*nres
 712         write (iout,*) i,gloc(i,icg)
 713       enddo
 714 #endif
 715       do i=1,nres-3
 716         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 717      &   +wcorr5*g_corr5_loc(i)
 718      &   +wcorr6*g_corr6_loc(i)
 719      &   +wturn4*gel_loc_turn4(i)
 720      &   +wturn3*gel_loc_turn3(i)
 721      &   +wturn6*gel_loc_turn6(i)
 722      &   +wel_loc*gel_loc_loc(i)
 723      &   +wsccor*gsccor_loc(i)
 724       enddo
 725 #ifdef DEBUG
 726       write (iout,*) "gloc after adding corr"
 727       do i=1,4*nres
 728         write (iout,*) i,gloc(i,icg)
 729       enddo
 730 #endif
 731 #ifdef MPI
 732       if (nfgtasks.gt.1) then
 733         do j=1,3
 734           do i=1,nres
 735             gradbufc(j,i)=gradc(j,i,icg)
 736             gradbufx(j,i)=gradx(j,i,icg)
 737           enddo
 738         enddo
 739         do i=1,4*nres
 740           glocbuf(i)=gloc(i,icg)
 741         enddo
 742         time00=MPI_Wtime()
 743         call MPI_Barrier(FG_COMM,IERR)
 744         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 745         time00=MPI_Wtime()
 746         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 749      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 750         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 751      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 752         time_reduce=time_reduce+MPI_Wtime()-time00
 753 #ifdef DEBUG
 754       write (iout,*) "gloc after reduce"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       endif
 760 #endif
 761       if (gnorm_check) then
 762 c
 763 c Compute the maximum elements of the gradient
 764 c
 765       gvdwc_max=0.0d0
 766       gvdwc_scp_max=0.0d0
 767       gelc_max=0.0d0
 768       gvdwpp_max=0.0d0
 769       gradb_max=0.0d0
 770       ghpbc_max=0.0d0
 771       gradcorr_max=0.0d0
 772       gel_loc_max=0.0d0
 773       gcorr3_turn_max=0.0d0
 774       gcorr4_turn_max=0.0d0
 775       gradcorr5_max=0.0d0
 776       gradcorr6_max=0.0d0
 777       gcorr6_turn_max=0.0d0
 778       gsccorc_max=0.0d0
 779       gscloc_max=0.0d0
 780       gvdwx_max=0.0d0
 781       gradx_scp_max=0.0d0
 782       ghpbx_max=0.0d0
 783       gradxorr_max=0.0d0
 784       gsccorx_max=0.0d0
 785       gsclocx_max=0.0d0
 786       do i=1,nct
 787         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 788         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 789 #ifdef TSCSC
 790         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 791         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 792 #endif
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831 #ifdef TSCSC
 832         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 833         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 834 #endif
 835         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 836         if (gradx_scp_norm.gt.gradx_scp_max)
 837      &    gradx_scp_max=gradx_scp_norm
 838         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 839         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 840         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 841         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 842         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 843         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 844         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 845         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 846       enddo
 847       if (gradout) then
 848 #ifdef AIX
 849         open(istat,file=statname,position="append")
 850 #else
 851         open(istat,file=statname,access="append")
 852 #endif
 853         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 854      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 855      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 856      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 857      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 858      &     gsccorx_max,gsclocx_max
 859         close(istat)
 860         if (gvdwc_max.gt.1.0d4) then
 861           write (iout,*) "gvdwc gvdwx gradb gradbx"
 862           do i=nnt,nct
 863             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 864      &        gradb(j,i),gradbx(j,i),j=1,3)
 865           enddo
 866           call pdbout(0.0d0,'cipiszcze',iout)
 867           call flush(iout)
 868         endif
 869       endif
 870       endif
 871 #ifdef DEBUG
 872       write (iout,*) "gradc gradx gloc"
 873       do i=1,nres
 874         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 875      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 876       enddo
 877 #endif
 878 #ifdef TIMING
 879       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 880 #endif
 881       return
 882       end
 883 c-------------------------------------------------------------------------------
 884       subroutine rescale_weights(t_bath)
 885       implicit real*8 (a-h,o-z)
 886       include 'DIMENSIONS'
 887       include 'COMMON.IOUNITS'
 888       include 'COMMON.FFIELD'
 889       include 'COMMON.SBRIDGE'
 890       double precision kfac /2.4d0/
 891       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 892 c      facT=temp0/t_bath
 893 c      facT=2*temp0/(t_bath+temp0)
 894       if (rescale_mode.eq.0) then
 895         facT=1.0d0
 896         facT2=1.0d0
 897         facT3=1.0d0
 898         facT4=1.0d0
 899         facT5=1.0d0
 900       else if (rescale_mode.eq.1) then
 901         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 902         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 903         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 904         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 905         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 906       else if (rescale_mode.eq.2) then
 907         x=t_bath/temp0
 908         x2=x*x
 909         x3=x2*x
 910         x4=x3*x
 911         x5=x4*x
 912         facT=licznik/dlog(dexp(x)+dexp(-x))
 913         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 914         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 915         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 916         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 917       else
 918         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 919         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 920 #ifdef MPI
 921        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 922 #endif
 923        stop 555
 924       endif
 925       welec=weights(3)*fact
 926       wcorr=weights(4)*fact3
 927       wcorr5=weights(5)*fact4
 928       wcorr6=weights(6)*fact5
 929       wel_loc=weights(7)*fact2
 930       wturn3=weights(8)*fact2
 931       wturn4=weights(9)*fact3
 932       wturn6=weights(10)*fact5
 933       wtor=weights(13)*fact
 934       wtor_d=weights(14)*fact2
 935       wsccor=weights(21)*fact
 936 #ifdef TSCSC
 937 c      wsct=t_bath/temp0
 938       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 939 #endif
 940       return
 941       end
 942 C------------------------------------------------------------------------
 943       subroutine enerprint(energia)
 944       implicit real*8 (a-h,o-z)
 945       include 'DIMENSIONS'
 946       include 'COMMON.IOUNITS'
 947       include 'COMMON.FFIELD'
 948       include 'COMMON.SBRIDGE'
 949       include 'COMMON.MD_'
 950       double precision energia(0:n_ene)
 951       etot=energia(0)
 952 #ifdef TSCSC
 953       evdw=energia(22)+wsct*energia(23)
 954 #else
 955       evdw=energia(1)
 956 #endif
 957       evdw2=energia(2)
 958 #ifdef SCP14
 959       evdw2=energia(2)+energia(18)
 960 #else
 961       evdw2=energia(2)
 962 #endif
 963       ees=energia(3)
 964 #ifdef SPLITELE
 965       evdw1=energia(16)
 966 #endif
 967       ecorr=energia(4)
 968       ecorr5=energia(5)
 969       ecorr6=energia(6)
 970       eel_loc=energia(7)
 971       eello_turn3=energia(8)
 972       eello_turn4=energia(9)
 973       eello_turn6=energia(10)
 974       ebe=energia(11)
 975       escloc=energia(12)
 976       etors=energia(13)
 977       etors_d=energia(14)
 978       ehpb=energia(15)
 979       edihcnstr=energia(19)
 980       estr=energia(17)
 981       Uconst=energia(20)
 982       esccor=energia(21)
 983 C     Juyong
 984       edfadis = energia(24)
 985       edfator = energia(25)
 986       edfanei = energia(26)
 987       edfabet = energia(27)
 988 C
 989 #ifdef SPLITELE
 990       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 991      &  estr,wbond,ebe,wang,
 992      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 993      &  ecorr,wcorr,
 994      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 995      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 996      &  edihcnstr,ebr*nss,
 997      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
 998    10 format (/'Virtual-chain energies:'//
 999      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1000      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1001      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1002      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1003      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1004      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1005      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1006      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1007      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1008      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1009      & ' (SS bridges & dist. cnstr.)'/
1010      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1011      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1012      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1013      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1014      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1015      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1016      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1017      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1018      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1019      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1020      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1021      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1022      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1023      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1024      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1025      & 'ETOT=  ',1pE16.6,' (total)')
1026 #else
1027       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1028      &  estr,wbond,ebe,wang,
1029      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1030      &  ecorr,wcorr,
1031      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1032      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1033      &  ebr*nss,
1034      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1035    10 format (/'Virtual-chain energies:'//
1036      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1037      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1038      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1039      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1040      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1041      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1042      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1043      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1044      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1045      & ' (SS bridges & dist. cnstr.)'/
1046      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1047      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1048      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1049      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1050      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1051      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1052      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1053      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1054      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1055      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1056      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1057      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1058      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1059      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1060      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1061      & 'ETOT=  ',1pE16.6,' (total)')
1062 #endif
1063       return
1064       end
1065 C-----------------------------------------------------------------------
1066       subroutine elj(evdw,evdw_p,evdw_m)
1067 C
1068 C This subroutine calculates the interaction energy of nonbonded side chains
1069 C assuming the LJ potential of interaction.
1070 C
1071       implicit real*8 (a-h,o-z)
1072       include 'DIMENSIONS'
1073       parameter (accur=1.0d-10)
1074       include 'COMMON.GEO'
1075       include 'COMMON.VAR'
1076       include 'COMMON.LOCAL'
1077       include 'COMMON.CHAIN'
1078       include 'COMMON.DERIV'
1079       include 'COMMON.INTERACT'
1080       include 'COMMON.TORSION'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.NAMES'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CONTACTS'
1085 #ifdef MOMENT
1086       include 'COMMON.CONTACTS.MOMENT'
1087 #endif
1088       dimension gg(3)
1089 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1090       evdw=0.0D0
1091       do i=iatsc_s,iatsc_e
1092         itypi=iabs(itype(i))
1093         itypi1=iabs(itype(i+1))
1094         xi=c(1,nres+i)
1095         yi=c(2,nres+i)
1096         zi=c(3,nres+i)
1097 C Change 12/1/95
1098         num_conti=0
1099 C
1100 C Calculate SC interaction energy.
1101 C
1102         do iint=1,nint_gr(i)
1103 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1104 cd   &                  'iend=',iend(i,iint)
1105           do j=istart(i,iint),iend(i,iint)
1106             itypj=iabs(itype(j))
1107             xj=c(1,nres+j)-xi
1108             yj=c(2,nres+j)-yi
1109             zj=c(3,nres+j)-zi
1110 C Change 12/1/95 to calculate four-body interactions
1111             rij=xj*xj+yj*yj+zj*zj
1112             rrij=1.0D0/rij
1113 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1114             eps0ij=eps(itypi,itypj)
1115             fac=rrij**expon2
1116             e1=fac*fac*aa(itypi,itypj)
1117             e2=fac*bb(itypi,itypj)
1118             evdwij=e1+e2
1119 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1120 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1121 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1122 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1123 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1124 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1125 #ifdef TSCSC
1126             if (bb(itypi,itypj).gt.0) then
1127                evdw_p=evdw_p+evdwij
1128             else
1129                evdw_m=evdw_m+evdwij
1130             endif
1131 #else
1132             evdw=evdw+evdwij
1133 #endif
1134 C
1135 C Calculate the components of the gradient in DC and X
1136 C
1137             fac=-rrij*(e1+evdwij)
1138             gg(1)=xj*fac
1139             gg(2)=yj*fac
1140             gg(3)=zj*fac
1141 #ifdef TSCSC
1142             if (bb(itypi,itypj).gt.0.0d0) then
1143               do k=1,3
1144                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1145                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1146                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1147                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1148               enddo
1149             else
1150               do k=1,3
1151                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1152                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1153                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1154                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1155               enddo
1156             endif
1157 #else
1158             do k=1,3
1159               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1160               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1161               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1162               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1163             enddo
1164 #endif
1165 cgrad            do k=i,j-1
1166 cgrad              do l=1,3
1167 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1168 cgrad              enddo
1169 cgrad            enddo
1170 C
1171 C 12/1/95, revised on 5/20/97
1172 C
1173 C Calculate the contact function. The ith column of the array JCONT will
1174 C contain the numbers of atoms that make contacts with the atom I (of numbers
1175 C greater than I). The arrays FACONT and GACONT will contain the values of
1176 C the contact function and its derivative.
1177 C
1178 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1179 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1180 C Uncomment next line, if the correlation interactions are contact function only
1181             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1182               rij=dsqrt(rij)
1183               sigij=sigma(itypi,itypj)
1184               r0ij=rs0(itypi,itypj)
1185 C
1186 C Check whether the SC's are not too far to make a contact.
1187 C
1188               rcut=1.5d0*r0ij
1189               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1190 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1191 C
1192               if (fcont.gt.0.0D0) then
1193 C If the SC-SC distance if close to sigma, apply spline.
1194 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1195 cAdam &             fcont1,fprimcont1)
1196 cAdam           fcont1=1.0d0-fcont1
1197 cAdam           if (fcont1.gt.0.0d0) then
1198 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1199 cAdam             fcont=fcont*fcont1
1200 cAdam           endif
1201 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1202 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1203 cga             do k=1,3
1204 cga               gg(k)=gg(k)*eps0ij
1205 cga             enddo
1206 cga             eps0ij=-evdwij*eps0ij
1207 C Uncomment for AL's type of SC correlation interactions.
1208 cadam           eps0ij=-evdwij
1209                 num_conti=num_conti+1
1210                 jcont(num_conti,i)=j
1211                 facont(num_conti,i)=fcont*eps0ij
1212                 fprimcont=eps0ij*fprimcont/rij
1213                 fcont=expon*fcont
1214 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1215 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1216 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1217 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1218                 gacont(1,num_conti,i)=-fprimcont*xj
1219                 gacont(2,num_conti,i)=-fprimcont*yj
1220                 gacont(3,num_conti,i)=-fprimcont*zj
1221 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1222 cd              write (iout,'(2i3,3f10.5)')
1223 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1224               endif
1225             endif
1226           enddo      ! j
1227         enddo        ! iint
1228 C Change 12/1/95
1229         num_cont(i)=num_conti
1230       enddo          ! i
1231       do i=1,nct
1232         do j=1,3
1233           gvdwc(j,i)=expon*gvdwc(j,i)
1234           gvdwx(j,i)=expon*gvdwx(j,i)
1235         enddo
1236       enddo
1237 C******************************************************************************
1238 C
1239 C                              N O T E !!!
1240 C
1241 C To save time, the factor of EXPON has been extracted from ALL components
1242 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1243 C use!
1244 C
1245 C******************************************************************************
1246       return
1247       end
1248 C-----------------------------------------------------------------------------
1249       subroutine eljk(evdw,evdw_p,evdw_m)
1250 C
1251 C This subroutine calculates the interaction energy of nonbonded side chains
1252 C assuming the LJK potential of interaction.
1253 C
1254       implicit real*8 (a-h,o-z)
1255       include 'DIMENSIONS'
1256       include 'COMMON.GEO'
1257       include 'COMMON.VAR'
1258       include 'COMMON.LOCAL'
1259       include 'COMMON.CHAIN'
1260       include 'COMMON.DERIV'
1261       include 'COMMON.INTERACT'
1262       include 'COMMON.IOUNITS'
1263       include 'COMMON.NAMES'
1264       dimension gg(3)
1265       logical scheck
1266 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1267       evdw=0.0D0
1268       do i=iatsc_s,iatsc_e
1269         itypi=iabs(itype(i))
1270         itypi1=iabs(itype(i+1))
1271         xi=c(1,nres+i)
1272         yi=c(2,nres+i)
1273         zi=c(3,nres+i)
1274 C
1275 C Calculate SC interaction energy.
1276 C
1277         do iint=1,nint_gr(i)
1278           do j=istart(i,iint),iend(i,iint)
1279             itypj=iabs(itype(j))
1280             xj=c(1,nres+j)-xi
1281             yj=c(2,nres+j)-yi
1282             zj=c(3,nres+j)-zi
1283             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1284             fac_augm=rrij**expon
1285             e_augm=augm(itypi,itypj)*fac_augm
1286             r_inv_ij=dsqrt(rrij)
1287             rij=1.0D0/r_inv_ij
1288             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1289             fac=r_shift_inv**expon
1290             e1=fac*fac*aa(itypi,itypj)
1291             e2=fac*bb(itypi,itypj)
1292             evdwij=e_augm+e1+e2
1293 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1294 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1295 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1296 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1297 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1298 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1299 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1300 #ifdef TSCSC
1301             if (bb(itypi,itypj).gt.0) then
1302                evdw_p=evdw_p+evdwij
1303             else
1304                evdw_m=evdw_m+evdwij
1305             endif
1306 #else
1307             evdw=evdw+evdwij
1308 #endif
1309 C
1310 C Calculate the components of the gradient in DC and X
1311 C
1312             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1313             gg(1)=xj*fac
1314             gg(2)=yj*fac
1315             gg(3)=zj*fac
1316 #ifdef TSCSC
1317             if (bb(itypi,itypj).gt.0.0d0) then
1318               do k=1,3
1319                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1320                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1321                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1322                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1323               enddo
1324             else
1325               do k=1,3
1326                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1327                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1328                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1329                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1330               enddo
1331             endif
1332 #else
1333             do k=1,3
1334               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1335               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1336               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1337               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1338             enddo
1339 #endif
1340 cgrad            do k=i,j-1
1341 cgrad              do l=1,3
1342 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1343 cgrad              enddo
1344 cgrad            enddo
1345           enddo      ! j
1346         enddo        ! iint
1347       enddo          ! i
1348       do i=1,nct
1349         do j=1,3
1350           gvdwc(j,i)=expon*gvdwc(j,i)
1351           gvdwx(j,i)=expon*gvdwx(j,i)
1352         enddo
1353       enddo
1354       return
1355       end
1356 C-----------------------------------------------------------------------------
1357       subroutine ebp(evdw,evdw_p,evdw_m)
1358 C
1359 C This subroutine calculates the interaction energy of nonbonded side chains
1360 C assuming the Berne-Pechukas potential of interaction.
1361 C
1362       implicit real*8 (a-h,o-z)
1363       include 'DIMENSIONS'
1364       include 'COMMON.GEO'
1365       include 'COMMON.VAR'
1366       include 'COMMON.LOCAL'
1367       include 'COMMON.CHAIN'
1368       include 'COMMON.DERIV'
1369       include 'COMMON.NAMES'
1370       include 'COMMON.INTERACT'
1371       include 'COMMON.IOUNITS'
1372       include 'COMMON.CALC'
1373       common /srutu/ icall
1374 c     double precision rrsave(maxdim)
1375       logical lprn
1376       evdw=0.0D0
1377 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1378       evdw=0.0D0
1379 c     if (icall.eq.0) then
1380 c       lprn=.true.
1381 c     else
1382         lprn=.false.
1383 c     endif
1384       ind=0
1385       do i=iatsc_s,iatsc_e
1386         itypi=iabs(itype(i))
1387         itypi1=iabs(itype(i+1))
1388         xi=c(1,nres+i)
1389         yi=c(2,nres+i)
1390         zi=c(3,nres+i)
1391         dxi=dc_norm(1,nres+i)
1392         dyi=dc_norm(2,nres+i)
1393         dzi=dc_norm(3,nres+i)
1394 c        dsci_inv=dsc_inv(itypi)
1395         dsci_inv=vbld_inv(i+nres)
1396 C
1397 C Calculate SC interaction energy.
1398 C
1399         do iint=1,nint_gr(i)
1400           do j=istart(i,iint),iend(i,iint)
1401             ind=ind+1
1402             itypj=itype(j)
1403 c            dscj_inv=dsc_inv(itypj)
1404             dscj_inv=vbld_inv(j+nres)
1405             chi1=chi(itypi,itypj)
1406             chi2=chi(itypj,itypi)
1407             chi12=chi1*chi2
1408             chip1=chip(itypi)
1409             chip2=chip(itypj)
1410             chip12=chip1*chip2
1411             alf1=alp(itypi)
1412             alf2=alp(itypj)
1413             alf12=0.5D0*(alf1+alf2)
1414 C For diagnostics only!!!
1415 c           chi1=0.0D0
1416 c           chi2=0.0D0
1417 c           chi12=0.0D0
1418 c           chip1=0.0D0
1419 c           chip2=0.0D0
1420 c           chip12=0.0D0
1421 c           alf1=0.0D0
1422 c           alf2=0.0D0
1423 c           alf12=0.0D0
1424             xj=c(1,nres+j)-xi
1425             yj=c(2,nres+j)-yi
1426             zj=c(3,nres+j)-zi
1427             dxj=dc_norm(1,nres+j)
1428             dyj=dc_norm(2,nres+j)
1429             dzj=dc_norm(3,nres+j)
1430             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1431 cd          if (icall.eq.0) then
1432 cd            rrsave(ind)=rrij
1433 cd          else
1434 cd            rrij=rrsave(ind)
1435 cd          endif
1436             rij=dsqrt(rrij)
1437 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1438             call sc_angular
1439 C Calculate whole angle-dependent part of epsilon and contributions
1440 C to its derivatives
1441             fac=(rrij*sigsq)**expon2
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1445             eps2der=evdwij*eps3rt
1446             eps3der=evdwij*eps2rt
1447             evdwij=evdwij*eps2rt*eps3rt
1448 #ifdef TSCSC
1449             if (bb(itypi,itypj).gt.0) then
1450                evdw_p=evdw_p+evdwij
1451             else
1452                evdw_m=evdw_m+evdwij
1453             endif
1454 #else
1455             evdw=evdw+evdwij
1456 #endif
1457             if (lprn) then
1458             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1459             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1460 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1461 cd     &        restyp(itypi),i,restyp(itypj),j,
1462 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1463 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1464 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1465 cd     &        evdwij
1466             endif
1467 C Calculate gradient components.
1468             e1=e1*eps1*eps2rt**2*eps3rt**2
1469             fac=-expon*(e1+evdwij)
1470             sigder=fac/sigsq
1471             fac=rrij*fac
1472 C Calculate radial part of the gradient
1473             gg(1)=xj*fac
1474             gg(2)=yj*fac
1475             gg(3)=zj*fac
1476 C Calculate the angular part of the gradient and sum add the contributions
1477 C to the appropriate components of the Cartesian gradient.
1478 #ifdef TSCSC
1479             if (bb(itypi,itypj).gt.0) then
1480                call sc_grad
1481             else
1482                call sc_grad_T
1483             endif
1484 #else
1485             call sc_grad
1486 #endif
1487           enddo      ! j
1488         enddo        ! iint
1489       enddo          ! i
1490 c     stop
1491       return
1492       end
1493 C-----------------------------------------------------------------------------
1494       subroutine egb(evdw,evdw_p,evdw_m)
1495 C
1496 C This subroutine calculates the interaction energy of nonbonded side chains
1497 C assuming the Gay-Berne potential of interaction.
1498 C
1499       implicit real*8 (a-h,o-z)
1500       include 'DIMENSIONS'
1501       include 'COMMON.GEO'
1502       include 'COMMON.VAR'
1503       include 'COMMON.LOCAL'
1504       include 'COMMON.CHAIN'
1505       include 'COMMON.DERIV'
1506       include 'COMMON.NAMES'
1507       include 'COMMON.INTERACT'
1508       include 'COMMON.IOUNITS'
1509       include 'COMMON.CALC'
1510       include 'COMMON.CONTROL'
1511       logical lprn
1512       evdw=0.0D0
1513 ccccc      energy_dec=.false.
1514 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1515       evdw=0.0D0
1516       evdw_p=0.0D0
1517       evdw_m=0.0D0
1518       lprn=.false.
1519 c     if (icall.eq.0) lprn=.false.
1520       ind=0
1521       do i=iatsc_s,iatsc_e
1522         itypi=iabs(itype(i))
1523         itypi1=iabs(itype(i+1))
1524         xi=c(1,nres+i)
1525         yi=c(2,nres+i)
1526         zi=c(3,nres+i)
1527         dxi=dc_norm(1,nres+i)
1528         dyi=dc_norm(2,nres+i)
1529         dzi=dc_norm(3,nres+i)
1530 c        dsci_inv=dsc_inv(itypi)
1531         dsci_inv=vbld_inv(i+nres)
1532 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1533 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1534 C
1535 C Calculate SC interaction energy.
1536 C
1537         do iint=1,nint_gr(i)
1538           do j=istart(i,iint),iend(i,iint)
1539             ind=ind+1
1540             itypj=iabs(itype(j))
1541 c            dscj_inv=dsc_inv(itypj)
1542             dscj_inv=vbld_inv(j+nres)
1543 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1544 c     &       1.0d0/vbld(j+nres)
1545 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1546             sig0ij=sigma(itypi,itypj)
1547             chi1=chi(itypi,itypj)
1548             chi2=chi(itypj,itypi)
1549             chi12=chi1*chi2
1550             chip1=chip(itypi)
1551             chip2=chip(itypj)
1552             chip12=chip1*chip2
1553             alf1=alp(itypi)
1554             alf2=alp(itypj)
1555             alf12=0.5D0*(alf1+alf2)
1556 C For diagnostics only!!!
1557 c           chi1=0.0D0
1558 c           chi2=0.0D0
1559 c           chi12=0.0D0
1560 c           chip1=0.0D0
1561 c           chip2=0.0D0
1562 c           chip12=0.0D0
1563 c           alf1=0.0D0
1564 c           alf2=0.0D0
1565 c           alf12=0.0D0
1566             xj=c(1,nres+j)-xi
1567             yj=c(2,nres+j)-yi
1568             zj=c(3,nres+j)-zi
1569             dxj=dc_norm(1,nres+j)
1570             dyj=dc_norm(2,nres+j)
1571             dzj=dc_norm(3,nres+j)
1572 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1573 c            write (iout,*) "j",j," dc_norm",
1574 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1575             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1576             rij=dsqrt(rrij)
1577 C Calculate angle-dependent terms of energy and contributions to their
1578 C derivatives.
1579             call sc_angular
1580             sigsq=1.0D0/sigsq
1581             sig=sig0ij*dsqrt(sigsq)
1582             rij_shift=1.0D0/rij-sig+sig0ij
1583 c for diagnostics; uncomment
1584 c            rij_shift=1.2*sig0ij
1585 C I hate to put IF's in the loops, but here don't have another choice!!!!
1586             if (rij_shift.le.0.0D0) then
1587               evdw=1.0D20
1588 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1589 cd     &        restyp(itypi),i,restyp(itypj),j,
1590 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1591               return
1592             endif
1593             sigder=-sig*sigsq
1594 c---------------------------------------------------------------
1595             rij_shift=1.0D0/rij_shift
1596             fac=rij_shift**expon
1597             e1=fac*fac*aa(itypi,itypj)
1598             e2=fac*bb(itypi,itypj)
1599             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1600             eps2der=evdwij*eps3rt
1601             eps3der=evdwij*eps2rt
1602 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1603 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1604             evdwij=evdwij*eps2rt*eps3rt
1605 #ifdef TSCSC
1606             if (bb(itypi,itypj).gt.0) then
1607                evdw_p=evdw_p+evdwij
1608             else
1609                evdw_m=evdw_m+evdwij
1610             endif
1611 #else
1612             evdw=evdw+evdwij
1613 #endif
1614             if (lprn) then
1615             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1616             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1617             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1618      &        restyp(itypi),i,restyp(itypj),j,
1619      &        epsi,sigm,chi1,chi2,chip1,chip2,
1620      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1621      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1622      &        evdwij
1623             endif
1624
1625             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1626      &                        'evdw',i,j,evdwij
1627
1628 C Calculate gradient components.
1629             e1=e1*eps1*eps2rt**2*eps3rt**2
1630             fac=-expon*(e1+evdwij)*rij_shift
1631             sigder=fac*sigder
1632             fac=rij*fac
1633 c            fac=0.0d0
1634 C Calculate the radial part of the gradient
1635             gg(1)=xj*fac
1636             gg(2)=yj*fac
1637             gg(3)=zj*fac
1638 C Calculate angular part of the gradient.
1639 #ifdef TSCSC
1640             if (bb(itypi,itypj).gt.0) then
1641                call sc_grad
1642             else
1643                call sc_grad_T
1644             endif
1645 #else
1646             call sc_grad
1647 #endif
1648           enddo      ! j
1649         enddo        ! iint
1650       enddo          ! i
1651 c      write (iout,*) "Number of loop steps in EGB:",ind
1652 cccc      energy_dec=.false.
1653       return
1654       end
1655 C-----------------------------------------------------------------------------
1656       subroutine egbv(evdw,evdw_p,evdw_m)
1657 C
1658 C This subroutine calculates the interaction energy of nonbonded side chains
1659 C assuming the Gay-Berne-Vorobjev potential of interaction.
1660 C
1661       implicit real*8 (a-h,o-z)
1662       include 'DIMENSIONS'
1663       include 'COMMON.GEO'
1664       include 'COMMON.VAR'
1665       include 'COMMON.LOCAL'
1666       include 'COMMON.CHAIN'
1667       include 'COMMON.DERIV'
1668       include 'COMMON.NAMES'
1669       include 'COMMON.INTERACT'
1670       include 'COMMON.IOUNITS'
1671       include 'COMMON.CALC'
1672       common /srutu/ icall
1673       logical lprn
1674       evdw=0.0D0
1675 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1676       evdw=0.0D0
1677       lprn=.false.
1678 c     if (icall.eq.0) lprn=.true.
1679       ind=0
1680       do i=iatsc_s,iatsc_e
1681         itypi=iabs(itype(i))
1682         itypi1=iabs(itype(i+1))
1683         xi=c(1,nres+i)
1684         yi=c(2,nres+i)
1685         zi=c(3,nres+i)
1686         dxi=dc_norm(1,nres+i)
1687         dyi=dc_norm(2,nres+i)
1688         dzi=dc_norm(3,nres+i)
1689 c        dsci_inv=dsc_inv(itypi)
1690         dsci_inv=vbld_inv(i+nres)
1691 C
1692 C Calculate SC interaction energy.
1693 C
1694         do iint=1,nint_gr(i)
1695           do j=istart(i,iint),iend(i,iint)
1696             ind=ind+1
1697             itypj=iabs(itype(j))
1698 c            dscj_inv=dsc_inv(itypj)
1699             dscj_inv=vbld_inv(j+nres)
1700             sig0ij=sigma(itypi,itypj)
1701             r0ij=r0(itypi,itypj)
1702             chi1=chi(itypi,itypj)
1703             chi2=chi(itypj,itypi)
1704             chi12=chi1*chi2
1705             chip1=chip(itypi)
1706             chip2=chip(itypj)
1707             chip12=chip1*chip2
1708             alf1=alp(itypi)
1709             alf2=alp(itypj)
1710             alf12=0.5D0*(alf1+alf2)
1711 C For diagnostics only!!!
1712 c           chi1=0.0D0
1713 c           chi2=0.0D0
1714 c           chi12=0.0D0
1715 c           chip1=0.0D0
1716 c           chip2=0.0D0
1717 c           chip12=0.0D0
1718 c           alf1=0.0D0
1719 c           alf2=0.0D0
1720 c           alf12=0.0D0
1721             xj=c(1,nres+j)-xi
1722             yj=c(2,nres+j)-yi
1723             zj=c(3,nres+j)-zi
1724             dxj=dc_norm(1,nres+j)
1725             dyj=dc_norm(2,nres+j)
1726             dzj=dc_norm(3,nres+j)
1727             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1728             rij=dsqrt(rrij)
1729 C Calculate angle-dependent terms of energy and contributions to their
1730 C derivatives.
1731             call sc_angular
1732             sigsq=1.0D0/sigsq
1733             sig=sig0ij*dsqrt(sigsq)
1734             rij_shift=1.0D0/rij-sig+r0ij
1735 C I hate to put IF's in the loops, but here don't have another choice!!!!
1736             if (rij_shift.le.0.0D0) then
1737               evdw=1.0D20
1738               return
1739             endif
1740             sigder=-sig*sigsq
1741 c---------------------------------------------------------------
1742             rij_shift=1.0D0/rij_shift
1743             fac=rij_shift**expon
1744             e1=fac*fac*aa(itypi,itypj)
1745             e2=fac*bb(itypi,itypj)
1746             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1747             eps2der=evdwij*eps3rt
1748             eps3der=evdwij*eps2rt
1749             fac_augm=rrij**expon
1750             e_augm=augm(itypi,itypj)*fac_augm
1751             evdwij=evdwij*eps2rt*eps3rt
1752 #ifdef TSCSC
1753             if (bb(itypi,itypj).gt.0) then
1754                evdw_p=evdw_p+evdwij+e_augm
1755             else
1756                evdw_m=evdw_m+evdwij+e_augm
1757             endif
1758 #else
1759             evdw=evdw+evdwij+e_augm
1760 #endif
1761             if (lprn) then
1762             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1763             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1764             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1765      &        restyp(itypi),i,restyp(itypj),j,
1766      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1767      &        chi1,chi2,chip1,chip2,
1768      &        eps1,eps2rt**2,eps3rt**2,
1769      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1770      &        evdwij+e_augm
1771             endif
1772 C Calculate gradient components.
1773             e1=e1*eps1*eps2rt**2*eps3rt**2
1774             fac=-expon*(e1+evdwij)*rij_shift
1775             sigder=fac*sigder
1776             fac=rij*fac-2*expon*rrij*e_augm
1777 C Calculate the radial part of the gradient
1778             gg(1)=xj*fac
1779             gg(2)=yj*fac
1780             gg(3)=zj*fac
1781 C Calculate angular part of the gradient.
1782 #ifdef TSCSC
1783             if (bb(itypi,itypj).gt.0) then
1784                call sc_grad
1785             else
1786                call sc_grad_T
1787             endif
1788 #else
1789             call sc_grad
1790 #endif
1791           enddo      ! j
1792         enddo        ! iint
1793       enddo          ! i
1794       end
1795 C-----------------------------------------------------------------------------
1796       subroutine sc_angular
1797 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1798 C om12. Called by ebp, egb, and egbv.
1799       implicit none
1800       include 'COMMON.CALC'
1801       include 'COMMON.IOUNITS'
1802       erij(1)=xj*rij
1803       erij(2)=yj*rij
1804       erij(3)=zj*rij
1805       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1806       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1807       om12=dxi*dxj+dyi*dyj+dzi*dzj
1808       chiom12=chi12*om12
1809 C Calculate eps1(om12) and its derivative in om12
1810       faceps1=1.0D0-om12*chiom12
1811       faceps1_inv=1.0D0/faceps1
1812       eps1=dsqrt(faceps1_inv)
1813 C Following variable is eps1*deps1/dom12
1814       eps1_om12=faceps1_inv*chiom12
1815 c diagnostics only
1816 c      faceps1_inv=om12
1817 c      eps1=om12
1818 c      eps1_om12=1.0d0
1819 c      write (iout,*) "om12",om12," eps1",eps1
1820 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1821 C and om12.
1822       om1om2=om1*om2
1823       chiom1=chi1*om1
1824       chiom2=chi2*om2
1825       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1826       sigsq=1.0D0-facsig*faceps1_inv
1827       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1828       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1829       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1830 c diagnostics only
1831 c      sigsq=1.0d0
1832 c      sigsq_om1=0.0d0
1833 c      sigsq_om2=0.0d0
1834 c      sigsq_om12=0.0d0
1835 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1836 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1837 c     &    " eps1",eps1
1838 C Calculate eps2 and its derivatives in om1, om2, and om12.
1839       chipom1=chip1*om1
1840       chipom2=chip2*om2
1841       chipom12=chip12*om12
1842       facp=1.0D0-om12*chipom12
1843       facp_inv=1.0D0/facp
1844       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1845 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1846 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1847 C Following variable is the square root of eps2
1848       eps2rt=1.0D0-facp1*facp_inv
1849 C Following three variables are the derivatives of the square root of eps
1850 C in om1, om2, and om12.
1851       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1852       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1853       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1854 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1855       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1856 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1857 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1858 c     &  " eps2rt_om12",eps2rt_om12
1859 C Calculate whole angle-dependent part of epsilon and contributions
1860 C to its derivatives
1861       return
1862       end
1863
1864 C----------------------------------------------------------------------------
1865       subroutine sc_grad_T
1866       implicit real*8 (a-h,o-z)
1867       include 'DIMENSIONS'
1868       include 'COMMON.CHAIN'
1869       include 'COMMON.DERIV'
1870       include 'COMMON.CALC'
1871       include 'COMMON.IOUNITS'
1872       double precision dcosom1(3),dcosom2(3)
1873       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1874       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1875       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1876      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1877 c diagnostics only
1878 c      eom1=0.0d0
1879 c      eom2=0.0d0
1880 c      eom12=evdwij*eps1_om12
1881 c end diagnostics
1882 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1883 c     &  " sigder",sigder
1884 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1885 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1886       do k=1,3
1887         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1888         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1889       enddo
1890       do k=1,3
1891         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1892       enddo
1893 c      write (iout,*) "gg",(gg(k),k=1,3)
1894       do k=1,3
1895         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1896      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1897      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1898         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1899      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1900      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1901 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1902 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1903 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1904 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1905       enddo
1906 C
1907 C Calculate the components of the gradient in DC and X
1908 C
1909 cgrad      do k=i,j-1
1910 cgrad        do l=1,3
1911 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1912 cgrad        enddo
1913 cgrad      enddo
1914       do l=1,3
1915         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1916         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1917       enddo
1918       return
1919       end
1920
1921 C----------------------------------------------------------------------------
1922       subroutine sc_grad
1923       implicit real*8 (a-h,o-z)
1924       include 'DIMENSIONS'
1925       include 'COMMON.CHAIN'
1926       include 'COMMON.DERIV'
1927       include 'COMMON.CALC'
1928       include 'COMMON.IOUNITS'
1929       double precision dcosom1(3),dcosom2(3)
1930       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1931       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1932       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1933      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1934 c diagnostics only
1935 c      eom1=0.0d0
1936 c      eom2=0.0d0
1937 c      eom12=evdwij*eps1_om12
1938 c end diagnostics
1939 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1940 c     &  " sigder",sigder
1941 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1942 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1943       do k=1,3
1944         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1945         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1946       enddo
1947       do k=1,3
1948         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1949       enddo
1950 c      write (iout,*) "gg",(gg(k),k=1,3)
1951       do k=1,3
1952         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1953      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1954      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1955         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1956      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1957      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1959 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1961 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1962       enddo
1963 C
1964 C Calculate the components of the gradient in DC and X
1965 C
1966 cgrad      do k=i,j-1
1967 cgrad        do l=1,3
1968 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1969 cgrad        enddo
1970 cgrad      enddo
1971       do l=1,3
1972         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1973         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1974       enddo
1975       return
1976       end
1977 C-----------------------------------------------------------------------
1978       subroutine e_softsphere(evdw)
1979 C
1980 C This subroutine calculates the interaction energy of nonbonded side chains
1981 C assuming the LJ potential of interaction.
1982 C
1983       implicit real*8 (a-h,o-z)
1984       include 'DIMENSIONS'
1985       parameter (accur=1.0d-10)
1986       include 'COMMON.GEO'
1987       include 'COMMON.VAR'
1988       include 'COMMON.LOCAL'
1989       include 'COMMON.CHAIN'
1990       include 'COMMON.DERIV'
1991       include 'COMMON.INTERACT'
1992       include 'COMMON.TORSION'
1993       include 'COMMON.SBRIDGE'
1994       include 'COMMON.NAMES'
1995       include 'COMMON.IOUNITS'
1996       include 'COMMON.CONTACTS'
1997 #ifdef MOMENT
1998       include 'COMMON.CONTACTS.MOMENT'
1999 #endif
2000       dimension gg(3)
2001 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2002       evdw=0.0D0
2003       do i=iatsc_s,iatsc_e
2004         itypi=iabs(itype(i))
2005         itypi1=iabs(itype(i+1))
2006         xi=c(1,nres+i)
2007         yi=c(2,nres+i)
2008         zi=c(3,nres+i)
2009 C
2010 C Calculate SC interaction energy.
2011 C
2012         do iint=1,nint_gr(i)
2013 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2014 cd   &                  'iend=',iend(i,iint)
2015           do j=istart(i,iint),iend(i,iint)
2016             itypj=iabs(itype(j))
2017             xj=c(1,nres+j)-xi
2018             yj=c(2,nres+j)-yi
2019             zj=c(3,nres+j)-zi
2020             rij=xj*xj+yj*yj+zj*zj
2021 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2022             r0ij=r0(itypi,itypj)
2023             r0ijsq=r0ij*r0ij
2024 c            print *,i,j,r0ij,dsqrt(rij)
2025             if (rij.lt.r0ijsq) then
2026               evdwij=0.25d0*(rij-r0ijsq)**2
2027               fac=rij-r0ijsq
2028             else
2029               evdwij=0.0d0
2030               fac=0.0d0
2031             endif
2032             evdw=evdw+evdwij
2033 C
2034 C Calculate the components of the gradient in DC and X
2035 C
2036             gg(1)=xj*fac
2037             gg(2)=yj*fac
2038             gg(3)=zj*fac
2039             do k=1,3
2040               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2041               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2042               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2043               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2044             enddo
2045 cgrad            do k=i,j-1
2046 cgrad              do l=1,3
2047 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2048 cgrad              enddo
2049 cgrad            enddo
2050           enddo ! j
2051         enddo ! iint
2052       enddo ! i
2053       return
2054       end
2055 C--------------------------------------------------------------------------
2056       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2057      &              eello_turn4)
2058 C
2059 C Soft-sphere potential of p-p interaction
2060 C
2061       implicit real*8 (a-h,o-z)
2062       include 'DIMENSIONS'
2063       include 'COMMON.CONTROL'
2064       include 'COMMON.IOUNITS'
2065       include 'COMMON.GEO'
2066       include 'COMMON.VAR'
2067       include 'COMMON.LOCAL'
2068       include 'COMMON.CHAIN'
2069       include 'COMMON.DERIV'
2070       include 'COMMON.INTERACT'
2071       include 'COMMON.CONTACTS'
2072 #ifdef MOMENT
2073       include 'COMMON.CONTACTS.MOMENT'
2074 #endif
2075       include 'COMMON.TORSION'
2076       include 'COMMON.VECTORS'
2077       include 'COMMON.FFIELD'
2078       dimension ggg(3)
2079 cd      write(iout,*) 'In EELEC_soft_sphere'
2080       ees=0.0D0
2081       evdw1=0.0D0
2082       eel_loc=0.0d0
2083       eello_turn3=0.0d0
2084       eello_turn4=0.0d0
2085       ind=0
2086       do i=iatel_s,iatel_e
2087         dxi=dc(1,i)
2088         dyi=dc(2,i)
2089         dzi=dc(3,i)
2090         xmedi=c(1,i)+0.5d0*dxi
2091         ymedi=c(2,i)+0.5d0*dyi
2092         zmedi=c(3,i)+0.5d0*dzi
2093         num_conti=0
2094 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2095         do j=ielstart(i),ielend(i)
2096           ind=ind+1
2097           iteli=itel(i)
2098           itelj=itel(j)
2099           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2100           r0ij=rpp(iteli,itelj)
2101           r0ijsq=r0ij*r0ij
2102           dxj=dc(1,j)
2103           dyj=dc(2,j)
2104           dzj=dc(3,j)
2105           xj=c(1,j)+0.5D0*dxj-xmedi
2106           yj=c(2,j)+0.5D0*dyj-ymedi
2107           zj=c(3,j)+0.5D0*dzj-zmedi
2108           rij=xj*xj+yj*yj+zj*zj
2109           if (rij.lt.r0ijsq) then
2110             evdw1ij=0.25d0*(rij-r0ijsq)**2
2111             fac=rij-r0ijsq
2112           else
2113             evdw1ij=0.0d0
2114             fac=0.0d0
2115           endif
2116           evdw1=evdw1+evdw1ij
2117 C
2118 C Calculate contributions to the Cartesian gradient.
2119 C
2120           ggg(1)=fac*xj
2121           ggg(2)=fac*yj
2122           ggg(3)=fac*zj
2123           do k=1,3
2124             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2125             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2126           enddo
2127 *
2128 * Loop over residues i+1 thru j-1.
2129 *
2130 cgrad          do k=i+1,j-1
2131 cgrad            do l=1,3
2132 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2133 cgrad            enddo
2134 cgrad          enddo
2135         enddo ! j
2136       enddo   ! i
2137 cgrad      do i=nnt,nct-1
2138 cgrad        do k=1,3
2139 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2140 cgrad        enddo
2141 cgrad        do j=i+1,nct-1
2142 cgrad          do k=1,3
2143 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2144 cgrad          enddo
2145 cgrad        enddo
2146 cgrad      enddo
2147       return
2148       end
2149 c------------------------------------------------------------------------------
2150       subroutine vec_and_deriv
2151       implicit real*8 (a-h,o-z)
2152       include 'DIMENSIONS'
2153 #ifdef MPI
2154       include 'mpif.h'
2155 #endif
2156       include 'COMMON.IOUNITS'
2157       include 'COMMON.GEO'
2158       include 'COMMON.VAR'
2159       include 'COMMON.LOCAL'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.VECTORS'
2162       include 'COMMON.SETUP'
2163       include 'COMMON.TIME1'
2164       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2165 C Compute the local reference systems. For reference system (i), the
2166 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2167 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2168 #ifdef PARVEC
2169       do i=ivec_start,ivec_end
2170 #else
2171       do i=1,nres-1
2172 #endif
2173           if (i.eq.nres-1) then
2174 C Case of the last full residue
2175 C Compute the Z-axis
2176             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2177             costh=dcos(pi-theta(nres))
2178             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2179             do k=1,3
2180               uz(k,i)=fac*uz(k,i)
2181             enddo
2182 C Compute the derivatives of uz
2183             uzder(1,1,1)= 0.0d0
2184             uzder(2,1,1)=-dc_norm(3,i-1)
2185             uzder(3,1,1)= dc_norm(2,i-1)
2186             uzder(1,2,1)= dc_norm(3,i-1)
2187             uzder(2,2,1)= 0.0d0
2188             uzder(3,2,1)=-dc_norm(1,i-1)
2189             uzder(1,3,1)=-dc_norm(2,i-1)
2190             uzder(2,3,1)= dc_norm(1,i-1)
2191             uzder(3,3,1)= 0.0d0
2192             uzder(1,1,2)= 0.0d0
2193             uzder(2,1,2)= dc_norm(3,i)
2194             uzder(3,1,2)=-dc_norm(2,i)
2195             uzder(1,2,2)=-dc_norm(3,i)
2196             uzder(2,2,2)= 0.0d0
2197             uzder(3,2,2)= dc_norm(1,i)
2198             uzder(1,3,2)= dc_norm(2,i)
2199             uzder(2,3,2)=-dc_norm(1,i)
2200             uzder(3,3,2)= 0.0d0
2201 C Compute the Y-axis
2202             facy=fac
2203             do k=1,3
2204               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2205             enddo
2206 C Compute the derivatives of uy
2207             do j=1,3
2208               do k=1,3
2209                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2210      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2211                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2212               enddo
2213               uyder(j,j,1)=uyder(j,j,1)-costh
2214               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2215             enddo
2216             do j=1,2
2217               do k=1,3
2218                 do l=1,3
2219                   uygrad(l,k,j,i)=uyder(l,k,j)
2220                   uzgrad(l,k,j,i)=uzder(l,k,j)
2221                 enddo
2222               enddo
2223             enddo
2224             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2225             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2226             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2227             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2228           else
2229 C Other residues
2230 C Compute the Z-axis
2231             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2232             costh=dcos(pi-theta(i+2))
2233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2234             do k=1,3
2235               uz(k,i)=fac*uz(k,i)
2236             enddo
2237 C Compute the derivatives of uz
2238             uzder(1,1,1)= 0.0d0
2239             uzder(2,1,1)=-dc_norm(3,i+1)
2240             uzder(3,1,1)= dc_norm(2,i+1)
2241             uzder(1,2,1)= dc_norm(3,i+1)
2242             uzder(2,2,1)= 0.0d0
2243             uzder(3,2,1)=-dc_norm(1,i+1)
2244             uzder(1,3,1)=-dc_norm(2,i+1)
2245             uzder(2,3,1)= dc_norm(1,i+1)
2246             uzder(3,3,1)= 0.0d0
2247             uzder(1,1,2)= 0.0d0
2248             uzder(2,1,2)= dc_norm(3,i)
2249             uzder(3,1,2)=-dc_norm(2,i)
2250             uzder(1,2,2)=-dc_norm(3,i)
2251             uzder(2,2,2)= 0.0d0
2252             uzder(3,2,2)= dc_norm(1,i)
2253             uzder(1,3,2)= dc_norm(2,i)
2254             uzder(2,3,2)=-dc_norm(1,i)
2255             uzder(3,3,2)= 0.0d0
2256 C Compute the Y-axis
2257             facy=fac
2258             do k=1,3
2259               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2260             enddo
2261 C Compute the derivatives of uy
2262             do j=1,3
2263               do k=1,3
2264                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2265      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2266                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2267               enddo
2268               uyder(j,j,1)=uyder(j,j,1)-costh
2269               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2270             enddo
2271             do j=1,2
2272               do k=1,3
2273                 do l=1,3
2274                   uygrad(l,k,j,i)=uyder(l,k,j)
2275                   uzgrad(l,k,j,i)=uzder(l,k,j)
2276                 enddo
2277               enddo
2278             enddo
2279             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2280             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2281             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2282             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2283           endif
2284       enddo
2285       do i=1,nres-1
2286         vbld_inv_temp(1)=vbld_inv(i+1)
2287         if (i.lt.nres-1) then
2288           vbld_inv_temp(2)=vbld_inv(i+2)
2289           else
2290           vbld_inv_temp(2)=vbld_inv(i)
2291           endif
2292         do j=1,2
2293           do k=1,3
2294             do l=1,3
2295               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2296               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2297             enddo
2298           enddo
2299         enddo
2300       enddo
2301 #if defined(PARVEC) && defined(MPI)
2302       if (nfgtasks1.gt.1) then
2303         time00=MPI_Wtime()
2304 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2305 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2306 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2307         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2308      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2309      &   FG_COMM1,IERR)
2310         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2311      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2312      &   FG_COMM1,IERR)
2313         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2314      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2315      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2316         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2317      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2318      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2319         time_gather=time_gather+MPI_Wtime()-time00
2320       endif
2321 c      if (fg_rank.eq.0) then
2322 c        write (iout,*) "Arrays UY and UZ"
2323 c        do i=1,nres-1
2324 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2325 c     &     (uz(k,i),k=1,3)
2326 c        enddo
2327 c      endif
2328 #endif
2329       return
2330       end
2331 C-----------------------------------------------------------------------------
2332       subroutine check_vecgrad
2333       implicit real*8 (a-h,o-z)
2334       include 'DIMENSIONS'
2335       include 'COMMON.IOUNITS'
2336       include 'COMMON.GEO'
2337       include 'COMMON.VAR'
2338       include 'COMMON.LOCAL'
2339       include 'COMMON.CHAIN'
2340       include 'COMMON.VECTORS'
2341       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2342       dimension uyt(3,maxres),uzt(3,maxres)
2343       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2344       double precision delta /1.0d-7/
2345       call vec_and_deriv
2346 cd      do i=1,nres
2347 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2348 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2349 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2350 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2351 cd     &     (dc_norm(if90,i),if90=1,3)
2352 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2353 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2354 cd          write(iout,'(a)')
2355 cd      enddo
2356       do i=1,nres
2357         do j=1,2
2358           do k=1,3
2359             do l=1,3
2360               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2361               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2362             enddo
2363           enddo
2364         enddo
2365       enddo
2366       call vec_and_deriv
2367       do i=1,nres
2368         do j=1,3
2369           uyt(j,i)=uy(j,i)
2370           uzt(j,i)=uz(j,i)
2371         enddo
2372       enddo
2373       do i=1,nres
2374 cd        write (iout,*) 'i=',i
2375         do k=1,3
2376           erij(k)=dc_norm(k,i)
2377         enddo
2378         do j=1,3
2379           do k=1,3
2380             dc_norm(k,i)=erij(k)
2381           enddo
2382           dc_norm(j,i)=dc_norm(j,i)+delta
2383 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2384 c          do k=1,3
2385 c            dc_norm(k,i)=dc_norm(k,i)/fac
2386 c          enddo
2387 c          write (iout,*) (dc_norm(k,i),k=1,3)
2388 c          write (iout,*) (erij(k),k=1,3)
2389           call vec_and_deriv
2390           do k=1,3
2391             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2392             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2393             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2394             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2395           enddo
2396 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2397 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2398 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2399         enddo
2400         do k=1,3
2401           dc_norm(k,i)=erij(k)
2402         enddo
2403 cd        do k=1,3
2404 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2405 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2406 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2407 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2408 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2409 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2410 cd          write (iout,'(a)')
2411 cd        enddo
2412       enddo
2413       return
2414       end
2415 C--------------------------------------------------------------------------
2416       subroutine set_matrices
2417       implicit real*8 (a-h,o-z)
2418       include 'DIMENSIONS'
2419 #ifdef MPI
2420       include "mpif.h"
2421       include "COMMON.SETUP"
2422       integer IERR
2423       integer status(MPI_STATUS_SIZE)
2424 #endif
2425       include 'COMMON.IOUNITS'
2426       include 'COMMON.GEO'
2427       include 'COMMON.VAR'
2428       include 'COMMON.LOCAL'
2429       include 'COMMON.CHAIN'
2430       include 'COMMON.DERIV'
2431       include 'COMMON.INTERACT'
2432       include 'COMMON.CONTACTS'
2433 #ifdef MOMENT
2434       include 'COMMON.CONTACTS.MOMENT'
2435 #endif
2436       include 'COMMON.TORSION'
2437       include 'COMMON.VECTORS'
2438       include 'COMMON.FFIELD'
2439       double precision auxvec(2),auxmat(2,2)
2440 C
2441 C Compute the virtual-bond-torsional-angle dependent quantities needed
2442 C to calculate the el-loc multibody terms of various order.
2443 C
2444 #ifdef PARMAT
2445       do i=ivec_start+2,ivec_end+2
2446 #else
2447       do i=3,nres+1
2448 #endif
2449         if (i .lt. nres+1) then
2450           sin1=dsin(phi(i))
2451           cos1=dcos(phi(i))
2452           sintab(i-2)=sin1
2453           costab(i-2)=cos1
2454           obrot(1,i-2)=cos1
2455           obrot(2,i-2)=sin1
2456           sin2=dsin(2*phi(i))
2457           cos2=dcos(2*phi(i))
2458           sintab2(i-2)=sin2
2459           costab2(i-2)=cos2
2460           obrot2(1,i-2)=cos2
2461           obrot2(2,i-2)=sin2
2462           Ug(1,1,i-2)=-cos1
2463           Ug(1,2,i-2)=-sin1
2464           Ug(2,1,i-2)=-sin1
2465           Ug(2,2,i-2)= cos1
2466           Ug2(1,1,i-2)=-cos2
2467           Ug2(1,2,i-2)=-sin2
2468           Ug2(2,1,i-2)=-sin2
2469           Ug2(2,2,i-2)= cos2
2470         else
2471           costab(i-2)=1.0d0
2472           sintab(i-2)=0.0d0
2473           obrot(1,i-2)=1.0d0
2474           obrot(2,i-2)=0.0d0
2475           obrot2(1,i-2)=0.0d0
2476           obrot2(2,i-2)=0.0d0
2477           Ug(1,1,i-2)=1.0d0
2478           Ug(1,2,i-2)=0.0d0
2479           Ug(2,1,i-2)=0.0d0
2480           Ug(2,2,i-2)=1.0d0
2481           Ug2(1,1,i-2)=0.0d0
2482           Ug2(1,2,i-2)=0.0d0
2483           Ug2(2,1,i-2)=0.0d0
2484           Ug2(2,2,i-2)=0.0d0
2485         endif
2486         if (i .gt. 3 .and. i .lt. nres+1) then
2487           obrot_der(1,i-2)=-sin1
2488           obrot_der(2,i-2)= cos1
2489           Ugder(1,1,i-2)= sin1
2490           Ugder(1,2,i-2)=-cos1
2491           Ugder(2,1,i-2)=-cos1
2492           Ugder(2,2,i-2)=-sin1
2493           dwacos2=cos2+cos2
2494           dwasin2=sin2+sin2
2495           obrot2_der(1,i-2)=-dwasin2
2496           obrot2_der(2,i-2)= dwacos2
2497           Ug2der(1,1,i-2)= dwasin2
2498           Ug2der(1,2,i-2)=-dwacos2
2499           Ug2der(2,1,i-2)=-dwacos2
2500           Ug2der(2,2,i-2)=-dwasin2
2501         else
2502           obrot_der(1,i-2)=0.0d0
2503           obrot_der(2,i-2)=0.0d0
2504           Ugder(1,1,i-2)=0.0d0
2505           Ugder(1,2,i-2)=0.0d0
2506           Ugder(2,1,i-2)=0.0d0
2507           Ugder(2,2,i-2)=0.0d0
2508           obrot2_der(1,i-2)=0.0d0
2509           obrot2_der(2,i-2)=0.0d0
2510           Ug2der(1,1,i-2)=0.0d0
2511           Ug2der(1,2,i-2)=0.0d0
2512           Ug2der(2,1,i-2)=0.0d0
2513           Ug2der(2,2,i-2)=0.0d0
2514         endif
2515 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2516         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2517           iti = itortyp(itype(i-2))
2518         else
2519           iti=ntortyp+1
2520         endif
2521 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2522         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2523           iti1 = itortyp(itype(i-1))
2524         else
2525           iti1=ntortyp+1
2526         endif
2527 cd        write (iout,*) '*******i',i,' iti1',iti
2528 cd        write (iout,*) 'b1',b1(:,iti)
2529 cd        write (iout,*) 'b2',b2(:,iti)
2530 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2531 c        if (i .gt. iatel_s+2) then
2532         if (i .gt. nnt+2) then
2533           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2534           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2535           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2536      &    then
2537           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2538           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2539           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2540           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2541           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2542           endif
2543         else
2544           do k=1,2
2545             Ub2(k,i-2)=0.0d0
2546             Ctobr(k,i-2)=0.0d0
2547             Dtobr2(k,i-2)=0.0d0
2548             do l=1,2
2549               EUg(l,k,i-2)=0.0d0
2550               CUg(l,k,i-2)=0.0d0
2551               DUg(l,k,i-2)=0.0d0
2552               DtUg2(l,k,i-2)=0.0d0
2553             enddo
2554           enddo
2555         endif
2556         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2557         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2558         do k=1,2
2559           muder(k,i-2)=Ub2der(k,i-2)
2560         enddo
2561 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2562         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2563           iti1 = itortyp(itype(i-1))
2564         else
2565           iti1=ntortyp+1
2566         endif
2567         do k=1,2
2568           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2569         enddo
2570 cd        write (iout,*) 'mu ',mu(:,i-2)
2571 cd        write (iout,*) 'mu1',mu1(:,i-2)
2572 cd        write (iout,*) 'mu2',mu2(:,i-2)
2573         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2574      &  then
2575         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2576         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2577         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2578         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2579         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2580 C Vectors and matrices dependent on a single virtual-bond dihedral.
2581         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2582         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2583         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2584         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2585         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2586         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2587         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2588         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2589         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2590         endif
2591       enddo
2592 C Matrices dependent on two consecutive virtual-bond dihedrals.
2593 C The order of matrices is from left to right.
2594       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2595      &then
2596 c      do i=max0(ivec_start,2),ivec_end
2597       do i=2,nres-1
2598         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2599         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2600         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2601         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2602         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2603         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2604         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2605         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2606       enddo
2607       endif
2608 #if defined(MPI) && defined(PARMAT)
2609 #ifdef DEBUG
2610 c      if (fg_rank.eq.0) then
2611         write (iout,*) "Arrays UG and UGDER before GATHER"
2612         do i=1,nres-1
2613           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2614      &     ((ug(l,k,i),l=1,2),k=1,2),
2615      &     ((ugder(l,k,i),l=1,2),k=1,2)
2616         enddo
2617         write (iout,*) "Arrays UG2 and UG2DER"
2618         do i=1,nres-1
2619           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2620      &     ((ug2(l,k,i),l=1,2),k=1,2),
2621      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2622         enddo
2623         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2624         do i=1,nres-1
2625           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2626      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2627      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2628         enddo
2629         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2630         do i=1,nres-1
2631           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2632      &     costab(i),sintab(i),costab2(i),sintab2(i)
2633         enddo
2634         write (iout,*) "Array MUDER"
2635         do i=1,nres-1
2636           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2637         enddo
2638 c      endif
2639 #endif
2640       if (nfgtasks.gt.1) then
2641         time00=MPI_Wtime()
2642 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2643 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2644 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2645 #ifdef MATGATHER
2646         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2653      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2654      &   FG_COMM1,IERR)
2655         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2656      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2657      &   FG_COMM1,IERR)
2658         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2659      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2660      &   FG_COMM1,IERR)
2661         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2662      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2663      &   FG_COMM1,IERR)
2664         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2665      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2666      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2667         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2668      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2669      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2670         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2671      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2672      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2673         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2674      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2675      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2676         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2677      &  then
2678         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2679      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2680      &   FG_COMM1,IERR)
2681         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2682      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2683      &   FG_COMM1,IERR)
2684         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2685      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2686      &   FG_COMM1,IERR)
2687        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2688      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2689      &   FG_COMM1,IERR)
2690         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2691      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2692      &   FG_COMM1,IERR)
2693         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2694      &   ivec_count(fg_rank1),
2695      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2707      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2708      &   FG_COMM1,IERR)
2709         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2713      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2714      &   FG_COMM1,IERR)
2715         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2716      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2717      &   FG_COMM1,IERR)
2718         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2719      &   ivec_count(fg_rank1),
2720      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2724      &   FG_COMM1,IERR)
2725        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2730      &   FG_COMM1,IERR)
2731        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2735      &   ivec_count(fg_rank1),
2736      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2737      &   FG_COMM1,IERR)
2738         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2739      &   ivec_count(fg_rank1),
2740      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2743      &   ivec_count(fg_rank1),
2744      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2745      &   MPI_MAT2,FG_COMM1,IERR)
2746         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2747      &   ivec_count(fg_rank1),
2748      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2749      &   MPI_MAT2,FG_COMM1,IERR)
2750         endif
2751 #else
2752 c Passes matrix info through the ring
2753       isend=fg_rank1
2754       irecv=fg_rank1-1
2755       if (irecv.lt.0) irecv=nfgtasks1-1
2756       iprev=irecv
2757       inext=fg_rank1+1
2758       if (inext.ge.nfgtasks1) inext=0
2759       do i=1,nfgtasks1-1
2760 c        write (iout,*) "isend",isend," irecv",irecv
2761 c        call flush(iout)
2762         lensend=lentyp(isend)
2763         lenrecv=lentyp(irecv)
2764 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2765 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2766 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2767 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2768 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2769 c        write (iout,*) "Gather ROTAT1"
2770 c        call flush(iout)
2771 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2772 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2773 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2774 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2775 c        write (iout,*) "Gather ROTAT2"
2776 c        call flush(iout)
2777         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2778      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2779      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2780      &   iprev,4400+irecv,FG_COMM,status,IERR)
2781 c        write (iout,*) "Gather ROTAT_OLD"
2782 c        call flush(iout)
2783         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2784      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2785      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2786      &   iprev,5500+irecv,FG_COMM,status,IERR)
2787 c        write (iout,*) "Gather PRECOMP11"
2788 c        call flush(iout)
2789         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2790      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2791      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2792      &   iprev,6600+irecv,FG_COMM,status,IERR)
2793 c        write (iout,*) "Gather PRECOMP12"
2794 c        call flush(iout)
2795         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2796      &  then
2797         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2798      &   MPI_ROTAT2(lensend),inext,7700+isend,
2799      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2800      &   iprev,7700+irecv,FG_COMM,status,IERR)
2801 c        write (iout,*) "Gather PRECOMP21"
2802 c        call flush(iout)
2803         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2804      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2805      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2806      &   iprev,8800+irecv,FG_COMM,status,IERR)
2807 c        write (iout,*) "Gather PRECOMP22"
2808 c        call flush(iout)
2809         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2810      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2811      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2812      &   MPI_PRECOMP23(lenrecv),
2813      &   iprev,9900+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather PRECOMP23"
2815 c        call flush(iout)
2816         endif
2817         isend=irecv
2818         irecv=irecv-1
2819         if (irecv.lt.0) irecv=nfgtasks1-1
2820       enddo
2821 #endif
2822         time_gather=time_gather+MPI_Wtime()-time00
2823       endif
2824 #ifdef DEBUG
2825 c      if (fg_rank.eq.0) then
2826         write (iout,*) "Arrays UG and UGDER"
2827         do i=1,nres-1
2828           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2829      &     ((ug(l,k,i),l=1,2),k=1,2),
2830      &     ((ugder(l,k,i),l=1,2),k=1,2)
2831         enddo
2832         write (iout,*) "Arrays UG2 and UG2DER"
2833         do i=1,nres-1
2834           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2835      &     ((ug2(l,k,i),l=1,2),k=1,2),
2836      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2837         enddo
2838         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2839         do i=1,nres-1
2840           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2841      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2842      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2843         enddo
2844         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2845         do i=1,nres-1
2846           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2847      &     costab(i),sintab(i),costab2(i),sintab2(i)
2848         enddo
2849         write (iout,*) "Array MUDER"
2850         do i=1,nres-1
2851           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2852         enddo
2853 c      endif
2854 #endif
2855 #endif
2856 cd      do i=1,nres
2857 cd        iti = itortyp(itype(i))
2858 cd        write (iout,*) i
2859 cd        do j=1,2
2860 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2861 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2862 cd        enddo
2863 cd      enddo
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2868 C
2869 C This subroutine calculates the average interaction energy and its gradient
2870 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2871 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2872 C The potential depends both on the distance of peptide-group centers and on
2873 C the orientation of the CA-CA virtual bonds.
2874 C
2875       implicit real*8 (a-h,o-z)
2876 #ifdef MPI
2877       include 'mpif.h'
2878 #endif
2879       include 'DIMENSIONS'
2880       include 'COMMON.CONTROL'
2881       include 'COMMON.SETUP'
2882       include 'COMMON.IOUNITS'
2883       include 'COMMON.GEO'
2884       include 'COMMON.VAR'
2885       include 'COMMON.LOCAL'
2886       include 'COMMON.CHAIN'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       include 'COMMON.CONTACTS'
2890 #ifdef MOMENT
2891       include 'COMMON.CONTACTS.MOMENT'
2892 #endif
2893       include 'COMMON.TORSION'
2894       include 'COMMON.VECTORS'
2895       include 'COMMON.FFIELD'
2896       include 'COMMON.TIME1'
2897       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2898      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2899       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2900      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2901       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2902      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2903      &    num_conti,j1,j2
2904 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2905 #ifdef MOMENT
2906       double precision scal_el /1.0d0/
2907 #else
2908       double precision scal_el /0.5d0/
2909 #endif
2910 C 12/13/98
2911 C 13-go grudnia roku pamietnego...
2912       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2913      &                   0.0d0,1.0d0,0.0d0,
2914      &                   0.0d0,0.0d0,1.0d0/
2915 cd      write(iout,*) 'In EELEC'
2916 cd      do i=1,nloctyp
2917 cd        write(iout,*) 'Type',i
2918 cd        write(iout,*) 'B1',B1(:,i)
2919 cd        write(iout,*) 'B2',B2(:,i)
2920 cd        write(iout,*) 'CC',CC(:,:,i)
2921 cd        write(iout,*) 'DD',DD(:,:,i)
2922 cd        write(iout,*) 'EE',EE(:,:,i)
2923 cd      enddo
2924 cd      call check_vecgrad
2925 cd      stop
2926       if (icheckgrad.eq.1) then
2927         do i=1,nres-1
2928           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2929           do k=1,3
2930             dc_norm(k,i)=dc(k,i)*fac
2931           enddo
2932 c          write (iout,*) 'i',i,' fac',fac
2933         enddo
2934       endif
2935       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2936      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2937      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2938 c        call vec_and_deriv
2939 #ifdef TIMING
2940         time01=MPI_Wtime()
2941 #endif
2942         call set_matrices
2943 #ifdef TIMING
2944         time_mat=time_mat+MPI_Wtime()-time01
2945 #endif
2946       endif
2947 cd      do i=1,nres-1
2948 cd        write (iout,*) 'i=',i
2949 cd        do k=1,3
2950 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2951 cd        enddo
2952 cd        do k=1,3
2953 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2954 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2955 cd        enddo
2956 cd      enddo
2957       t_eelecij=0.0d0
2958       ees=0.0D0
2959       evdw1=0.0D0
2960       eel_loc=0.0d0
2961       eello_turn3=0.0d0
2962       eello_turn4=0.0d0
2963       ind=0
2964       do i=1,nres
2965         num_cont_hb(i)=0
2966       enddo
2967 cd      print '(a)','Enter EELEC'
2968 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2969       do i=1,nres
2970         gel_loc_loc(i)=0.0d0
2971         gcorr_loc(i)=0.0d0
2972       enddo
2973 c
2974 c
2975 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2976 C
2977 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2978 C
2979       do i=iturn3_start,iturn3_end
2980         dxi=dc(1,i)
2981         dyi=dc(2,i)
2982         dzi=dc(3,i)
2983         dx_normi=dc_norm(1,i)
2984         dy_normi=dc_norm(2,i)
2985         dz_normi=dc_norm(3,i)
2986         xmedi=c(1,i)+0.5d0*dxi
2987         ymedi=c(2,i)+0.5d0*dyi
2988         zmedi=c(3,i)+0.5d0*dzi
2989         num_conti=0
2990         call eelecij(i,i+2,ees,evdw1,eel_loc)
2991         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2992         num_cont_hb(i)=num_conti
2993       enddo
2994       do i=iturn4_start,iturn4_end
2995         dxi=dc(1,i)
2996         dyi=dc(2,i)
2997         dzi=dc(3,i)
2998         dx_normi=dc_norm(1,i)
2999         dy_normi=dc_norm(2,i)
3000         dz_normi=dc_norm(3,i)
3001         xmedi=c(1,i)+0.5d0*dxi
3002         ymedi=c(2,i)+0.5d0*dyi
3003         zmedi=c(3,i)+0.5d0*dzi
3004         num_conti=num_cont_hb(i)
3005         call eelecij(i,i+3,ees,evdw1,eel_loc)
3006         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3007         num_cont_hb(i)=num_conti
3008       enddo   ! i
3009 c
3010 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3011 c
3012       do i=iatel_s,iatel_e
3013         dxi=dc(1,i)
3014         dyi=dc(2,i)
3015         dzi=dc(3,i)
3016         dx_normi=dc_norm(1,i)
3017         dy_normi=dc_norm(2,i)
3018         dz_normi=dc_norm(3,i)
3019         xmedi=c(1,i)+0.5d0*dxi
3020         ymedi=c(2,i)+0.5d0*dyi
3021         zmedi=c(3,i)+0.5d0*dzi
3022 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3023         num_conti=num_cont_hb(i)
3024         do j=ielstart(i),ielend(i)
3025           call eelecij(i,j,ees,evdw1,eel_loc)
3026         enddo ! j
3027         num_cont_hb(i)=num_conti
3028       enddo   ! i
3029 c      write (iout,*) "Number of loop steps in EELEC:",ind
3030 cd      do i=1,nres
3031 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3032 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3033 cd      enddo
3034 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3035 ccc      eel_loc=eel_loc+eello_turn3
3036 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3037       return
3038       end
3039 C-------------------------------------------------------------------------------
3040       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3041       implicit real*8 (a-h,o-z)
3042       include 'DIMENSIONS'
3043 #ifdef MPI
3044       include "mpif.h"
3045 #endif
3046       include 'COMMON.CONTROL'
3047       include 'COMMON.IOUNITS'
3048       include 'COMMON.GEO'
3049       include 'COMMON.VAR'
3050       include 'COMMON.LOCAL'
3051       include 'COMMON.CHAIN'
3052       include 'COMMON.DERIV'
3053       include 'COMMON.INTERACT'
3054       include 'COMMON.CONTACTS'
3055 #ifdef MOMENT
3056       include 'COMMON.CONTACTS.MOMENT'
3057 #endif
3058       include 'COMMON.TORSION'
3059       include 'COMMON.VECTORS'
3060       include 'COMMON.FFIELD'
3061       include 'COMMON.TIME1'
3062       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3063      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3064       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3065      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3066       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3067      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3068      &    num_conti,j1,j2
3069 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3070 #ifdef MOMENT
3071       double precision scal_el /1.0d0/
3072 #else
3073       double precision scal_el /0.5d0/
3074 #endif
3075 C 12/13/98
3076 C 13-go grudnia roku pamietnego...
3077       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3078      &                   0.0d0,1.0d0,0.0d0,
3079      &                   0.0d0,0.0d0,1.0d0/
3080 c          time00=MPI_Wtime()
3081 cd      write (iout,*) "eelecij",i,j
3082 c          ind=ind+1
3083           iteli=itel(i)
3084           itelj=itel(j)
3085           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3086           aaa=app(iteli,itelj)
3087           bbb=bpp(iteli,itelj)
3088           ael6i=ael6(iteli,itelj)
3089           ael3i=ael3(iteli,itelj)
3090           dxj=dc(1,j)
3091           dyj=dc(2,j)
3092           dzj=dc(3,j)
3093           dx_normj=dc_norm(1,j)
3094           dy_normj=dc_norm(2,j)
3095           dz_normj=dc_norm(3,j)
3096           xj=c(1,j)+0.5D0*dxj-xmedi
3097           yj=c(2,j)+0.5D0*dyj-ymedi
3098           zj=c(3,j)+0.5D0*dzj-zmedi
3099           rij=xj*xj+yj*yj+zj*zj
3100           rrmij=1.0D0/rij
3101           rij=dsqrt(rij)
3102           rmij=1.0D0/rij
3103           r3ij=rrmij*rmij
3104           r6ij=r3ij*r3ij
3105           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3106           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3107           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3108           fac=cosa-3.0D0*cosb*cosg
3109           ev1=aaa*r6ij*r6ij
3110 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3111           if (j.eq.i+2) ev1=scal_el*ev1
3112           ev2=bbb*r6ij
3113           fac3=ael6i*r6ij
3114           fac4=ael3i*r3ij
3115           evdwij=ev1+ev2
3116           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3117           el2=fac4*fac
3118           eesij=el1+el2
3119 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3120           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3121           ees=ees+eesij
3122           evdw1=evdw1+evdwij
3123 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3124 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3125 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3126 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3127
3128           if (energy_dec) then
3129               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3130               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3131           endif
3132
3133 C
3134 C Calculate contributions to the Cartesian gradient.
3135 C
3136 #ifdef SPLITELE
3137           facvdw=-6*rrmij*(ev1+evdwij)
3138           facel=-3*rrmij*(el1+eesij)
3139           fac1=fac
3140           erij(1)=xj*rmij
3141           erij(2)=yj*rmij
3142           erij(3)=zj*rmij
3143 *
3144 * Radial derivatives. First process both termini of the fragment (i,j)
3145 *
3146           ggg(1)=facel*xj
3147           ggg(2)=facel*yj
3148           ggg(3)=facel*zj
3149 c          do k=1,3
3150 c            ghalf=0.5D0*ggg(k)
3151 c            gelc(k,i)=gelc(k,i)+ghalf
3152 c            gelc(k,j)=gelc(k,j)+ghalf
3153 c          enddo
3154 c 9/28/08 AL Gradient compotents will be summed only at the end
3155           do k=1,3
3156             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3157             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3158           enddo
3159 *
3160 * Loop over residues i+1 thru j-1.
3161 *
3162 cgrad          do k=i+1,j-1
3163 cgrad            do l=1,3
3164 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3165 cgrad            enddo
3166 cgrad          enddo
3167           ggg(1)=facvdw*xj
3168           ggg(2)=facvdw*yj
3169           ggg(3)=facvdw*zj
3170 c          do k=1,3
3171 c            ghalf=0.5D0*ggg(k)
3172 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3173 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3174 c          enddo
3175 c 9/28/08 AL Gradient compotents will be summed only at the end
3176           do k=1,3
3177             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3178             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3179           enddo
3180 *
3181 * Loop over residues i+1 thru j-1.
3182 *
3183 cgrad          do k=i+1,j-1
3184 cgrad            do l=1,3
3185 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3186 cgrad            enddo
3187 cgrad          enddo
3188 #else
3189           facvdw=ev1+evdwij
3190           facel=el1+eesij
3191           fac1=fac
3192           fac=-3*rrmij*(facvdw+facvdw+facel)
3193           erij(1)=xj*rmij
3194           erij(2)=yj*rmij
3195           erij(3)=zj*rmij
3196 *
3197 * Radial derivatives. First process both termini of the fragment (i,j)
3198 *
3199           ggg(1)=fac*xj
3200           ggg(2)=fac*yj
3201           ggg(3)=fac*zj
3202 c          do k=1,3
3203 c            ghalf=0.5D0*ggg(k)
3204 c            gelc(k,i)=gelc(k,i)+ghalf
3205 c            gelc(k,j)=gelc(k,j)+ghalf
3206 c          enddo
3207 c 9/28/08 AL Gradient compotents will be summed only at the end
3208           do k=1,3
3209             gelc_long(k,j)=gelc(k,j)+ggg(k)
3210             gelc_long(k,i)=gelc(k,i)-ggg(k)
3211           enddo
3212 *
3213 * Loop over residues i+1 thru j-1.
3214 *
3215 cgrad          do k=i+1,j-1
3216 cgrad            do l=1,3
3217 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3218 cgrad            enddo
3219 cgrad          enddo
3220 c 9/28/08 AL Gradient compotents will be summed only at the end
3221           ggg(1)=facvdw*xj
3222           ggg(2)=facvdw*yj
3223           ggg(3)=facvdw*zj
3224           do k=1,3
3225             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3226             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3227           enddo
3228 #endif
3229 *
3230 * Angular part
3231 *
3232           ecosa=2.0D0*fac3*fac1+fac4
3233           fac4=-3.0D0*fac4
3234           fac3=-6.0D0*fac3
3235           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3236           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3237           do k=1,3
3238             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3239             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3240           enddo
3241 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3242 cd   &          (dcosg(k),k=1,3)
3243           do k=1,3
3244             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3245           enddo
3246 c          do k=1,3
3247 c            ghalf=0.5D0*ggg(k)
3248 c            gelc(k,i)=gelc(k,i)+ghalf
3249 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3250 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3251 c            gelc(k,j)=gelc(k,j)+ghalf
3252 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3253 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3254 c          enddo
3255 cgrad          do k=i+1,j-1
3256 cgrad            do l=1,3
3257 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3258 cgrad            enddo
3259 cgrad          enddo
3260           do k=1,3
3261             gelc(k,i)=gelc(k,i)
3262      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3263      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3264             gelc(k,j)=gelc(k,j)
3265      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3266      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3267             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3268             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3269           enddo
3270           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3271      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3272      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3273 C
3274 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3275 C   energy of a peptide unit is assumed in the form of a second-order
3276 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3277 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3278 C   are computed for EVERY pair of non-contiguous peptide groups.
3279 C
3280           if (j.lt.nres-1) then
3281             j1=j+1
3282             j2=j-1
3283           else
3284             j1=j-1
3285             j2=j-2
3286           endif
3287           kkk=0
3288           do k=1,2
3289             do l=1,2
3290               kkk=kkk+1
3291               muij(kkk)=mu(k,i)*mu(l,j)
3292             enddo
3293           enddo
3294 cd         write (iout,*) 'EELEC: i',i,' j',j
3295 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3296 cd          write(iout,*) 'muij',muij
3297           ury=scalar(uy(1,i),erij)
3298           urz=scalar(uz(1,i),erij)
3299           vry=scalar(uy(1,j),erij)
3300           vrz=scalar(uz(1,j),erij)
3301           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3302           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3303           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3304           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3305           fac=dsqrt(-ael6i)*r3ij
3306           a22=a22*fac
3307           a23=a23*fac
3308           a32=a32*fac
3309           a33=a33*fac
3310 cd          write (iout,'(4i5,4f10.5)')
3311 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3312 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3313 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3314 cd     &      uy(:,j),uz(:,j)
3315 cd          write (iout,'(4f10.5)')
3316 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3317 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3318 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3319 cd           write (iout,'(9f10.5/)')
3320 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3321 C Derivatives of the elements of A in virtual-bond vectors
3322           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3323           do k=1,3
3324             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3325             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3326             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3327             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3328             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3329             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3330             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3331             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3332             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3333             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3334             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3335             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3336           enddo
3337 C Compute radial contributions to the gradient
3338           facr=-3.0d0*rrmij
3339           a22der=a22*facr
3340           a23der=a23*facr
3341           a32der=a32*facr
3342           a33der=a33*facr
3343           agg(1,1)=a22der*xj
3344           agg(2,1)=a22der*yj
3345           agg(3,1)=a22der*zj
3346           agg(1,2)=a23der*xj
3347           agg(2,2)=a23der*yj
3348           agg(3,2)=a23der*zj
3349           agg(1,3)=a32der*xj
3350           agg(2,3)=a32der*yj
3351           agg(3,3)=a32der*zj
3352           agg(1,4)=a33der*xj
3353           agg(2,4)=a33der*yj
3354           agg(3,4)=a33der*zj
3355 C Add the contributions coming from er
3356           fac3=-3.0d0*fac
3357           do k=1,3
3358             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3359             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3360             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3361             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3362           enddo
3363           do k=1,3
3364 C Derivatives in DC(i)
3365 cgrad            ghalf1=0.5d0*agg(k,1)
3366 cgrad            ghalf2=0.5d0*agg(k,2)
3367 cgrad            ghalf3=0.5d0*agg(k,3)
3368 cgrad            ghalf4=0.5d0*agg(k,4)
3369             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3370      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3371             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3372      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3373             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3374      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3375             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3376      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3377 C Derivatives in DC(i+1)
3378             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3379      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3380             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3381      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3382             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3383      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3384             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3385      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3386 C Derivatives in DC(j)
3387             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3388      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3389             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3390      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3391             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3392      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3393             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3394      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3395 C Derivatives in DC(j+1) or DC(nres-1)
3396             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3397      &      -3.0d0*vryg(k,3)*ury)
3398             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3399      &      -3.0d0*vrzg(k,3)*ury)
3400             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3401      &      -3.0d0*vryg(k,3)*urz)
3402             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3403      &      -3.0d0*vrzg(k,3)*urz)
3404 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3405 cgrad              do l=1,4
3406 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3407 cgrad              enddo
3408 cgrad            endif
3409           enddo
3410           acipa(1,1)=a22
3411           acipa(1,2)=a23
3412           acipa(2,1)=a32
3413           acipa(2,2)=a33
3414           a22=-a22
3415           a23=-a23
3416           do l=1,2
3417             do k=1,3
3418               agg(k,l)=-agg(k,l)
3419               aggi(k,l)=-aggi(k,l)
3420               aggi1(k,l)=-aggi1(k,l)
3421               aggj(k,l)=-aggj(k,l)
3422               aggj1(k,l)=-aggj1(k,l)
3423             enddo
3424           enddo
3425           if (j.lt.nres-1) then
3426             a22=-a22
3427             a32=-a32
3428             do l=1,3,2
3429               do k=1,3
3430                 agg(k,l)=-agg(k,l)
3431                 aggi(k,l)=-aggi(k,l)
3432                 aggi1(k,l)=-aggi1(k,l)
3433                 aggj(k,l)=-aggj(k,l)
3434                 aggj1(k,l)=-aggj1(k,l)
3435               enddo
3436             enddo
3437           else
3438             a22=-a22
3439             a23=-a23
3440             a32=-a32
3441             a33=-a33
3442             do l=1,4
3443               do k=1,3
3444                 agg(k,l)=-agg(k,l)
3445                 aggi(k,l)=-aggi(k,l)
3446                 aggi1(k,l)=-aggi1(k,l)
3447                 aggj(k,l)=-aggj(k,l)
3448                 aggj1(k,l)=-aggj1(k,l)
3449               enddo
3450             enddo
3451           endif
3452           ENDIF ! WCORR
3453           IF (wel_loc.gt.0.0d0) THEN
3454 C Contribution to the local-electrostatic energy coming from the i-j pair
3455           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3456      &     +a33*muij(4)
3457 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3458
3459           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3460      &            'eelloc',i,j,eel_loc_ij
3461
3462           eel_loc=eel_loc+eel_loc_ij
3463 C Partial derivatives in virtual-bond dihedral angles gamma
3464           if (i.gt.1)
3465      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3466      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3467      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3468           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3469      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3470      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3471 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3472           do l=1,3
3473             ggg(l)=agg(l,1)*muij(1)+
3474      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3475             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3476             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3477 cgrad            ghalf=0.5d0*ggg(l)
3478 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3479 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3480           enddo
3481 cgrad          do k=i+1,j2
3482 cgrad            do l=1,3
3483 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3484 cgrad            enddo
3485 cgrad          enddo
3486 C Remaining derivatives of eello
3487           do l=1,3
3488             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3489      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3490             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3491      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3492             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3493      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3494             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3495      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3496           enddo
3497           ENDIF
3498 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3499 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3500           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3501      &       .and. num_conti.le.maxconts) then
3502 c            write (iout,*) i,j," entered corr"
3503 C
3504 C Calculate the contact function. The ith column of the array JCONT will
3505 C contain the numbers of atoms that make contacts with the atom I (of numbers
3506 C greater than I). The arrays FACONT and GACONT will contain the values of
3507 C the contact function and its derivative.
3508 c           r0ij=1.02D0*rpp(iteli,itelj)
3509 c           r0ij=1.11D0*rpp(iteli,itelj)
3510             r0ij=2.20D0*rpp(iteli,itelj)
3511 c           r0ij=1.55D0*rpp(iteli,itelj)
3512             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3513             if (fcont.gt.0.0D0) then
3514               num_conti=num_conti+1
3515               if (num_conti.gt.maxconts) then
3516                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3517      &                         ' will skip next contacts for this conf.'
3518               else
3519                 jcont_hb(num_conti,i)=j
3520 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3521 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3522                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3523      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3524 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3525 C  terms.
3526                 d_cont(num_conti,i)=rij
3527 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3528 C     --- Electrostatic-interaction matrix ---
3529                 a_chuj(1,1,num_conti,i)=a22
3530                 a_chuj(1,2,num_conti,i)=a23
3531                 a_chuj(2,1,num_conti,i)=a32
3532                 a_chuj(2,2,num_conti,i)=a33
3533 C     --- Gradient of rij
3534                 do kkk=1,3
3535                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3536                 enddo
3537                 kkll=0
3538                 do k=1,2
3539                   do l=1,2
3540                     kkll=kkll+1
3541                     do m=1,3
3542                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3543                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3544                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3545                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3546                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3547                     enddo
3548                   enddo
3549                 enddo
3550                 ENDIF
3551                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3552 C Calculate contact energies
3553                 cosa4=4.0D0*cosa
3554                 wij=cosa-3.0D0*cosb*cosg
3555                 cosbg1=cosb+cosg
3556                 cosbg2=cosb-cosg
3557 c               fac3=dsqrt(-ael6i)/r0ij**3
3558                 fac3=dsqrt(-ael6i)*r3ij
3559 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3560                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3561                 if (ees0tmp.gt.0) then
3562                   ees0pij=dsqrt(ees0tmp)
3563                 else
3564                   ees0pij=0
3565                 endif
3566 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3567                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3568                 if (ees0tmp.gt.0) then
3569                   ees0mij=dsqrt(ees0tmp)
3570                 else
3571                   ees0mij=0
3572                 endif
3573 c               ees0mij=0.0D0
3574                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3575                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3576 C Diagnostics. Comment out or remove after debugging!
3577 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3578 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3579 c               ees0m(num_conti,i)=0.0D0
3580 C End diagnostics.
3581 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3582 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3583 C Angular derivatives of the contact function
3584                 ees0pij1=fac3/ees0pij
3585                 ees0mij1=fac3/ees0mij
3586                 fac3p=-3.0D0*fac3*rrmij
3587                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3588                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3589 c               ees0mij1=0.0D0
3590                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3591                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3592                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3593                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3594                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3595                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3596                 ecosap=ecosa1+ecosa2
3597                 ecosbp=ecosb1+ecosb2
3598                 ecosgp=ecosg1+ecosg2
3599                 ecosam=ecosa1-ecosa2
3600                 ecosbm=ecosb1-ecosb2
3601                 ecosgm=ecosg1-ecosg2
3602 C Diagnostics
3603 c               ecosap=ecosa1
3604 c               ecosbp=ecosb1
3605 c               ecosgp=ecosg1
3606 c               ecosam=0.0D0
3607 c               ecosbm=0.0D0
3608 c               ecosgm=0.0D0
3609 C End diagnostics
3610                 facont_hb(num_conti,i)=fcont
3611                 fprimcont=fprimcont/rij
3612 cd              facont_hb(num_conti,i)=1.0D0
3613 C Following line is for diagnostics.
3614 cd              fprimcont=0.0D0
3615                 do k=1,3
3616                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3617                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3618                 enddo
3619                 do k=1,3
3620                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3621                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3622                 enddo
3623                 gggp(1)=gggp(1)+ees0pijp*xj
3624                 gggp(2)=gggp(2)+ees0pijp*yj
3625                 gggp(3)=gggp(3)+ees0pijp*zj
3626                 gggm(1)=gggm(1)+ees0mijp*xj
3627                 gggm(2)=gggm(2)+ees0mijp*yj
3628                 gggm(3)=gggm(3)+ees0mijp*zj
3629 C Derivatives due to the contact function
3630                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3631                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3632                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3633                 do k=1,3
3634 c
3635 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3636 c          following the change of gradient-summation algorithm.
3637 c
3638 cgrad                  ghalfp=0.5D0*gggp(k)
3639 cgrad                  ghalfm=0.5D0*gggm(k)
3640                   gacontp_hb1(k,num_conti,i)=!ghalfp
3641      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3642      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3643                   gacontp_hb2(k,num_conti,i)=!ghalfp
3644      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3645      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3646                   gacontp_hb3(k,num_conti,i)=gggp(k)
3647                   gacontm_hb1(k,num_conti,i)=!ghalfm
3648      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3649      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3650                   gacontm_hb2(k,num_conti,i)=!ghalfm
3651      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3652      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3653                   gacontm_hb3(k,num_conti,i)=gggm(k)
3654                 enddo
3655 C Diagnostics. Comment out or remove after debugging!
3656 cdiag           do k=1,3
3657 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3658 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3659 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3660 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3661 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3662 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3663 cdiag           enddo
3664               ENDIF ! wcorr
3665               endif  ! num_conti.le.maxconts
3666             endif  ! fcont.gt.0
3667           endif    ! j.gt.i+1
3668           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3669             do k=1,4
3670               do l=1,3
3671                 ghalf=0.5d0*agg(l,k)
3672                 aggi(l,k)=aggi(l,k)+ghalf
3673                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3674                 aggj(l,k)=aggj(l,k)+ghalf
3675               enddo
3676             enddo
3677             if (j.eq.nres-1 .and. i.lt.j-2) then
3678               do k=1,4
3679                 do l=1,3
3680                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3681                 enddo
3682               enddo
3683             endif
3684           endif
3685 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3686       return
3687       end
3688 C-----------------------------------------------------------------------------
3689       subroutine eturn3(i,eello_turn3)
3690 C Third- and fourth-order contributions from turns
3691       implicit real*8 (a-h,o-z)
3692       include 'DIMENSIONS'
3693       include 'COMMON.IOUNITS'
3694       include 'COMMON.GEO'
3695       include 'COMMON.VAR'
3696       include 'COMMON.LOCAL'
3697       include 'COMMON.CHAIN'
3698       include 'COMMON.DERIV'
3699       include 'COMMON.INTERACT'
3700       include 'COMMON.CONTACTS'
3701 #ifdef MOMENT
3702       include 'COMMON.CONTACTS.MOMENT'
3703 #endif
3704       include 'COMMON.TORSION'
3705       include 'COMMON.VECTORS'
3706       include 'COMMON.FFIELD'
3707       include 'COMMON.CONTROL'
3708       dimension ggg(3)
3709       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3710      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3711      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3712       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3713      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3714       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3715      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3716      &    num_conti,j1,j2
3717       j=i+2
3718 c      write (iout,*) "eturn3",i,j,j1,j2
3719       a_temp(1,1)=a22
3720       a_temp(1,2)=a23
3721       a_temp(2,1)=a32
3722       a_temp(2,2)=a33
3723 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3724 C
3725 C               Third-order contributions
3726 C
3727 C                 (i+2)o----(i+3)
3728 C                      | |
3729 C                      | |
3730 C                 (i+1)o----i
3731 C
3732 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3733 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3734         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3735         call transpose2(auxmat(1,1),auxmat1(1,1))
3736         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3737         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3738         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3739      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3740 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3741 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3742 cd     &    ' eello_turn3_num',4*eello_turn3_num
3743 C Derivatives in gamma(i)
3744         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3745         call transpose2(auxmat2(1,1),auxmat3(1,1))
3746         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3747         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3748 C Derivatives in gamma(i+1)
3749         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3750         call transpose2(auxmat2(1,1),auxmat3(1,1))
3751         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3752         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3753      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3754 C Cartesian derivatives
3755         do l=1,3
3756 c            ghalf1=0.5d0*agg(l,1)
3757 c            ghalf2=0.5d0*agg(l,2)
3758 c            ghalf3=0.5d0*agg(l,3)
3759 c            ghalf4=0.5d0*agg(l,4)
3760           a_temp(1,1)=aggi(l,1)!+ghalf1
3761           a_temp(1,2)=aggi(l,2)!+ghalf2
3762           a_temp(2,1)=aggi(l,3)!+ghalf3
3763           a_temp(2,2)=aggi(l,4)!+ghalf4
3764           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3765           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3766      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3767           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3768           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3769           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3770           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3771           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3772           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3773      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3774           a_temp(1,1)=aggj(l,1)!+ghalf1
3775           a_temp(1,2)=aggj(l,2)!+ghalf2
3776           a_temp(2,1)=aggj(l,3)!+ghalf3
3777           a_temp(2,2)=aggj(l,4)!+ghalf4
3778           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3779           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3780      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3781           a_temp(1,1)=aggj1(l,1)
3782           a_temp(1,2)=aggj1(l,2)
3783           a_temp(2,1)=aggj1(l,3)
3784           a_temp(2,2)=aggj1(l,4)
3785           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3786           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3787      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3788         enddo
3789       return
3790       end
3791 C-------------------------------------------------------------------------------
3792       subroutine eturn4(i,eello_turn4)
3793 C Third- and fourth-order contributions from turns
3794       implicit real*8 (a-h,o-z)
3795       include 'DIMENSIONS'
3796       include 'COMMON.IOUNITS'
3797       include 'COMMON.GEO'
3798       include 'COMMON.VAR'
3799       include 'COMMON.LOCAL'
3800       include 'COMMON.CHAIN'
3801       include 'COMMON.DERIV'
3802       include 'COMMON.INTERACT'
3803       include 'COMMON.CONTACTS'
3804 #ifdef MOMENT
3805       include 'COMMON.CONTACTS.MOMENT'
3806 #endif
3807       include 'COMMON.TORSION'
3808       include 'COMMON.VECTORS'
3809       include 'COMMON.FFIELD'
3810       include 'COMMON.CONTROL'
3811       dimension ggg(3)
3812       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3813      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3814      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3815       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3816      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3817       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3818      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3819      &    num_conti,j1,j2
3820       j=i+3
3821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3822 C
3823 C               Fourth-order contributions
3824 C
3825 C                 (i+3)o----(i+4)
3826 C                     /  |
3827 C               (i+2)o   |
3828 C                     \  |
3829 C                 (i+1)o----i
3830 C
3831 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3832 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3833 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3834         a_temp(1,1)=a22
3835         a_temp(1,2)=a23
3836         a_temp(2,1)=a32
3837         a_temp(2,2)=a33
3838         iti1=itortyp(itype(i+1))
3839         iti2=itortyp(itype(i+2))
3840         iti3=itortyp(itype(i+3))
3841 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3842         call transpose2(EUg(1,1,i+1),e1t(1,1))
3843         call transpose2(Eug(1,1,i+2),e2t(1,1))
3844         call transpose2(Eug(1,1,i+3),e3t(1,1))
3845         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3846         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3847         s1=scalar2(b1(1,iti2),auxvec(1))
3848         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3849         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3850         s2=scalar2(b1(1,iti1),auxvec(1))
3851         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3852         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3853         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3854         eello_turn4=eello_turn4-(s1+s2+s3)
3855         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3856      &      'eturn4',i,j,-(s1+s2+s3)
3857 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3858 cd     &    ' eello_turn4_num',8*eello_turn4_num
3859 C Derivatives in gamma(i)
3860         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3861         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3862         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3863         s1=scalar2(b1(1,iti2),auxvec(1))
3864         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3865         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3867 C Derivatives in gamma(i+1)
3868         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3869         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3870         s2=scalar2(b1(1,iti1),auxvec(1))
3871         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3872         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3873         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3874         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3875 C Derivatives in gamma(i+2)
3876         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3877         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3878         s1=scalar2(b1(1,iti2),auxvec(1))
3879         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3880         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3881         s2=scalar2(b1(1,iti1),auxvec(1))
3882         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3883         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3886 C Cartesian derivatives
3887 C Derivatives of this turn contributions in DC(i+2)
3888         if (j.lt.nres-1) then
3889           do l=1,3
3890             a_temp(1,1)=agg(l,1)
3891             a_temp(1,2)=agg(l,2)
3892             a_temp(2,1)=agg(l,3)
3893             a_temp(2,2)=agg(l,4)
3894             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3895             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3896             s1=scalar2(b1(1,iti2),auxvec(1))
3897             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3898             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3899             s2=scalar2(b1(1,iti1),auxvec(1))
3900             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3901             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3902             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903             ggg(l)=-(s1+s2+s3)
3904             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3905           enddo
3906         endif
3907 C Remaining derivatives of this turn contribution
3908         do l=1,3
3909           a_temp(1,1)=aggi(l,1)
3910           a_temp(1,2)=aggi(l,2)
3911           a_temp(2,1)=aggi(l,3)
3912           a_temp(2,2)=aggi(l,4)
3913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3915           s1=scalar2(b1(1,iti2),auxvec(1))
3916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3918           s2=scalar2(b1(1,iti1),auxvec(1))
3919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3923           a_temp(1,1)=aggi1(l,1)
3924           a_temp(1,2)=aggi1(l,2)
3925           a_temp(2,1)=aggi1(l,3)
3926           a_temp(2,2)=aggi1(l,4)
3927           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3928           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3929           s1=scalar2(b1(1,iti2),auxvec(1))
3930           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3931           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3932           s2=scalar2(b1(1,iti1),auxvec(1))
3933           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3934           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3935           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3936           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3937           a_temp(1,1)=aggj(l,1)
3938           a_temp(1,2)=aggj(l,2)
3939           a_temp(2,1)=aggj(l,3)
3940           a_temp(2,2)=aggj(l,4)
3941           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3942           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3943           s1=scalar2(b1(1,iti2),auxvec(1))
3944           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3945           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3946           s2=scalar2(b1(1,iti1),auxvec(1))
3947           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3948           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3949           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3950           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3951           a_temp(1,1)=aggj1(l,1)
3952           a_temp(1,2)=aggj1(l,2)
3953           a_temp(2,1)=aggj1(l,3)
3954           a_temp(2,2)=aggj1(l,4)
3955           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3956           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3957           s1=scalar2(b1(1,iti2),auxvec(1))
3958           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3959           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3960           s2=scalar2(b1(1,iti1),auxvec(1))
3961           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3962           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3963           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3964 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3965           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3966         enddo
3967       return
3968       end
3969 C-----------------------------------------------------------------------------
3970       subroutine vecpr(u,v,w)
3971       implicit real*8(a-h,o-z)
3972       dimension u(3),v(3),w(3)
3973       w(1)=u(2)*v(3)-u(3)*v(2)
3974       w(2)=-u(1)*v(3)+u(3)*v(1)
3975       w(3)=u(1)*v(2)-u(2)*v(1)
3976       return
3977       end
3978 C-----------------------------------------------------------------------------
3979       subroutine unormderiv(u,ugrad,unorm,ungrad)
3980 C This subroutine computes the derivatives of a normalized vector u, given
3981 C the derivatives computed without normalization conditions, ugrad. Returns
3982 C ungrad.
3983       implicit none
3984       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3985       double precision vec(3)
3986       double precision scalar
3987       integer i,j
3988 c      write (2,*) 'ugrad',ugrad
3989 c      write (2,*) 'u',u
3990       do i=1,3
3991         vec(i)=scalar(ugrad(1,i),u(1))
3992       enddo
3993 c      write (2,*) 'vec',vec
3994       do i=1,3
3995         do j=1,3
3996           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3997         enddo
3998       enddo
3999 c      write (2,*) 'ungrad',ungrad
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine escp_soft_sphere(evdw2,evdw2_14)
4004 C
4005 C This subroutine calculates the excluded-volume interaction energy between
4006 C peptide-group centers and side chains and its gradient in virtual-bond and
4007 C side-chain vectors.
4008 C
4009       implicit real*8 (a-h,o-z)
4010       include 'DIMENSIONS'
4011       include 'COMMON.GEO'
4012       include 'COMMON.VAR'
4013       include 'COMMON.LOCAL'
4014       include 'COMMON.CHAIN'
4015       include 'COMMON.DERIV'
4016       include 'COMMON.INTERACT'
4017       include 'COMMON.FFIELD'
4018       include 'COMMON.IOUNITS'
4019       include 'COMMON.CONTROL'
4020       dimension ggg(3)
4021       evdw2=0.0D0
4022       evdw2_14=0.0d0
4023       r0_scp=4.5d0
4024 cd    print '(a)','Enter ESCP'
4025 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4026       do i=iatscp_s,iatscp_e
4027         iteli=itel(i)
4028         xi=0.5D0*(c(1,i)+c(1,i+1))
4029         yi=0.5D0*(c(2,i)+c(2,i+1))
4030         zi=0.5D0*(c(3,i)+c(3,i+1))
4031
4032         do iint=1,nscp_gr(i)
4033
4034         do j=iscpstart(i,iint),iscpend(i,iint)
4035           itypj=iabs(itype(j))
4036 C Uncomment following three lines for SC-p interactions
4037 c         xj=c(1,nres+j)-xi
4038 c         yj=c(2,nres+j)-yi
4039 c         zj=c(3,nres+j)-zi
4040 C Uncomment following three lines for Ca-p interactions
4041           xj=c(1,j)-xi
4042           yj=c(2,j)-yi
4043           zj=c(3,j)-zi
4044           rij=xj*xj+yj*yj+zj*zj
4045           r0ij=r0_scp
4046           r0ijsq=r0ij*r0ij
4047           if (rij.lt.r0ijsq) then
4048             evdwij=0.25d0*(rij-r0ijsq)**2
4049             fac=rij-r0ijsq
4050           else
4051             evdwij=0.0d0
4052             fac=0.0d0
4053           endif
4054           evdw2=evdw2+evdwij
4055 C
4056 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4057 C
4058           ggg(1)=xj*fac
4059           ggg(2)=yj*fac
4060           ggg(3)=zj*fac
4061 cgrad          if (j.lt.i) then
4062 cd          write (iout,*) 'j<i'
4063 C Uncomment following three lines for SC-p interactions
4064 c           do k=1,3
4065 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4066 c           enddo
4067 cgrad          else
4068 cd          write (iout,*) 'j>i'
4069 cgrad            do k=1,3
4070 cgrad              ggg(k)=-ggg(k)
4071 C Uncomment following line for SC-p interactions
4072 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4073 cgrad            enddo
4074 cgrad          endif
4075 cgrad          do k=1,3
4076 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4077 cgrad          enddo
4078 cgrad          kstart=min0(i+1,j)
4079 cgrad          kend=max0(i-1,j-1)
4080 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4081 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4082 cgrad          do k=kstart,kend
4083 cgrad            do l=1,3
4084 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4085 cgrad            enddo
4086 cgrad          enddo
4087           do k=1,3
4088             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4089             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4090           enddo
4091         enddo
4092
4093         enddo ! iint
4094       enddo ! i
4095       return
4096       end
4097 C-----------------------------------------------------------------------------
4098       subroutine escp(evdw2,evdw2_14)
4099 C
4100 C This subroutine calculates the excluded-volume interaction energy between
4101 C peptide-group centers and side chains and its gradient in virtual-bond and
4102 C side-chain vectors.
4103 C
4104       implicit real*8 (a-h,o-z)
4105       include 'DIMENSIONS'
4106       include 'COMMON.GEO'
4107       include 'COMMON.VAR'
4108       include 'COMMON.LOCAL'
4109       include 'COMMON.CHAIN'
4110       include 'COMMON.DERIV'
4111       include 'COMMON.INTERACT'
4112       include 'COMMON.FFIELD'
4113       include 'COMMON.IOUNITS'
4114       include 'COMMON.CONTROL'
4115       dimension ggg(3)
4116       evdw2=0.0D0
4117       evdw2_14=0.0d0
4118 cd    print '(a)','Enter ESCP'
4119 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4120       do i=iatscp_s,iatscp_e
4121         iteli=itel(i)
4122         xi=0.5D0*(c(1,i)+c(1,i+1))
4123         yi=0.5D0*(c(2,i)+c(2,i+1))
4124         zi=0.5D0*(c(3,i)+c(3,i+1))
4125
4126         do iint=1,nscp_gr(i)
4127
4128         do j=iscpstart(i,iint),iscpend(i,iint)
4129           itypj=iabs(itype(j))
4130 C Uncomment following three lines for SC-p interactions
4131 c         xj=c(1,nres+j)-xi
4132 c         yj=c(2,nres+j)-yi
4133 c         zj=c(3,nres+j)-zi
4134 C Uncomment following three lines for Ca-p interactions
4135           xj=c(1,j)-xi
4136           yj=c(2,j)-yi
4137           zj=c(3,j)-zi
4138           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4139           fac=rrij**expon2
4140           e1=fac*fac*aad(itypj,iteli)
4141           e2=fac*bad(itypj,iteli)
4142           if (iabs(j-i) .le. 2) then
4143             e1=scal14*e1
4144             e2=scal14*e2
4145             evdw2_14=evdw2_14+e1+e2
4146           endif
4147           evdwij=e1+e2
4148           evdw2=evdw2+evdwij
4149           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4150      &        'evdw2',i,j,evdwij
4151 C
4152 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4153 C
4154           fac=-(evdwij+e1)*rrij
4155           ggg(1)=xj*fac
4156           ggg(2)=yj*fac
4157           ggg(3)=zj*fac
4158 cgrad          if (j.lt.i) then
4159 cd          write (iout,*) 'j<i'
4160 C Uncomment following three lines for SC-p interactions
4161 c           do k=1,3
4162 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4163 c           enddo
4164 cgrad          else
4165 cd          write (iout,*) 'j>i'
4166 cgrad            do k=1,3
4167 cgrad              ggg(k)=-ggg(k)
4168 C Uncomment following line for SC-p interactions
4169 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4170 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4171 cgrad            enddo
4172 cgrad          endif
4173 cgrad          do k=1,3
4174 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4175 cgrad          enddo
4176 cgrad          kstart=min0(i+1,j)
4177 cgrad          kend=max0(i-1,j-1)
4178 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4179 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4180 cgrad          do k=kstart,kend
4181 cgrad            do l=1,3
4182 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4183 cgrad            enddo
4184 cgrad          enddo
4185           do k=1,3
4186             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4187             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4188           enddo
4189         enddo
4190
4191         enddo ! iint
4192       enddo ! i
4193       do i=1,nct
4194         do j=1,3
4195           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4196           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4197           gradx_scp(j,i)=expon*gradx_scp(j,i)
4198         enddo
4199       enddo
4200 C******************************************************************************
4201 C
4202 C                              N O T E !!!
4203 C
4204 C To save time the factor EXPON has been extracted from ALL components
4205 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4206 C use!
4207 C
4208 C******************************************************************************
4209       return
4210       end
4211 C--------------------------------------------------------------------------
4212       subroutine edis(ehpb)
4213 C
4214 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4215 C
4216       implicit real*8 (a-h,o-z)
4217       include 'DIMENSIONS'
4218       include 'COMMON.SBRIDGE'
4219       include 'COMMON.CHAIN'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.INTERACT'
4223       include 'COMMON.IOUNITS'
4224       dimension ggg(3)
4225       ehpb=0.0D0
4226 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4227 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4228       if (link_end.eq.0) return
4229       do i=link_start,link_end
4230 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4231 C CA-CA distance used in regularization of structure.
4232         ii=ihpb(i)
4233         jj=jhpb(i)
4234 C iii and jjj point to the residues for which the distance is assigned.
4235         if (ii.gt.nres) then
4236           iii=ii-nres
4237           jjj=jj-nres
4238         else
4239           iii=ii
4240           jjj=jj
4241         endif
4242 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4243 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4244 C    distance and angle dependent SS bond potential.
4245         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4246      &)).eq.1) then
4247           call ssbond_ene(iii,jjj,eij)
4248           ehpb=ehpb+2*eij
4249 cd          write (iout,*) "eij",eij
4250         else
4251 C Calculate the distance between the two points and its difference from the
4252 C target distance.
4253         dd=dist(ii,jj)
4254         rdis=dd-dhpb(i)
4255 C Get the force constant corresponding to this distance.
4256         waga=forcon(i)
4257 C Calculate the contribution to energy.
4258         ehpb=ehpb+waga*rdis*rdis
4259 C
4260 C Evaluate gradient.
4261 C
4262         fac=waga*rdis/dd
4263 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4264 cd   &   ' waga=',waga,' fac=',fac
4265         do j=1,3
4266           ggg(j)=fac*(c(j,jj)-c(j,ii))
4267         enddo
4268 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4269 C If this is a SC-SC distance, we need to calculate the contributions to the
4270 C Cartesian gradient in the SC vectors (ghpbx).
4271         if (iii.lt.ii) then
4272           do j=1,3
4273             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4274             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4275           enddo
4276         endif
4277 cgrad        do j=iii,jjj-1
4278 cgrad          do k=1,3
4279 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4280 cgrad          enddo
4281 cgrad        enddo
4282         do k=1,3
4283           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4284           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4285         enddo
4286         endif
4287       enddo
4288       ehpb=0.5D0*ehpb
4289       return
4290       end
4291 C--------------------------------------------------------------------------
4292       subroutine ssbond_ene(i,j,eij)
4293 C
4294 C Calculate the distance and angle dependent SS-bond potential energy
4295 C using a free-energy function derived based on RHF/6-31G** ab initio
4296 C calculations of diethyl disulfide.
4297 C
4298 C A. Liwo and U. Kozlowska, 11/24/03
4299 C
4300       implicit real*8 (a-h,o-z)
4301       include 'DIMENSIONS'
4302       include 'COMMON.SBRIDGE'
4303       include 'COMMON.CHAIN'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.LOCAL'
4306       include 'COMMON.INTERACT'
4307       include 'COMMON.VAR'
4308       include 'COMMON.IOUNITS'
4309       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4310       itypi=iabs(itype(i))
4311       xi=c(1,nres+i)
4312       yi=c(2,nres+i)
4313       zi=c(3,nres+i)
4314       dxi=dc_norm(1,nres+i)
4315       dyi=dc_norm(2,nres+i)
4316       dzi=dc_norm(3,nres+i)
4317 c      dsci_inv=dsc_inv(itypi)
4318       dsci_inv=vbld_inv(nres+i)
4319       itypj=iabs(itype(j))
4320 c      dscj_inv=dsc_inv(itypj)
4321       dscj_inv=vbld_inv(nres+j)
4322       xj=c(1,nres+j)-xi
4323       yj=c(2,nres+j)-yi
4324       zj=c(3,nres+j)-zi
4325       dxj=dc_norm(1,nres+j)
4326       dyj=dc_norm(2,nres+j)
4327       dzj=dc_norm(3,nres+j)
4328       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4329       rij=dsqrt(rrij)
4330       erij(1)=xj*rij
4331       erij(2)=yj*rij
4332       erij(3)=zj*rij
4333       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4334       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4335       om12=dxi*dxj+dyi*dyj+dzi*dzj
4336       do k=1,3
4337         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4338         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4339       enddo
4340       rij=1.0d0/rij
4341       deltad=rij-d0cm
4342       deltat1=1.0d0-om1
4343       deltat2=1.0d0+om2
4344       deltat12=om2-om1+2.0d0
4345       cosphi=om12-om1*om2
4346       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4347      &  +akct*deltad*deltat12
4348      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4349 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4350 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4351 c     &  " deltat12",deltat12," eij",eij
4352       ed=2*akcm*deltad+akct*deltat12
4353       pom1=akct*deltad
4354       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4355       eom1=-2*akth*deltat1-pom1-om2*pom2
4356       eom2= 2*akth*deltat2+pom1-om1*pom2
4357       eom12=pom2
4358       do k=1,3
4359         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4360         ghpbx(k,i)=ghpbx(k,i)-ggk
4361      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4362      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4363         ghpbx(k,j)=ghpbx(k,j)+ggk
4364      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4365      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4366         ghpbc(k,i)=ghpbc(k,i)-ggk
4367         ghpbc(k,j)=ghpbc(k,j)+ggk
4368       enddo
4369 C
4370 C Calculate the components of the gradient in DC and X
4371 C
4372 cgrad      do k=i,j-1
4373 cgrad        do l=1,3
4374 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4375 cgrad        enddo
4376 cgrad      enddo
4377       return
4378       end
4379 C--------------------------------------------------------------------------
4380       subroutine ebond(estr)
4381 c
4382 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4383 c
4384       implicit real*8 (a-h,o-z)
4385       include 'DIMENSIONS'
4386       include 'COMMON.LOCAL'
4387       include 'COMMON.GEO'
4388       include 'COMMON.INTERACT'
4389       include 'COMMON.DERIV'
4390       include 'COMMON.VAR'
4391       include 'COMMON.CHAIN'
4392       include 'COMMON.IOUNITS'
4393       include 'COMMON.NAMES'
4394       include 'COMMON.FFIELD'
4395       include 'COMMON.CONTROL'
4396       include 'COMMON.SETUP'
4397       double precision u(3),ud(3)
4398       estr=0.0d0
4399       do i=ibondp_start,ibondp_end
4400         diff = vbld(i)-vbldp0
4401 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4402         estr=estr+diff*diff
4403         do j=1,3
4404           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4405         enddo
4406 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4407       enddo
4408       estr=0.5d0*AKP*estr
4409 c
4410 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4411 c
4412       do i=ibond_start,ibond_end
4413         iti=iabs(itype(i))
4414         if (iti.ne.10) then
4415           nbi=nbondterm(iti)
4416           if (nbi.eq.1) then
4417             diff=vbld(i+nres)-vbldsc0(1,iti)
4418 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4419 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4420             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4421             do j=1,3
4422               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4423             enddo
4424           else
4425             do j=1,nbi
4426               diff=vbld(i+nres)-vbldsc0(j,iti)
4427               ud(j)=aksc(j,iti)*diff
4428               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4429             enddo
4430             uprod=u(1)
4431             do j=2,nbi
4432               uprod=uprod*u(j)
4433             enddo
4434             usum=0.0d0
4435             usumsqder=0.0d0
4436             do j=1,nbi
4437               uprod1=1.0d0
4438               uprod2=1.0d0
4439               do k=1,nbi
4440                 if (k.ne.j) then
4441                   uprod1=uprod1*u(k)
4442                   uprod2=uprod2*u(k)*u(k)
4443                 endif
4444               enddo
4445               usum=usum+uprod1
4446               usumsqder=usumsqder+ud(j)*uprod2
4447             enddo
4448             estr=estr+uprod/usum
4449             do j=1,3
4450              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4451             enddo
4452           endif
4453         endif
4454       enddo
4455       return
4456       end
4457 #ifdef CRYST_THETA
4458 C--------------------------------------------------------------------------
4459       subroutine ebend(etheta)
4460 C
4461 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4462 C angles gamma and its derivatives in consecutive thetas and gammas.
4463 C
4464       implicit real*8 (a-h,o-z)
4465       include 'DIMENSIONS'
4466       include 'COMMON.LOCAL'
4467       include 'COMMON.GEO'
4468       include 'COMMON.INTERACT'
4469       include 'COMMON.DERIV'
4470       include 'COMMON.VAR'
4471       include 'COMMON.CHAIN'
4472       include 'COMMON.IOUNITS'
4473       include 'COMMON.NAMES'
4474       include 'COMMON.FFIELD'
4475       include 'COMMON.CONTROL'
4476       common /calcthet/ term1,term2,termm,diffak,ratak,
4477      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4478      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4479       double precision y(2),z(2)
4480       delta=0.02d0*pi
4481 c      time11=dexp(-2*time)
4482 c      time12=1.0d0
4483       etheta=0.0D0
4484 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4485       do i=ithet_start,ithet_end
4486 C Zero the energy function and its derivative at 0 or pi.
4487         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4488 <<<<<<< HEAD
4489         it=iabs(itype(i-1))
4490 =======
4491         it=itype(i-1)
4492         ichir1=isign(1,itype(i-2))
4493         ichir2=isign(1,itype(i))
4494         if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4495         if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4496         if (itype(i-1).eq.10) then
4497          itype1=isign(10,itype(i-2))
4498          ichir11=isign(1,itype(i-2))
4499          ichir12=isign(1,itype(i-2))
4500          itype2=isign(10,itype(i))
4501          ichir21=isign(1,itype(i))
4502          ichir22=isign(1,itype(i))
4503         endif
4504 >>>>>>> bartek2
4505         if (i.gt.3) then
4506 #ifdef OSF
4507           phii=phi(i)
4508           if (phii.ne.phii) phii=150.0
4509 #else
4510           phii=phi(i)
4511 #endif
4512           y(1)=dcos(phii)
4513           y(2)=dsin(phii)
4514         else
4515           y(1)=0.0D0
4516           y(2)=0.0D0
4517         endif
4518         if (i.lt.nres) then
4519 #ifdef OSF
4520           phii1=phi(i+1)
4521           if (phii1.ne.phii1) phii1=150.0
4522           phii1=pinorm(phii1)
4523           z(1)=cos(phii1)
4524 #else
4525           phii1=phi(i+1)
4526           z(1)=dcos(phii1)
4527 #endif
4528           z(2)=dsin(phii1)
4529         else
4530           z(1)=0.0D0
4531           z(2)=0.0D0
4532         endif
4533 C Calculate the "mean" value of theta from the part of the distribution
4534 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4535 C In following comments this theta will be referred to as t_c.
4536         thet_pred_mean=0.0d0
4537         do k=1,2
4538           athetk=athet(k,it,ichir1,ichir2)
4539           bthetk=bthet(k,it,ichir1,ichir2)
4540         if (it.eq.10) then
4541            athetk=athet(k,itype1,ichir11,ichir12)
4542            bthetk=bthet(k,itype2,ichir21,ichir22)
4543         endif
4544           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4545         enddo
4546         dthett=thet_pred_mean*ssd
4547         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4548 C Derivatives of the "mean" values in gamma1 and gamma2.
4549         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4550      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4551         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4552      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4553         if (it.eq.10) then
4554       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4555      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4556         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4557      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4558         endif
4559         if (theta(i).gt.pi-delta) then
4560           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4561      &         E_tc0)
4562           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4563           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4564           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4565      &        E_theta)
4566           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4567      &        E_tc)
4568         else if (theta(i).lt.delta) then
4569           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4570           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4571           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4572      &        E_theta)
4573           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4574           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4575      &        E_tc)
4576         else
4577           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4578      &        E_theta,E_tc)
4579         endif
4580         etheta=etheta+ethetai
4581         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4582      &      'ebend',i,ethetai
4583         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4584         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4585         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4586       enddo
4587 C Ufff.... We've done all this!!!
4588       return
4589       end
4590 C---------------------------------------------------------------------------
4591       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4592      &     E_tc)
4593       implicit real*8 (a-h,o-z)
4594       include 'DIMENSIONS'
4595       include 'COMMON.LOCAL'
4596       include 'COMMON.IOUNITS'
4597       common /calcthet/ term1,term2,termm,diffak,ratak,
4598      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4599      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4600 C Calculate the contributions to both Gaussian lobes.
4601 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4602 C The "polynomial part" of the "standard deviation" of this part of
4603 C the distribution.
4604         sig=polthet(3,it)
4605         do j=2,0,-1
4606           sig=sig*thet_pred_mean+polthet(j,it)
4607         enddo
4608 C Derivative of the "interior part" of the "standard deviation of the"
4609 C gamma-dependent Gaussian lobe in t_c.
4610         sigtc=3*polthet(3,it)
4611         do j=2,1,-1
4612           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4613         enddo
4614         sigtc=sig*sigtc
4615 C Set the parameters of both Gaussian lobes of the distribution.
4616 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4617         fac=sig*sig+sigc0(it)
4618         sigcsq=fac+fac
4619         sigc=1.0D0/sigcsq
4620 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4621         sigsqtc=-4.0D0*sigcsq*sigtc
4622 c       print *,i,sig,sigtc,sigsqtc
4623 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4624         sigtc=-sigtc/(fac*fac)
4625 C Following variable is sigma(t_c)**(-2)
4626         sigcsq=sigcsq*sigcsq
4627         sig0i=sig0(it)
4628         sig0inv=1.0D0/sig0i**2
4629         delthec=thetai-thet_pred_mean
4630         delthe0=thetai-theta0i
4631         term1=-0.5D0*sigcsq*delthec*delthec
4632         term2=-0.5D0*sig0inv*delthe0*delthe0
4633 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4634 C NaNs in taking the logarithm. We extract the largest exponent which is added
4635 C to the energy (this being the log of the distribution) at the end of energy
4636 C term evaluation for this virtual-bond angle.
4637         if (term1.gt.term2) then
4638           termm=term1
4639           term2=dexp(term2-termm)
4640           term1=1.0d0
4641         else
4642           termm=term2
4643           term1=dexp(term1-termm)
4644           term2=1.0d0
4645         endif
4646 C The ratio between the gamma-independent and gamma-dependent lobes of
4647 C the distribution is a Gaussian function of thet_pred_mean too.
4648         diffak=gthet(2,it)-thet_pred_mean
4649         ratak=diffak/gthet(3,it)**2
4650         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4651 C Let's differentiate it in thet_pred_mean NOW.
4652         aktc=ak*ratak
4653 C Now put together the distribution terms to make complete distribution.
4654         termexp=term1+ak*term2
4655         termpre=sigc+ak*sig0i
4656 C Contribution of the bending energy from this theta is just the -log of
4657 C the sum of the contributions from the two lobes and the pre-exponential
4658 C factor. Simple enough, isn't it?
4659         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4660 C NOW the derivatives!!!
4661 C 6/6/97 Take into account the deformation.
4662         E_theta=(delthec*sigcsq*term1
4663      &       +ak*delthe0*sig0inv*term2)/termexp
4664         E_tc=((sigtc+aktc*sig0i)/termpre
4665      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4666      &       aktc*term2)/termexp)
4667       return
4668       end
4669 c-----------------------------------------------------------------------------
4670       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4671       implicit real*8 (a-h,o-z)
4672       include 'DIMENSIONS'
4673       include 'COMMON.LOCAL'
4674       include 'COMMON.IOUNITS'
4675       common /calcthet/ term1,term2,termm,diffak,ratak,
4676      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4677      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4678       delthec=thetai-thet_pred_mean
4679       delthe0=thetai-theta0i
4680 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4681       t3 = thetai-thet_pred_mean
4682       t6 = t3**2
4683       t9 = term1
4684       t12 = t3*sigcsq
4685       t14 = t12+t6*sigsqtc
4686       t16 = 1.0d0
4687       t21 = thetai-theta0i
4688       t23 = t21**2
4689       t26 = term2
4690       t27 = t21*t26
4691       t32 = termexp
4692       t40 = t32**2
4693       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4694      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4695      & *(-t12*t9-ak*sig0inv*t27)
4696       return
4697       end
4698 #else
4699 C--------------------------------------------------------------------------
4700       subroutine ebend(etheta)
4701 C
4702 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4703 C angles gamma and its derivatives in consecutive thetas and gammas.
4704 C ab initio-derived potentials from
4705 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4706 C
4707       implicit real*8 (a-h,o-z)
4708       include 'DIMENSIONS'
4709       include 'COMMON.LOCAL'
4710       include 'COMMON.GEO'
4711       include 'COMMON.INTERACT'
4712       include 'COMMON.DERIV'
4713       include 'COMMON.VAR'
4714       include 'COMMON.CHAIN'
4715       include 'COMMON.IOUNITS'
4716       include 'COMMON.NAMES'
4717       include 'COMMON.FFIELD'
4718       include 'COMMON.CONTROL'
4719       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4720      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4721      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4722      & sinph1ph2(maxdouble,maxdouble)
4723       logical lprn /.false./, lprn1 /.false./
4724       etheta=0.0D0
4725       do i=ithet_start,ithet_end
4726         dethetai=0.0d0
4727         dephii=0.0d0
4728         dephii1=0.0d0
4729         theti2=0.5d0*theta(i)
4730         ityp2=ithetyp(iabs(itype(i-1)))
4731         do k=1,nntheterm
4732           coskt(k)=dcos(k*theti2)
4733           sinkt(k)=dsin(k*theti2)
4734         enddo
4735         if (i.gt.3) then
4736 #ifdef OSF
4737           phii=phi(i)
4738           if (phii.ne.phii) phii=150.0
4739 #else
4740           phii=phi(i)
4741 #endif
4742           ityp1=ithetyp(iabs(itype(i-2)))
4743           do k=1,nsingle
4744             cosph1(k)=dcos(k*phii)
4745             sinph1(k)=dsin(k*phii)
4746           enddo
4747         else
4748           phii=0.0d0
4749           ityp1=nthetyp+1
4750           do k=1,nsingle
4751             cosph1(k)=0.0d0
4752             sinph1(k)=0.0d0
4753           enddo
4754         endif
4755         if (i.lt.nres) then
4756 #ifdef OSF
4757           phii1=phi(i+1)
4758           if (phii1.ne.phii1) phii1=150.0
4759           phii1=pinorm(phii1)
4760 #else
4761           phii1=phi(i+1)
4762 #endif
4763           ityp3=ithetyp(iabs(itype(i)))
4764           do k=1,nsingle
4765             cosph2(k)=dcos(k*phii1)
4766             sinph2(k)=dsin(k*phii1)
4767           enddo
4768         else
4769           phii1=0.0d0
4770           ityp3=nthetyp+1
4771           do k=1,nsingle
4772             cosph2(k)=0.0d0
4773             sinph2(k)=0.0d0
4774           enddo
4775         endif
4776         ethetai=aa0thet(ityp1,ityp2,ityp3)
4777         do k=1,ndouble
4778           do l=1,k-1
4779             ccl=cosph1(l)*cosph2(k-l)
4780             ssl=sinph1(l)*sinph2(k-l)
4781             scl=sinph1(l)*cosph2(k-l)
4782             csl=cosph1(l)*sinph2(k-l)
4783             cosph1ph2(l,k)=ccl-ssl
4784             cosph1ph2(k,l)=ccl+ssl
4785             sinph1ph2(l,k)=scl+csl
4786             sinph1ph2(k,l)=scl-csl
4787           enddo
4788         enddo
4789         if (lprn) then
4790         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4791      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4792         write (iout,*) "coskt and sinkt"
4793         do k=1,nntheterm
4794           write (iout,*) k,coskt(k),sinkt(k)
4795         enddo
4796         endif
4797         do k=1,ntheterm
4798           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4799           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4800      &      *coskt(k)
4801           if (lprn)
4802      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4803      &     " ethetai",ethetai
4804         enddo
4805         if (lprn) then
4806         write (iout,*) "cosph and sinph"
4807         do k=1,nsingle
4808           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4809         enddo
4810         write (iout,*) "cosph1ph2 and sinph2ph2"
4811         do k=2,ndouble
4812           do l=1,k-1
4813             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4814      &         sinph1ph2(l,k),sinph1ph2(k,l)
4815           enddo
4816         enddo
4817         write(iout,*) "ethetai",ethetai
4818         endif
4819         do m=1,ntheterm2
4820           do k=1,nsingle
4821             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4822      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4823      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4824      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4825             ethetai=ethetai+sinkt(m)*aux
4826             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4827             dephii=dephii+k*sinkt(m)*(
4828      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4829      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4830             dephii1=dephii1+k*sinkt(m)*(
4831      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4832      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4833             if (lprn)
4834      &      write (iout,*) "m",m," k",k," bbthet",
4835      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4836      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4837      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4838      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4839           enddo
4840         enddo
4841         if (lprn)
4842      &  write(iout,*) "ethetai",ethetai
4843         do m=1,ntheterm3
4844           do k=2,ndouble
4845             do l=1,k-1
4846               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4847      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4848      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4849      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4850               ethetai=ethetai+sinkt(m)*aux
4851               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4852               dephii=dephii+l*sinkt(m)*(
4853      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4854      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4855      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4856      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4857               dephii1=dephii1+(k-l)*sinkt(m)*(
4858      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4859      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4860      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4861      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4862               if (lprn) then
4863               write (iout,*) "m",m," k",k," l",l," ffthet",
4864      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4865      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4866      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4867      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4868               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4869      &            cosph1ph2(k,l)*sinkt(m),
4870      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4871               endif
4872             enddo
4873           enddo
4874         enddo
4875 10      continue
4876         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4877      &   i,theta(i)*rad2deg,phii*rad2deg,
4878      &   phii1*rad2deg,ethetai
4879         etheta=etheta+ethetai
4880         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4881         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4882         gloc(nphi+i-2,icg)=wang*dethetai
4883       enddo
4884       return
4885       end
4886 #endif
4887 #ifdef CRYST_SC
4888 c-----------------------------------------------------------------------------
4889       subroutine esc(escloc)
4890 C Calculate the local energy of a side chain and its derivatives in the
4891 C corresponding virtual-bond valence angles THETA and the spherical angles
4892 C ALPHA and OMEGA.
4893       implicit real*8 (a-h,o-z)
4894       include 'DIMENSIONS'
4895       include 'COMMON.GEO'
4896       include 'COMMON.LOCAL'
4897       include 'COMMON.VAR'
4898       include 'COMMON.INTERACT'
4899       include 'COMMON.DERIV'
4900       include 'COMMON.CHAIN'
4901       include 'COMMON.IOUNITS'
4902       include 'COMMON.NAMES'
4903       include 'COMMON.FFIELD'
4904       include 'COMMON.CONTROL'
4905       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4906      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4907       common /sccalc/ time11,time12,time112,theti,it,nlobit
4908       delta=0.02d0*pi
4909       escloc=0.0D0
4910 c     write (iout,'(a)') 'ESC'
4911       do i=loc_start,loc_end
4912         it=itype(i)
4913         if (it.eq.10) goto 1
4914         nlobit=nlob(iabs(it))
4915 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4916 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4917         theti=theta(i+1)-pipol
4918         x(1)=dtan(theti)
4919         x(2)=alph(i)
4920         x(3)=omeg(i)
4921
4922         if (x(2).gt.pi-delta) then
4923           xtemp(1)=x(1)
4924           xtemp(2)=pi-delta
4925           xtemp(3)=x(3)
4926           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4927           xtemp(2)=pi
4928           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4929           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4930      &        escloci,dersc(2))
4931           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4932      &        ddersc0(1),dersc(1))
4933           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4934      &        ddersc0(3),dersc(3))
4935           xtemp(2)=pi-delta
4936           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4937           xtemp(2)=pi
4938           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4939           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4940      &            dersc0(2),esclocbi,dersc02)
4941           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4942      &            dersc12,dersc01)
4943           call splinthet(x(2),0.5d0*delta,ss,ssd)
4944           dersc0(1)=dersc01
4945           dersc0(2)=dersc02
4946           dersc0(3)=0.0d0
4947           do k=1,3
4948             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4949           enddo
4950           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4951 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4952 c    &             esclocbi,ss,ssd
4953           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4954 c         escloci=esclocbi
4955 c         write (iout,*) escloci
4956         else if (x(2).lt.delta) then
4957           xtemp(1)=x(1)
4958           xtemp(2)=delta
4959           xtemp(3)=x(3)
4960           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4961           xtemp(2)=0.0d0
4962           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4963           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4964      &        escloci,dersc(2))
4965           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4966      &        ddersc0(1),dersc(1))
4967           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4968      &        ddersc0(3),dersc(3))
4969           xtemp(2)=delta
4970           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4971           xtemp(2)=0.0d0
4972           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4973           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4974      &            dersc0(2),esclocbi,dersc02)
4975           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4976      &            dersc12,dersc01)
4977           dersc0(1)=dersc01
4978           dersc0(2)=dersc02
4979           dersc0(3)=0.0d0
4980           call splinthet(x(2),0.5d0*delta,ss,ssd)
4981           do k=1,3
4982             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4983           enddo
4984           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4985 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4986 c    &             esclocbi,ss,ssd
4987           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4988 c         write (iout,*) escloci
4989         else
4990           call enesc(x,escloci,dersc,ddummy,.false.)
4991         endif
4992
4993         escloc=escloc+escloci
4994         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4995      &     'escloc',i,escloci
4996 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4997
4998         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4999      &   wscloc*dersc(1)
5000         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5001         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5002     1   continue
5003       enddo
5004       return
5005       end
5006 C---------------------------------------------------------------------------
5007       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5008       implicit real*8 (a-h,o-z)
5009       include 'DIMENSIONS'
5010       include 'COMMON.GEO'
5011       include 'COMMON.LOCAL'
5012       include 'COMMON.IOUNITS'
5013       common /sccalc/ time11,time12,time112,theti,it,nlobit
5014       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5015       double precision contr(maxlob,-1:1)
5016       logical mixed
5017 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5018         escloc_i=0.0D0
5019         do j=1,3
5020           dersc(j)=0.0D0
5021           if (mixed) ddersc(j)=0.0d0
5022         enddo
5023         x3=x(3)
5024
5025 C Because of periodicity of the dependence of the SC energy in omega we have
5026 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5027 C To avoid underflows, first compute & store the exponents.
5028
5029         do iii=-1,1
5030
5031           x(3)=x3+iii*dwapi
5032
5033           do j=1,nlobit
5034             do k=1,3
5035               z(k)=x(k)-censc(k,j,it)
5036             enddo
5037             do k=1,3
5038               Axk=0.0D0
5039               do l=1,3
5040                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5041               enddo
5042               Ax(k,j,iii)=Axk
5043             enddo
5044             expfac=0.0D0
5045             do k=1,3
5046               expfac=expfac+Ax(k,j,iii)*z(k)
5047             enddo
5048             contr(j,iii)=expfac
5049           enddo ! j
5050
5051         enddo ! iii
5052
5053         x(3)=x3
5054 C As in the case of ebend, we want to avoid underflows in exponentiation and
5055 C subsequent NaNs and INFs in energy calculation.
5056 C Find the largest exponent
5057         emin=contr(1,-1)
5058         do iii=-1,1
5059           do j=1,nlobit
5060             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5061           enddo
5062         enddo
5063         emin=0.5D0*emin
5064 cd      print *,'it=',it,' emin=',emin
5065
5066 C Compute the contribution to SC energy and derivatives
5067         do iii=-1,1
5068
5069           do j=1,nlobit
5070 #ifdef OSF
5071             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5072             if(adexp.ne.adexp) adexp=1.0
5073             expfac=dexp(adexp)
5074 #else
5075             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5076 #endif
5077 cd          print *,'j=',j,' expfac=',expfac
5078             escloc_i=escloc_i+expfac
5079             do k=1,3
5080               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5081             enddo
5082             if (mixed) then
5083               do k=1,3,2
5084                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5085      &            +gaussc(k,2,j,it))*expfac
5086               enddo
5087             endif
5088           enddo
5089
5090         enddo ! iii
5091
5092         dersc(1)=dersc(1)/cos(theti)**2
5093         ddersc(1)=ddersc(1)/cos(theti)**2
5094         ddersc(3)=ddersc(3)
5095
5096         escloci=-(dlog(escloc_i)-emin)
5097         do j=1,3
5098           dersc(j)=dersc(j)/escloc_i
5099         enddo
5100         if (mixed) then
5101           do j=1,3,2
5102             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5103           enddo
5104         endif
5105       return
5106       end
5107 C------------------------------------------------------------------------------
5108       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5109       implicit real*8 (a-h,o-z)
5110       include 'DIMENSIONS'
5111       include 'COMMON.GEO'
5112       include 'COMMON.LOCAL'
5113       include 'COMMON.IOUNITS'
5114       common /sccalc/ time11,time12,time112,theti,it,nlobit
5115       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5116       double precision contr(maxlob)
5117       logical mixed
5118
5119       escloc_i=0.0D0
5120
5121       do j=1,3
5122         dersc(j)=0.0D0
5123       enddo
5124
5125       do j=1,nlobit
5126         do k=1,2
5127           z(k)=x(k)-censc(k,j,it)
5128         enddo
5129         z(3)=dwapi
5130         do k=1,3
5131           Axk=0.0D0
5132           do l=1,3
5133             Axk=Axk+gaussc(l,k,j,it)*z(l)
5134           enddo
5135           Ax(k,j)=Axk
5136         enddo
5137         expfac=0.0D0
5138         do k=1,3
5139           expfac=expfac+Ax(k,j)*z(k)
5140         enddo
5141         contr(j)=expfac
5142       enddo ! j
5143
5144 C As in the case of ebend, we want to avoid underflows in exponentiation and
5145 C subsequent NaNs and INFs in energy calculation.
5146 C Find the largest exponent
5147       emin=contr(1)
5148       do j=1,nlobit
5149         if (emin.gt.contr(j)) emin=contr(j)
5150       enddo
5151       emin=0.5D0*emin
5152
5153 C Compute the contribution to SC energy and derivatives
5154
5155       dersc12=0.0d0
5156       do j=1,nlobit
5157         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5158         escloc_i=escloc_i+expfac
5159         do k=1,2
5160           dersc(k)=dersc(k)+Ax(k,j)*expfac
5161         enddo
5162         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5163      &            +gaussc(1,2,j,it))*expfac
5164         dersc(3)=0.0d0
5165       enddo
5166
5167       dersc(1)=dersc(1)/cos(theti)**2
5168       dersc12=dersc12/cos(theti)**2
5169       escloci=-(dlog(escloc_i)-emin)
5170       do j=1,2
5171         dersc(j)=dersc(j)/escloc_i
5172       enddo
5173       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5174       return
5175       end
5176 #else
5177 c----------------------------------------------------------------------------------
5178       subroutine esc(escloc)
5179 C Calculate the local energy of a side chain and its derivatives in the
5180 C corresponding virtual-bond valence angles THETA and the spherical angles
5181 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5182 C added by Urszula Kozlowska. 07/11/2007
5183 C
5184       implicit real*8 (a-h,o-z)
5185       include 'DIMENSIONS'
5186       include 'COMMON.GEO'
5187       include 'COMMON.LOCAL'
5188       include 'COMMON.VAR'
5189       include 'COMMON.SCROT'
5190       include 'COMMON.INTERACT'
5191       include 'COMMON.DERIV'
5192       include 'COMMON.CHAIN'
5193       include 'COMMON.IOUNITS'
5194       include 'COMMON.NAMES'
5195       include 'COMMON.FFIELD'
5196       include 'COMMON.CONTROL'
5197       include 'COMMON.VECTORS'
5198       double precision x_prime(3),y_prime(3),z_prime(3)
5199      &    , sumene,dsc_i,dp2_i,x(65),
5200      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5201      &    de_dxx,de_dyy,de_dzz,de_dt
5202       double precision s1_t,s1_6_t,s2_t,s2_6_t
5203       double precision
5204      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5205      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5206      & dt_dCi(3),dt_dCi1(3)
5207       common /sccalc/ time11,time12,time112,theti,it,nlobit
5208       delta=0.02d0*pi
5209       escloc=0.0D0
5210       do i=loc_start,loc_end
5211         costtab(i+1) =dcos(theta(i+1))
5212         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5213         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5214         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5215         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5216         cosfac=dsqrt(cosfac2)
5217         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5218         sinfac=dsqrt(sinfac2)
5219         it=itype(i)
5220         if (it.eq.10) goto 1
5221 c
5222 C  Compute the axes of tghe local cartesian coordinates system; store in
5223 c   x_prime, y_prime and z_prime
5224 c
5225         do j=1,3
5226           x_prime(j) = 0.00
5227           y_prime(j) = 0.00
5228           z_prime(j) = 0.00
5229         enddo
5230 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5231 C     &   dc_norm(3,i+nres)
5232         do j = 1,3
5233           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5234           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5235         enddo
5236         do j = 1,3
5237           z_prime(j) = -uz(j,i-1)
5238         enddo
5239 c       write (2,*) "i",i
5240 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5241 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5242 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5243 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5244 c      & " xy",scalar(x_prime(1),y_prime(1)),
5245 c      & " xz",scalar(x_prime(1),z_prime(1)),
5246 c      & " yy",scalar(y_prime(1),y_prime(1)),
5247 c      & " yz",scalar(y_prime(1),z_prime(1)),
5248 c      & " zz",scalar(z_prime(1),z_prime(1))
5249 c
5250 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5251 C to local coordinate system. Store in xx, yy, zz.
5252 c
5253         xx=0.0d0
5254         yy=0.0d0
5255         zz=0.0d0
5256         do j = 1,3
5257           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5258           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5259           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5260         enddo
5261
5262         xxtab(i)=xx
5263         yytab(i)=yy
5264         zztab(i)=zz
5265 C
5266 C Compute the energy of the ith side cbain
5267 C
5268 c        write (2,*) "xx",xx," yy",yy," zz",zz
5269         it=itype(i)
5270         do j = 1,65
5271           x(j) = sc_parmin(j,it)
5272         enddo
5273 #ifdef CHECK_COORD
5274 Cc diagnostics - remove later
5275         xx1 = dcos(alph(2))
5276         yy1 = dsin(alph(2))*dcos(omeg(2))
5277         zz1 = -dsin(alph(2))*dsin(omeg(2))
5278         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5279      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5280      &    xx1,yy1,zz1
5281 C,"  --- ", xx_w,yy_w,zz_w
5282 c end diagnostics
5283 #endif
5284         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5285      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5286      &   + x(10)*yy*zz
5287         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5288      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5289      & + x(20)*yy*zz
5290         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5291      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5292      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5293      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5294      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5295      &  +x(40)*xx*yy*zz
5296         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5297      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5298      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5299      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5300      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5301      &  +x(60)*xx*yy*zz
5302         dsc_i   = 0.743d0+x(61)
5303         dp2_i   = 1.9d0+x(62)
5304         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5305      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5306         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5307      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5308         s1=(1+x(63))/(0.1d0 + dscp1)
5309         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5310         s2=(1+x(65))/(0.1d0 + dscp2)
5311         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5312         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5313      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5314 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5315 c     &   sumene4,
5316 c     &   dscp1,dscp2,sumene
5317 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5318         escloc = escloc + sumene
5319 c        write (2,*) "i",i," escloc",sumene,escloc
5320 #ifdef DEBUG
5321 C
5322 C This section to check the numerical derivatives of the energy of ith side
5323 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5324 C #define DEBUG in the code to turn it on.
5325 C
5326         write (2,*) "sumene               =",sumene
5327         aincr=1.0d-7
5328         xxsave=xx
5329         xx=xx+aincr
5330         write (2,*) xx,yy,zz
5331         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5332         de_dxx_num=(sumenep-sumene)/aincr
5333         xx=xxsave
5334         write (2,*) "xx+ sumene from enesc=",sumenep
5335         yysave=yy
5336         yy=yy+aincr
5337         write (2,*) xx,yy,zz
5338         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5339         de_dyy_num=(sumenep-sumene)/aincr
5340         yy=yysave
5341         write (2,*) "yy+ sumene from enesc=",sumenep
5342         zzsave=zz
5343         zz=zz+aincr
5344         write (2,*) xx,yy,zz
5345         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5346         de_dzz_num=(sumenep-sumene)/aincr
5347         zz=zzsave
5348         write (2,*) "zz+ sumene from enesc=",sumenep
5349         costsave=cost2tab(i+1)
5350         sintsave=sint2tab(i+1)
5351         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5352         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5353         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5354         de_dt_num=(sumenep-sumene)/aincr
5355         write (2,*) " t+ sumene from enesc=",sumenep
5356         cost2tab(i+1)=costsave
5357         sint2tab(i+1)=sintsave
5358 C End of diagnostics section.
5359 #endif
5360 C
5361 C Compute the gradient of esc
5362 C
5363         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5364         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5365         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5366         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5367         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5368         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5369         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5370         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5371         pom1=(sumene3*sint2tab(i+1)+sumene1)
5372      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5373         pom2=(sumene4*cost2tab(i+1)+sumene2)
5374      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5375         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5376         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5377      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5378      &  +x(40)*yy*zz
5379         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5380         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5381      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5382      &  +x(60)*yy*zz
5383         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5384      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5385      &        +(pom1+pom2)*pom_dx
5386 #ifdef DEBUG
5387         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5388 #endif
5389 C
5390         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5391         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5392      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5393      &  +x(40)*xx*zz
5394         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5395         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5396      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5397      &  +x(59)*zz**2 +x(60)*xx*zz
5398         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5399      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5400      &        +(pom1-pom2)*pom_dy
5401 #ifdef DEBUG
5402         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5403 #endif
5404 C
5405         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5406      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5407      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5408      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5409      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5410      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5411      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5412      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5413 #ifdef DEBUG
5414         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5415 #endif
5416 C
5417         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5418      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5419      &  +pom1*pom_dt1+pom2*pom_dt2
5420 #ifdef DEBUG
5421         write(2,*), "de_dt = ", de_dt,de_dt_num
5422 #endif
5423 c
5424 C
5425        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5426        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5427        cosfac2xx=cosfac2*xx
5428        sinfac2yy=sinfac2*yy
5429        do k = 1,3
5430          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5431      &      vbld_inv(i+1)
5432          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5433      &      vbld_inv(i)
5434          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5435          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5436 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5437 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5438 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5439 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5440          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5441          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5442          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5443          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5444          dZZ_Ci1(k)=0.0d0
5445          dZZ_Ci(k)=0.0d0
5446          do j=1,3
5447            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5448            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5449          enddo
5450
5451          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5452          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5453          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5454 c
5455          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5456          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5457        enddo
5458
5459        do k=1,3
5460          dXX_Ctab(k,i)=dXX_Ci(k)
5461          dXX_C1tab(k,i)=dXX_Ci1(k)
5462          dYY_Ctab(k,i)=dYY_Ci(k)
5463          dYY_C1tab(k,i)=dYY_Ci1(k)
5464          dZZ_Ctab(k,i)=dZZ_Ci(k)
5465          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5466          dXX_XYZtab(k,i)=dXX_XYZ(k)
5467          dYY_XYZtab(k,i)=dYY_XYZ(k)
5468          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5469        enddo
5470
5471        do k = 1,3
5472 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5473 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5474 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5475 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5476 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5477 c     &    dt_dci(k)
5478 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5479 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5480          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5481      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5482          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5483      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5484          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5485      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5486        enddo
5487 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5488 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5489
5490 C to check gradient call subroutine check_grad
5491
5492     1 continue
5493       enddo
5494       return
5495       end
5496 c------------------------------------------------------------------------------
5497       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5498       implicit none
5499       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5500      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5501       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5502      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5503      &   + x(10)*yy*zz
5504       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5505      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5506      & + x(20)*yy*zz
5507       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5508      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5509      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5510      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5511      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5512      &  +x(40)*xx*yy*zz
5513       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5514      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5515      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5516      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5517      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5518      &  +x(60)*xx*yy*zz
5519       dsc_i   = 0.743d0+x(61)
5520       dp2_i   = 1.9d0+x(62)
5521       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5522      &          *(xx*cost2+yy*sint2))
5523       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5524      &          *(xx*cost2-yy*sint2))
5525       s1=(1+x(63))/(0.1d0 + dscp1)
5526       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5527       s2=(1+x(65))/(0.1d0 + dscp2)
5528       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5529       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5530      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5531       enesc=sumene
5532       return
5533       end
5534 #endif
5535 c------------------------------------------------------------------------------
5536       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5537 C
5538 C This procedure calculates two-body contact function g(rij) and its derivative:
5539 C
5540 C           eps0ij                                     !       x < -1
5541 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5542 C            0                                         !       x > 1
5543 C
5544 C where x=(rij-r0ij)/delta
5545 C
5546 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5547 C
5548       implicit none
5549       double precision rij,r0ij,eps0ij,fcont,fprimcont
5550       double precision x,x2,x4,delta
5551 c     delta=0.02D0*r0ij
5552 c      delta=0.2D0*r0ij
5553       x=(rij-r0ij)/delta
5554       if (x.lt.-1.0D0) then
5555         fcont=eps0ij
5556         fprimcont=0.0D0
5557       else if (x.le.1.0D0) then
5558         x2=x*x
5559         x4=x2*x2
5560         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5561         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5562       else
5563         fcont=0.0D0
5564         fprimcont=0.0D0
5565       endif
5566       return
5567       end
5568 c------------------------------------------------------------------------------
5569       subroutine splinthet(theti,delta,ss,ssder)
5570       implicit real*8 (a-h,o-z)
5571       include 'DIMENSIONS'
5572       include 'COMMON.VAR'
5573       include 'COMMON.GEO'
5574       thetup=pi-delta
5575       thetlow=delta
5576       if (theti.gt.pipol) then
5577         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5578       else
5579         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5580         ssder=-ssder
5581       endif
5582       return
5583       end
5584 c------------------------------------------------------------------------------
5585       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5586       implicit none
5587       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5588       double precision ksi,ksi2,ksi3,a1,a2,a3
5589       a1=fprim0*delta/(f1-f0)
5590       a2=3.0d0-2.0d0*a1
5591       a3=a1-2.0d0
5592       ksi=(x-x0)/delta
5593       ksi2=ksi*ksi
5594       ksi3=ksi2*ksi
5595       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5596       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5597       return
5598       end
5599 c------------------------------------------------------------------------------
5600       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5601       implicit none
5602       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5603       double precision ksi,ksi2,ksi3,a1,a2,a3
5604       ksi=(x-x0)/delta
5605       ksi2=ksi*ksi
5606       ksi3=ksi2*ksi
5607       a1=fprim0x*delta
5608       a2=3*(f1x-f0x)-2*fprim0x*delta
5609       a3=fprim0x*delta-2*(f1x-f0x)
5610       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5611       return
5612       end
5613 C-----------------------------------------------------------------------------
5614 #ifdef CRYST_TOR
5615 C-----------------------------------------------------------------------------
5616       subroutine etor(etors,edihcnstr)
5617       implicit real*8 (a-h,o-z)
5618       include 'DIMENSIONS'
5619       include 'COMMON.VAR'
5620       include 'COMMON.GEO'
5621       include 'COMMON.LOCAL'
5622       include 'COMMON.TORSION'
5623       include 'COMMON.INTERACT'
5624       include 'COMMON.DERIV'
5625       include 'COMMON.CHAIN'
5626       include 'COMMON.NAMES'
5627       include 'COMMON.IOUNITS'
5628       include 'COMMON.FFIELD'
5629       include 'COMMON.TORCNSTR'
5630       include 'COMMON.CONTROL'
5631       logical lprn
5632 C Set lprn=.true. for debugging
5633       lprn=.false.
5634 c      lprn=.true.
5635       etors=0.0D0
5636       do i=iphi_start,iphi_end
5637       etors_ii=0.0D0
5638         itori=itortyp(itype(i-2))
5639         itori1=itortyp(itype(i-1))
5640         if (iabs(itype(i)).eq.20) then
5641         iblock=2
5642         else
5643         iblock=1
5644         endif
5645         phii=phi(i)
5646         gloci=0.0D0
5647 C Proline-Proline pair is a special case...
5648         if (itori.eq.3 .and. itori1.eq.3) then
5649           if (phii.gt.-dwapi3) then
5650             cosphi=dcos(3*phii)
5651             fac=1.0D0/(1.0D0-cosphi)
5652             etorsi=v1(1,3,3)*fac
5653             etorsi=etorsi+etorsi
5654             etors=etors+etorsi-v1(1,3,3)
5655             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5656             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5657           endif
5658           do j=1,3
5659             v1ij=v1(j+1,itori,itori1)
5660             v2ij=v2(j+1,itori,itori1)
5661             cosphi=dcos(j*phii)
5662             sinphi=dsin(j*phii)
5663             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5664             if (energy_dec) etors_ii=etors_ii+
5665      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5666             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5667           enddo
5668         else
5669           do j=1,nterm_old
5670             v1ij=v1(j,itori,itori1)
5671             v2ij=v2(j,itori,itori1)
5672             cosphi=dcos(j*phii)
5673             sinphi=dsin(j*phii)
5674             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5675             if (energy_dec) etors_ii=etors_ii+
5676      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5677             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5678           enddo
5679         endif
5680         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5681      &        'etor',i,etors_ii
5682         if (lprn)
5683      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5684      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5685      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5686         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5687 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5688       enddo
5689 ! 6/20/98 - dihedral angle constraints
5690       edihcnstr=0.0d0
5691       do i=1,ndih_constr
5692         itori=idih_constr(i)
5693         phii=phi(itori)
5694         difi=phii-phi0(i)
5695         if (difi.gt.drange(i)) then
5696           difi=difi-drange(i)
5697           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5698           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5699         else if (difi.lt.-drange(i)) then
5700           difi=difi+drange(i)
5701           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5702           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5703         endif
5704 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5705 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5706       enddo
5707 !      write (iout,*) 'edihcnstr',edihcnstr
5708       return
5709       end
5710 c------------------------------------------------------------------------------
5711       subroutine etor_d(etors_d)
5712       etors_d=0.0d0
5713       return
5714       end
5715 c----------------------------------------------------------------------------
5716 #else
5717       subroutine etor(etors,edihcnstr)
5718       implicit real*8 (a-h,o-z)
5719       include 'DIMENSIONS'
5720       include 'COMMON.VAR'
5721       include 'COMMON.GEO'
5722       include 'COMMON.LOCAL'
5723       include 'COMMON.TORSION'
5724       include 'COMMON.INTERACT'
5725       include 'COMMON.DERIV'
5726       include 'COMMON.CHAIN'
5727       include 'COMMON.NAMES'
5728       include 'COMMON.IOUNITS'
5729       include 'COMMON.FFIELD'
5730       include 'COMMON.TORCNSTR'
5731       include 'COMMON.CONTROL'
5732       logical lprn
5733 C Set lprn=.true. for debugging
5734       lprn=.false.
5735 c     lprn=.true.
5736       etors=0.0D0
5737       do i=iphi_start,iphi_end
5738       etors_ii=0.0D0
5739         itori=itortyp(itype(i-2))
5740         itori1=itortyp(itype(i-1))
5741         phii=phi(i)
5742         gloci=0.0D0
5743 C Regular cosine and sine terms
5744         do j=1,nterm(itori,itori1,iblock)
5745           v1ij=v1(j,itori,itori1,iblock)
5746           v2ij=v2(j,itori,itori1,iblock)
5747           cosphi=dcos(j*phii)
5748           sinphi=dsin(j*phii)
5749           etors=etors+v1ij*cosphi+v2ij*sinphi
5750           if (energy_dec) etors_ii=etors_ii+
5751      &                v1ij*cosphi+v2ij*sinphi
5752           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5753         enddo
5754 C Lorentz terms
5755 C                         v1
5756 C  E = SUM ----------------------------------- - v1
5757 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5758 C
5759         cosphi=dcos(0.5d0*phii)
5760         sinphi=dsin(0.5d0*phii)
5761         do j=1,nlor(itori,itori1,iblock)
5762           vl1ij=vlor1(j,itori,itori1)
5763           vl2ij=vlor2(j,itori,itori1)
5764           vl3ij=vlor3(j,itori,itori1)
5765           pom=vl2ij*cosphi+vl3ij*sinphi
5766           pom1=1.0d0/(pom*pom+1.0d0)
5767           etors=etors+vl1ij*pom1
5768           if (energy_dec) etors_ii=etors_ii+
5769      &                vl1ij*pom1
5770           pom=-pom*pom1*pom1
5771           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5772         enddo
5773 C Subtract the constant term
5774         etors=etors-v0(itori,itori1,iblock)
5775           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5776      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5777         if (lprn)
5778      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5779      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5780      &  (v1(j,itori,itori1,iblock),j=1,6),
5781      &  (v2(j,itori,itori1,iblock),j=1,6)
5782         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5783 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5784       enddo
5785 ! 6/20/98 - dihedral angle constraints
5786       edihcnstr=0.0d0
5787 c      do i=1,ndih_constr
5788       do i=idihconstr_start,idihconstr_end
5789         itori=idih_constr(i)
5790         phii=phi(itori)
5791         difi=pinorm(phii-phi0(i))
5792         if (difi.gt.drange(i)) then
5793           difi=difi-drange(i)
5794           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5795           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5796         else if (difi.lt.-drange(i)) then
5797           difi=difi+drange(i)
5798           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5799           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5800         else
5801           difi=0.0
5802         endif
5803 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5804 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5805 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5806       enddo
5807 cd       write (iout,*) 'edihcnstr',edihcnstr
5808       return
5809       end
5810 c----------------------------------------------------------------------------
5811       subroutine etor_d(etors_d)
5812 C 6/23/01 Compute double torsional energy
5813       implicit real*8 (a-h,o-z)
5814       include 'DIMENSIONS'
5815       include 'COMMON.VAR'
5816       include 'COMMON.GEO'
5817       include 'COMMON.LOCAL'
5818       include 'COMMON.TORSION'
5819       include 'COMMON.INTERACT'
5820       include 'COMMON.DERIV'
5821       include 'COMMON.CHAIN'
5822       include 'COMMON.NAMES'
5823       include 'COMMON.IOUNITS'
5824       include 'COMMON.FFIELD'
5825       include 'COMMON.TORCNSTR'
5826       logical lprn
5827 C Set lprn=.true. for debugging
5828       lprn=.false.
5829 c     lprn=.true.
5830       etors_d=0.0D0
5831       do i=iphid_start,iphid_end
5832         itori=itortyp(itype(i-2))
5833         itori1=itortyp(itype(i-1))
5834         itori2=itortyp(itype(i))
5835         iblock=1
5836         if (iabs(itype(i+1)).eq.20) iblock=2
5837         phii=phi(i)
5838         phii1=phi(i+1)
5839         gloci1=0.0D0
5840         gloci2=0.0D0
5841 C Regular cosine and sine terms
5842         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5843           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5844           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5845           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5846           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5847           cosphi1=dcos(j*phii)
5848           sinphi1=dsin(j*phii)
5849           cosphi2=dcos(j*phii1)
5850           sinphi2=dsin(j*phii1)
5851           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5852      &     v2cij*cosphi2+v2sij*sinphi2
5853           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5854           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5855         enddo
5856         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5857           do l=1,k-1
5858             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5859             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5860             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5861             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5862             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5863             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5864             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5865             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5866             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5867      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5868             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5869      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5870             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5871      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5872           enddo
5873         enddo
5874         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5875         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5876       enddo
5877       return
5878       end
5879 #endif
5880 c------------------------------------------------------------------------------
5881       subroutine eback_sc_corr(esccor)
5882 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5883 c        conformational states; temporarily implemented as differences
5884 c        between UNRES torsional potentials (dependent on three types of
5885 c        residues) and the torsional potentials dependent on all 20 types
5886 c        of residues computed from AM1  energy surfaces of terminally-blocked
5887 c        amino-acid residues.
5888       implicit real*8 (a-h,o-z)
5889       include 'DIMENSIONS'
5890       include 'COMMON.VAR'
5891       include 'COMMON.GEO'
5892       include 'COMMON.LOCAL'
5893       include 'COMMON.TORSION'
5894       include 'COMMON.SCCOR'
5895       include 'COMMON.INTERACT'
5896       include 'COMMON.DERIV'
5897       include 'COMMON.CHAIN'
5898       include 'COMMON.NAMES'
5899       include 'COMMON.IOUNITS'
5900       include 'COMMON.FFIELD'
5901       include 'COMMON.CONTROL'
5902       logical lprn
5903 C Set lprn=.true. for debugging
5904       lprn=.false.
5905 c      lprn=.true.
5906 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5907       esccor=0.0D0
5908       do i=iphi_start,iphi_end
5909         esccor_ii=0.0D0
5910         itori=itype(i-2)
5911         itori1=itype(i-1)
5912         phii=phi(i)
5913         gloci=0.0D0
5914         do j=1,nterm_sccor
5915           v1ij=v1sccor(j,itori,itori1)
5916           v2ij=v2sccor(j,itori,itori1)
5917           cosphi=dcos(j*phii)
5918           sinphi=dsin(j*phii)
5919           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5920           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5921         enddo
5922         if (lprn)
5923      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5924      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5925      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5926         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5927       enddo
5928       return
5929       end
5930 c----------------------------------------------------------------------------
5931       subroutine multibody(ecorr)
5932 C This subroutine calculates multi-body contributions to energy following
5933 C the idea of Skolnick et al. If side chains I and J make a contact and
5934 C at the same time side chains I+1 and J+1 make a contact, an extra
5935 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5936       implicit real*8 (a-h,o-z)
5937       include 'DIMENSIONS'
5938       include 'COMMON.IOUNITS'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.INTERACT'
5941       include 'COMMON.CONTACTS'
5942 #ifdef MOMENT
5943       include 'COMMON.CONTACTS.MOMENT'
5944 #endif
5945       double precision gx(3),gx1(3)
5946       logical lprn
5947
5948 C Set lprn=.true. for debugging
5949       lprn=.false.
5950
5951       if (lprn) then
5952         write (iout,'(a)') 'Contact function values:'
5953         do i=nnt,nct-2
5954           write (iout,'(i2,20(1x,i2,f10.5))')
5955      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5956         enddo
5957       endif
5958       ecorr=0.0D0
5959       do i=nnt,nct
5960         do j=1,3
5961           gradcorr(j,i)=0.0D0
5962           gradxorr(j,i)=0.0D0
5963         enddo
5964       enddo
5965       do i=nnt,nct-2
5966
5967         DO ISHIFT = 3,4
5968
5969         i1=i+ishift
5970         num_conti=num_cont(i)
5971         num_conti1=num_cont(i1)
5972         do jj=1,num_conti
5973           j=jcont(jj,i)
5974           do kk=1,num_conti1
5975             j1=jcont(kk,i1)
5976             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5977 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5978 cd   &                   ' ishift=',ishift
5979 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5980 C The system gains extra energy.
5981               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5982             endif   ! j1==j+-ishift
5983           enddo     ! kk
5984         enddo       ! jj
5985
5986         ENDDO ! ISHIFT
5987
5988       enddo         ! i
5989       return
5990       end
5991 c------------------------------------------------------------------------------
5992       double precision function esccorr(i,j,k,l,jj,kk)
5993       implicit real*8 (a-h,o-z)
5994       include 'DIMENSIONS'
5995       include 'COMMON.IOUNITS'
5996       include 'COMMON.DERIV'
5997       include 'COMMON.INTERACT'
5998       include 'COMMON.CONTACTS'
5999 #ifdef MOMENT
6000       include 'COMMON.CONTACTS.MOMENT'
6001 #endif
6002       double precision gx(3),gx1(3)
6003       logical lprn
6004       lprn=.false.
6005       eij=facont(jj,i)
6006       ekl=facont(kk,k)
6007 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6008 C Calculate the multi-body contribution to energy.
6009 C Calculate multi-body contributions to the gradient.
6010 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6011 cd   & k,l,(gacont(m,kk,k),m=1,3)
6012       do m=1,3
6013         gx(m) =ekl*gacont(m,jj,i)
6014         gx1(m)=eij*gacont(m,kk,k)
6015         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6016         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6017         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6018         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6019       enddo
6020       do m=i,j-1
6021         do ll=1,3
6022           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6023         enddo
6024       enddo
6025       do m=k,l-1
6026         do ll=1,3
6027           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6028         enddo
6029       enddo
6030       esccorr=-eij*ekl
6031       return
6032       end
6033 c------------------------------------------------------------------------------
6034       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6035 C This subroutine calculates multi-body contributions to hydrogen-bonding
6036       implicit real*8 (a-h,o-z)
6037       include 'DIMENSIONS'
6038       include 'COMMON.IOUNITS'
6039 #ifdef MPI
6040       include "mpif.h"
6041       parameter (max_cont=maxconts)
6042       parameter (max_dim=26)
6043       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6044       double precision zapas(max_dim,maxconts,max_fg_procs),
6045      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6046       common /przechowalnia/ zapas
6047       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6048      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6049 #endif
6050       include 'COMMON.SETUP'
6051       include 'COMMON.FFIELD'
6052       include 'COMMON.DERIV'
6053       include 'COMMON.INTERACT'
6054       include 'COMMON.CONTACTS'
6055 #ifdef MOMENT
6056       include 'COMMON.CONTACTS.MOMENT'
6057 #endif
6058       include 'COMMON.CONTROL'
6059       include 'COMMON.LOCAL'
6060       double precision gx(3),gx1(3),time00
6061       logical lprn,ldone
6062
6063 C Set lprn=.true. for debugging
6064       lprn=.false.
6065 #ifdef MPI
6066       n_corr=0
6067       n_corr1=0
6068       if (nfgtasks.le.1) goto 30
6069       if (lprn) then
6070         write (iout,'(a)') 'Contact function values before RECEIVE:'
6071         do i=nnt,nct-2
6072           write (iout,'(2i3,50(1x,i2,f5.2))')
6073      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6074      &    j=1,num_cont_hb(i))
6075         enddo
6076       endif
6077       call flush(iout)
6078       do i=1,ntask_cont_from
6079         ncont_recv(i)=0
6080       enddo
6081       do i=1,ntask_cont_to
6082         ncont_sent(i)=0
6083       enddo
6084 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6085 c     & ntask_cont_to
6086 C Make the list of contacts to send to send to other procesors
6087 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6088 c      call flush(iout)
6089       do i=iturn3_start,iturn3_end
6090 c        write (iout,*) "make contact list turn3",i," num_cont",
6091 c     &    num_cont_hb(i)
6092         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6093       enddo
6094       do i=iturn4_start,iturn4_end
6095 c        write (iout,*) "make contact list turn4",i," num_cont",
6096 c     &   num_cont_hb(i)
6097         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6098       enddo
6099       do ii=1,nat_sent
6100         i=iat_sent(ii)
6101 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6102 c     &    num_cont_hb(i)
6103         do j=1,num_cont_hb(i)
6104         do k=1,4
6105           jjc=jcont_hb(j,i)
6106           iproc=iint_sent_local(k,jjc,ii)
6107 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6108           if (iproc.gt.0) then
6109             ncont_sent(iproc)=ncont_sent(iproc)+1
6110             nn=ncont_sent(iproc)
6111             zapas(1,nn,iproc)=i
6112             zapas(2,nn,iproc)=jjc
6113             zapas(3,nn,iproc)=facont_hb(j,i)
6114             zapas(4,nn,iproc)=ees0p(j,i)
6115             zapas(5,nn,iproc)=ees0m(j,i)
6116             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6117             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6118             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6119             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6120             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6121             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6122             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6123             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6124             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6125             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6126             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6127             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6128             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6129             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6130             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6131             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6132             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6133             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6134             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6135             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6136             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6137           endif
6138         enddo
6139         enddo
6140       enddo
6141       if (lprn) then
6142       write (iout,*)
6143      &  "Numbers of contacts to be sent to other processors",
6144      &  (ncont_sent(i),i=1,ntask_cont_to)
6145       write (iout,*) "Contacts sent"
6146       do ii=1,ntask_cont_to
6147         nn=ncont_sent(ii)
6148         iproc=itask_cont_to(ii)
6149         write (iout,*) nn," contacts to processor",iproc,
6150      &   " of CONT_TO_COMM group"
6151         do i=1,nn
6152           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6153         enddo
6154       enddo
6155       call flush(iout)
6156       endif
6157       CorrelType=477
6158       CorrelID=fg_rank+1
6159       CorrelType1=478
6160       CorrelID1=nfgtasks+fg_rank+1
6161       ireq=0
6162 C Receive the numbers of needed contacts from other processors
6163       do ii=1,ntask_cont_from
6164         iproc=itask_cont_from(ii)
6165         ireq=ireq+1
6166         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6167      &    FG_COMM,req(ireq),IERR)
6168       enddo
6169 c      write (iout,*) "IRECV ended"
6170 c      call flush(iout)
6171 C Send the number of contacts needed by other processors
6172       do ii=1,ntask_cont_to
6173         iproc=itask_cont_to(ii)
6174         ireq=ireq+1
6175         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6176      &    FG_COMM,req(ireq),IERR)
6177       enddo
6178 c      write (iout,*) "ISEND ended"
6179 c      write (iout,*) "number of requests (nn)",ireq
6180       call flush(iout)
6181       if (ireq.gt.0)
6182      &  call MPI_Waitall(ireq,req,status_array,ierr)
6183 c      write (iout,*)
6184 c     &  "Numbers of contacts to be received from other processors",
6185 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6186 c      call flush(iout)
6187 C Receive contacts
6188       ireq=0
6189       do ii=1,ntask_cont_from
6190         iproc=itask_cont_from(ii)
6191         nn=ncont_recv(ii)
6192 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6193 c     &   " of CONT_TO_COMM group"
6194         call flush(iout)
6195         if (nn.gt.0) then
6196           ireq=ireq+1
6197           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6198      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6199 c          write (iout,*) "ireq,req",ireq,req(ireq)
6200         endif
6201       enddo
6202 C Send the contacts to processors that need them
6203       do ii=1,ntask_cont_to
6204         iproc=itask_cont_to(ii)
6205         nn=ncont_sent(ii)
6206 c        write (iout,*) nn," contacts to processor",iproc,
6207 c     &   " of CONT_TO_COMM group"
6208         if (nn.gt.0) then
6209           ireq=ireq+1
6210           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6211      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6212 c          write (iout,*) "ireq,req",ireq,req(ireq)
6213 c          do i=1,nn
6214 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6215 c          enddo
6216         endif
6217       enddo
6218 c      write (iout,*) "number of requests (contacts)",ireq
6219 c      write (iout,*) "req",(req(i),i=1,4)
6220 c      call flush(iout)
6221       if (ireq.gt.0)
6222      & call MPI_Waitall(ireq,req,status_array,ierr)
6223       do iii=1,ntask_cont_from
6224         iproc=itask_cont_from(iii)
6225         nn=ncont_recv(iii)
6226         if (lprn) then
6227         write (iout,*) "Received",nn," contacts from processor",iproc,
6228      &   " of CONT_FROM_COMM group"
6229         call flush(iout)
6230         do i=1,nn
6231           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6232         enddo
6233         call flush(iout)
6234         endif
6235         do i=1,nn
6236           ii=zapas_recv(1,i,iii)
6237 c Flag the received contacts to prevent double-counting
6238           jj=-zapas_recv(2,i,iii)
6239 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6240 c          call flush(iout)
6241           nnn=num_cont_hb(ii)+1
6242           num_cont_hb(ii)=nnn
6243           jcont_hb(nnn,ii)=jj
6244           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6245           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6246           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6247           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6248           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6249           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6250           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6251           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6252           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6253           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6254           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6255           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6256           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6257           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6258           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6259           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6260           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6261           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6262           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6263           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6264           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6265           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6266           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6267           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6268         enddo
6269       enddo
6270       call flush(iout)
6271       if (lprn) then
6272         write (iout,'(a)') 'Contact function values after receive:'
6273         do i=nnt,nct-2
6274           write (iout,'(2i3,50(1x,i3,f5.2))')
6275      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6276      &    j=1,num_cont_hb(i))
6277         enddo
6278         call flush(iout)
6279       endif
6280    30 continue
6281 #endif
6282       if (lprn) then
6283         write (iout,'(a)') 'Contact function values:'
6284         do i=nnt,nct-2
6285           write (iout,'(2i3,50(1x,i3,f5.2))')
6286      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6287      &    j=1,num_cont_hb(i))
6288         enddo
6289       endif
6290       ecorr=0.0D0
6291 C Remove the loop below after debugging !!!
6292       do i=nnt,nct
6293         do j=1,3
6294           gradcorr(j,i)=0.0D0
6295           gradxorr(j,i)=0.0D0
6296         enddo
6297       enddo
6298 C Calculate the local-electrostatic correlation terms
6299       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6300         i1=i+1
6301         num_conti=num_cont_hb(i)
6302         num_conti1=num_cont_hb(i+1)
6303         do jj=1,num_conti
6304           j=jcont_hb(jj,i)
6305           jp=iabs(j)
6306           do kk=1,num_conti1
6307             j1=jcont_hb(kk,i1)
6308             jp1=iabs(j1)
6309 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6310 c     &         ' jj=',jj,' kk=',kk
6311             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6312      &          .or. j.lt.0 .and. j1.gt.0) .and.
6313      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6314 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6315 C The system gains extra energy.
6316               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6317               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6318      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6319               n_corr=n_corr+1
6320             else if (j1.eq.j) then
6321 C Contacts I-J and I-(J+1) occur simultaneously.
6322 C The system loses extra energy.
6323 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6324             endif
6325           enddo ! kk
6326           do kk=1,num_conti
6327             j1=jcont_hb(kk,i)
6328 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6329 c    &         ' jj=',jj,' kk=',kk
6330             if (j1.eq.j+1) then
6331 C Contacts I-J and (I+1)-J occur simultaneously.
6332 C The system loses extra energy.
6333 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6334             endif ! j1==j+1
6335           enddo ! kk
6336         enddo ! jj
6337       enddo ! i
6338       return
6339       end
6340 c------------------------------------------------------------------------------
6341       subroutine add_hb_contact(ii,jj,itask)
6342       implicit real*8 (a-h,o-z)
6343       include "DIMENSIONS"
6344       include "COMMON.IOUNITS"
6345       integer max_cont
6346       integer max_dim
6347       parameter (max_cont=maxconts)
6348       parameter (max_dim=26)
6349       include "COMMON.CONTACTS"
6350 #ifdef MOMENT
6351       include 'COMMON.CONTACTS.MOMENT'
6352 #endif
6353       double precision zapas(max_dim,maxconts,max_fg_procs),
6354      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6355       common /przechowalnia/ zapas
6356       integer i,j,ii,jj,iproc,itask(4),nn
6357 c      write (iout,*) "itask",itask
6358       do i=1,2
6359         iproc=itask(i)
6360         if (iproc.gt.0) then
6361           do j=1,num_cont_hb(ii)
6362             jjc=jcont_hb(j,ii)
6363 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6364             if (jjc.eq.jj) then
6365               ncont_sent(iproc)=ncont_sent(iproc)+1
6366               nn=ncont_sent(iproc)
6367               zapas(1,nn,iproc)=ii
6368               zapas(2,nn,iproc)=jjc
6369               zapas(3,nn,iproc)=facont_hb(j,ii)
6370               zapas(4,nn,iproc)=ees0p(j,ii)
6371               zapas(5,nn,iproc)=ees0m(j,ii)
6372               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6373               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6374               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6375               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6376               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6377               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6378               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6379               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6380               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6381               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6382               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6383               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6384               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6385               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6386               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6387               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6388               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6389               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6390               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6391               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6392               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6393               exit
6394             endif
6395           enddo
6396         endif
6397       enddo
6398       return
6399       end
6400 c------------------------------------------------------------------------------
6401       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6402      &  n_corr1)
6403 C This subroutine calculates multi-body contributions to hydrogen-bonding
6404       implicit real*8 (a-h,o-z)
6405       include 'DIMENSIONS'
6406       include 'COMMON.IOUNITS'
6407 #ifdef MPI
6408       include "mpif.h"
6409       parameter (max_cont=maxconts)
6410       parameter (max_dim=70)
6411       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6412       double precision zapas(max_dim,maxconts,max_fg_procs),
6413      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6414       common /przechowalnia/ zapas
6415       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6416      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6417 #endif
6418       include 'COMMON.SETUP'
6419       include 'COMMON.FFIELD'
6420       include 'COMMON.DERIV'
6421       include 'COMMON.LOCAL'
6422       include 'COMMON.INTERACT'
6423       include 'COMMON.CONTACTS'
6424 #ifdef MOMENT
6425       include 'COMMON.CONTACTS.MOMENT'
6426 #endif
6427       include 'COMMON.CHAIN'
6428       include 'COMMON.CONTROL'
6429       double precision gx(3),gx1(3)
6430       integer num_cont_hb_old(maxres)
6431       logical lprn,ldone
6432       double precision eello4,eello5,eelo6,eello_turn6
6433       external eello4,eello5,eello6,eello_turn6
6434 C Set lprn=.true. for debugging
6435       lprn=.false.
6436       eturn6=0.0d0
6437 #ifdef MPI
6438       do i=1,nres
6439         num_cont_hb_old(i)=num_cont_hb(i)
6440       enddo
6441       n_corr=0
6442       n_corr1=0
6443       if (nfgtasks.le.1) goto 30
6444       if (lprn) then
6445         write (iout,'(a)') 'Contact function values before RECEIVE:'
6446         do i=nnt,nct-2
6447           write (iout,'(2i3,50(1x,i2,f5.2))')
6448      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6449      &    j=1,num_cont_hb(i))
6450         enddo
6451       endif
6452       call flush(iout)
6453       do i=1,ntask_cont_from
6454         ncont_recv(i)=0
6455       enddo
6456       do i=1,ntask_cont_to
6457         ncont_sent(i)=0
6458       enddo
6459 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6460 c     & ntask_cont_to
6461 C Make the list of contacts to send to send to other procesors
6462       do i=iturn3_start,iturn3_end
6463 c        write (iout,*) "make contact list turn3",i," num_cont",
6464 c     &    num_cont_hb(i)
6465         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6466       enddo
6467       do i=iturn4_start,iturn4_end
6468 c        write (iout,*) "make contact list turn4",i," num_cont",
6469 c     &   num_cont_hb(i)
6470         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6471       enddo
6472       do ii=1,nat_sent
6473         i=iat_sent(ii)
6474 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6475 c     &    num_cont_hb(i)
6476         do j=1,num_cont_hb(i)
6477         do k=1,4
6478           jjc=jcont_hb(j,i)
6479           iproc=iint_sent_local(k,jjc,ii)
6480 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6481           if (iproc.ne.0) then
6482             ncont_sent(iproc)=ncont_sent(iproc)+1
6483             nn=ncont_sent(iproc)
6484             zapas(1,nn,iproc)=i
6485             zapas(2,nn,iproc)=jjc
6486             zapas(3,nn,iproc)=d_cont(j,i)
6487             ind=3
6488             do kk=1,3
6489               ind=ind+1
6490               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6491             enddo
6492             do kk=1,2
6493               do ll=1,2
6494                 ind=ind+1
6495                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6496               enddo
6497             enddo
6498             do jj=1,5
6499               do kk=1,3
6500                 do ll=1,2
6501                   do mm=1,2
6502                     ind=ind+1
6503                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6504                   enddo
6505                 enddo
6506               enddo
6507             enddo
6508           endif
6509         enddo
6510         enddo
6511       enddo
6512       if (lprn) then
6513       write (iout,*)
6514      &  "Numbers of contacts to be sent to other processors",
6515      &  (ncont_sent(i),i=1,ntask_cont_to)
6516       write (iout,*) "Contacts sent"
6517       do ii=1,ntask_cont_to
6518         nn=ncont_sent(ii)
6519         iproc=itask_cont_to(ii)
6520         write (iout,*) nn," contacts to processor",iproc,
6521      &   " of CONT_TO_COMM group"
6522         do i=1,nn
6523           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6524         enddo
6525       enddo
6526       call flush(iout)
6527       endif
6528       CorrelType=477
6529       CorrelID=fg_rank+1
6530       CorrelType1=478
6531       CorrelID1=nfgtasks+fg_rank+1
6532       ireq=0
6533 C Receive the numbers of needed contacts from other processors
6534       do ii=1,ntask_cont_from
6535         iproc=itask_cont_from(ii)
6536         ireq=ireq+1
6537         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6538      &    FG_COMM,req(ireq),IERR)
6539       enddo
6540 c      write (iout,*) "IRECV ended"
6541 c      call flush(iout)
6542 C Send the number of contacts needed by other processors
6543       do ii=1,ntask_cont_to
6544         iproc=itask_cont_to(ii)
6545         ireq=ireq+1
6546         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6547      &    FG_COMM,req(ireq),IERR)
6548       enddo
6549 c      write (iout,*) "ISEND ended"
6550 c      write (iout,*) "number of requests (nn)",ireq
6551       call flush(iout)
6552       if (ireq.gt.0)
6553      &  call MPI_Waitall(ireq,req,status_array,ierr)
6554 c      write (iout,*)
6555 c     &  "Numbers of contacts to be received from other processors",
6556 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6557 c      call flush(iout)
6558 C Receive contacts
6559       ireq=0
6560       do ii=1,ntask_cont_from
6561         iproc=itask_cont_from(ii)
6562         nn=ncont_recv(ii)
6563 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6564 c     &   " of CONT_TO_COMM group"
6565         call flush(iout)
6566         if (nn.gt.0) then
6567           ireq=ireq+1
6568           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6569      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6570 c          write (iout,*) "ireq,req",ireq,req(ireq)
6571         endif
6572       enddo
6573 C Send the contacts to processors that need them
6574       do ii=1,ntask_cont_to
6575         iproc=itask_cont_to(ii)
6576         nn=ncont_sent(ii)
6577 c        write (iout,*) nn," contacts to processor",iproc,
6578 c     &   " of CONT_TO_COMM group"
6579         if (nn.gt.0) then
6580           ireq=ireq+1
6581           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6582      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6583 c          write (iout,*) "ireq,req",ireq,req(ireq)
6584 c          do i=1,nn
6585 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6586 c          enddo
6587         endif
6588       enddo
6589 c      write (iout,*) "number of requests (contacts)",ireq
6590 c      write (iout,*) "req",(req(i),i=1,4)
6591 c      call flush(iout)
6592       if (ireq.gt.0)
6593      & call MPI_Waitall(ireq,req,status_array,ierr)
6594       do iii=1,ntask_cont_from
6595         iproc=itask_cont_from(iii)
6596         nn=ncont_recv(iii)
6597         if (lprn) then
6598         write (iout,*) "Received",nn," contacts from processor",iproc,
6599      &   " of CONT_FROM_COMM group"
6600         call flush(iout)
6601         do i=1,nn
6602           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6603         enddo
6604         call flush(iout)
6605         endif
6606         do i=1,nn
6607           ii=zapas_recv(1,i,iii)
6608 c Flag the received contacts to prevent double-counting
6609           jj=-zapas_recv(2,i,iii)
6610 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6611 c          call flush(iout)
6612           nnn=num_cont_hb(ii)+1
6613           num_cont_hb(ii)=nnn
6614           jcont_hb(nnn,ii)=jj
6615           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6616           ind=3
6617           do kk=1,3
6618             ind=ind+1
6619             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6620           enddo
6621           do kk=1,2
6622             do ll=1,2
6623               ind=ind+1
6624               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6625             enddo
6626           enddo
6627           do jj=1,5
6628             do kk=1,3
6629               do ll=1,2
6630                 do mm=1,2
6631                   ind=ind+1
6632                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6633                 enddo
6634               enddo
6635             enddo
6636           enddo
6637         enddo
6638       enddo
6639       call flush(iout)
6640       if (lprn) then
6641         write (iout,'(a)') 'Contact function values after receive:'
6642         do i=nnt,nct-2
6643           write (iout,'(2i3,50(1x,i3,5f6.3))')
6644      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6645      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6646         enddo
6647         call flush(iout)
6648       endif
6649    30 continue
6650 #endif
6651       if (lprn) then
6652         write (iout,'(a)') 'Contact function values:'
6653         do i=nnt,nct-2
6654           write (iout,'(2i3,50(1x,i2,5f6.3))')
6655      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6656      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6657         enddo
6658       endif
6659       ecorr=0.0D0
6660       ecorr5=0.0d0
6661       ecorr6=0.0d0
6662 C Remove the loop below after debugging !!!
6663       do i=nnt,nct
6664         do j=1,3
6665           gradcorr(j,i)=0.0D0
6666           gradxorr(j,i)=0.0D0
6667         enddo
6668       enddo
6669 C Calculate the dipole-dipole interaction energies
6670       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6671       do i=iatel_s,iatel_e+1
6672         num_conti=num_cont_hb(i)
6673         do jj=1,num_conti
6674           j=jcont_hb(jj,i)
6675 #ifdef MOMENT
6676           call dipole(i,j,jj)
6677 #endif
6678         enddo
6679       enddo
6680       endif
6681 C Calculate the local-electrostatic correlation terms
6682 c                write (iout,*) "gradcorr5 in eello5 before loop"
6683 c                do iii=1,nres
6684 c                  write (iout,'(i5,3f10.5)')
6685 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6686 c                enddo
6687       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6688 c        write (iout,*) "corr loop i",i
6689         i1=i+1
6690         num_conti=num_cont_hb(i)
6691         num_conti1=num_cont_hb(i+1)
6692         do jj=1,num_conti
6693           j=jcont_hb(jj,i)
6694           jp=iabs(j)
6695           do kk=1,num_conti1
6696             j1=jcont_hb(kk,i1)
6697             jp1=iabs(j1)
6698 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6699 c     &         ' jj=',jj,' kk=',kk
6700 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6701             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6702      &          .or. j.lt.0 .and. j1.gt.0) .and.
6703      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6704 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6705 C The system gains extra energy.
6706               n_corr=n_corr+1
6707               sqd1=dsqrt(d_cont(jj,i))
6708               sqd2=dsqrt(d_cont(kk,i1))
6709               sred_geom = sqd1*sqd2
6710               IF (sred_geom.lt.cutoff_corr) THEN
6711                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6712      &            ekont,fprimcont)
6713 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6714 cd     &         ' jj=',jj,' kk=',kk
6715                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6716                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6717                 do l=1,3
6718                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6719                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6720                 enddo
6721                 n_corr1=n_corr1+1
6722 cd               write (iout,*) 'sred_geom=',sred_geom,
6723 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6724 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6725 cd               write (iout,*) "g_contij",g_contij
6726 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6727 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6728                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6729                 if (wcorr4.gt.0.0d0)
6730      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6731                   if (energy_dec.and.wcorr4.gt.0.0d0)
6732      1                 write (iout,'(a6,4i5,0pf7.3)')
6733      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6734 c                write (iout,*) "gradcorr5 before eello5"
6735 c                do iii=1,nres
6736 c                  write (iout,'(i5,3f10.5)')
6737 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6738 c                enddo
6739                 if (wcorr5.gt.0.0d0)
6740      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6741 c                write (iout,*) "gradcorr5 after eello5"
6742 c                do iii=1,nres
6743 c                  write (iout,'(i5,3f10.5)')
6744 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6745 c                enddo
6746                   if (energy_dec.and.wcorr5.gt.0.0d0)
6747      1                 write (iout,'(a6,4i5,0pf7.3)')
6748      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6749 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6750 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6751                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6752      &               .or. wturn6.eq.0.0d0))then
6753 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6754                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6755                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6756      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6757 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6758 cd     &            'ecorr6=',ecorr6
6759 cd                write (iout,'(4e15.5)') sred_geom,
6760 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6761 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6762 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6763                 else if (wturn6.gt.0.0d0
6764      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6765 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6766                   eturn6=eturn6+eello_turn6(i,jj,kk)
6767                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6768      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6769 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6770                 endif
6771               ENDIF
6772 1111          continue
6773             endif
6774           enddo ! kk
6775         enddo ! jj
6776       enddo ! i
6777       do i=1,nres
6778         num_cont_hb(i)=num_cont_hb_old(i)
6779       enddo
6780 c                write (iout,*) "gradcorr5 in eello5"
6781 c                do iii=1,nres
6782 c                  write (iout,'(i5,3f10.5)')
6783 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6784 c                enddo
6785       return
6786       end
6787 c------------------------------------------------------------------------------
6788       subroutine add_hb_contact_eello(ii,jj,itask)
6789       implicit real*8 (a-h,o-z)
6790       include "DIMENSIONS"
6791       include "COMMON.IOUNITS"
6792       integer max_cont
6793       integer max_dim
6794       parameter (max_cont=maxconts)
6795       parameter (max_dim=70)
6796       include "COMMON.CONTACTS"
6797 #ifdef MOMENT
6798       include 'COMMON.CONTACTS.MOMENT'
6799 #endif
6800       double precision zapas(max_dim,maxconts,max_fg_procs),
6801      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6802       common /przechowalnia/ zapas
6803       integer i,j,ii,jj,iproc,itask(4),nn
6804 c      write (iout,*) "itask",itask
6805       do i=1,2
6806         iproc=itask(i)
6807         if (iproc.gt.0) then
6808           do j=1,num_cont_hb(ii)
6809             jjc=jcont_hb(j,ii)
6810 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6811             if (jjc.eq.jj) then
6812               ncont_sent(iproc)=ncont_sent(iproc)+1
6813               nn=ncont_sent(iproc)
6814               zapas(1,nn,iproc)=ii
6815               zapas(2,nn,iproc)=jjc
6816               zapas(3,nn,iproc)=d_cont(j,ii)
6817               ind=3
6818               do kk=1,3
6819                 ind=ind+1
6820                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6821               enddo
6822               do kk=1,2
6823                 do ll=1,2
6824                   ind=ind+1
6825                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6826                 enddo
6827               enddo
6828               do jj=1,5
6829                 do kk=1,3
6830                   do ll=1,2
6831                     do mm=1,2
6832                       ind=ind+1
6833                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6834                     enddo
6835                   enddo
6836                 enddo
6837               enddo
6838               exit
6839             endif
6840           enddo
6841         endif
6842       enddo
6843       return
6844       end
6845 c------------------------------------------------------------------------------
6846       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6847       implicit real*8 (a-h,o-z)
6848       include 'DIMENSIONS'
6849       include 'COMMON.IOUNITS'
6850       include 'COMMON.DERIV'
6851       include 'COMMON.INTERACT'
6852       include 'COMMON.CONTACTS'
6853 #ifdef MOMENT
6854       include 'COMMON.CONTACTS.MOMENT'
6855 #endif
6856       double precision gx(3),gx1(3)
6857       logical lprn
6858       lprn=.false.
6859       eij=facont_hb(jj,i)
6860       ekl=facont_hb(kk,k)
6861       ees0pij=ees0p(jj,i)
6862       ees0pkl=ees0p(kk,k)
6863       ees0mij=ees0m(jj,i)
6864       ees0mkl=ees0m(kk,k)
6865       ekont=eij*ekl
6866       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6867 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6868 C Following 4 lines for diagnostics.
6869 cd    ees0pkl=0.0D0
6870 cd    ees0pij=1.0D0
6871 cd    ees0mkl=0.0D0
6872 cd    ees0mij=1.0D0
6873 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6874 c     & 'Contacts ',i,j,
6875 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6876 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6877 c     & 'gradcorr_long'
6878 C Calculate the multi-body contribution to energy.
6879 c      ecorr=ecorr+ekont*ees
6880 C Calculate multi-body contributions to the gradient.
6881       coeffpees0pij=coeffp*ees0pij
6882       coeffmees0mij=coeffm*ees0mij
6883       coeffpees0pkl=coeffp*ees0pkl
6884       coeffmees0mkl=coeffm*ees0mkl
6885       do ll=1,3
6886 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6887         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6888      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6889      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6890         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6891      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6892      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6893 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6894         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6895      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6896      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6897         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6898      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6899      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6900         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6901      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6902      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6903         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6904         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6905         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6906      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6907      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6908         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6909         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6910 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6911       enddo
6912 c      write (iout,*)
6913 cgrad      do m=i+1,j-1
6914 cgrad        do ll=1,3
6915 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6916 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6917 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6918 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6919 cgrad        enddo
6920 cgrad      enddo
6921 cgrad      do m=k+1,l-1
6922 cgrad        do ll=1,3
6923 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6924 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6925 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6926 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6927 cgrad        enddo
6928 cgrad      enddo
6929 c      write (iout,*) "ehbcorr",ekont*ees
6930       ehbcorr=ekont*ees
6931       return
6932       end
6933 #ifdef MOMENT
6934 C---------------------------------------------------------------------------
6935       subroutine dipole(i,j,jj)
6936       implicit real*8 (a-h,o-z)
6937       include 'DIMENSIONS'
6938       include 'COMMON.IOUNITS'
6939       include 'COMMON.CHAIN'
6940       include 'COMMON.FFIELD'
6941       include 'COMMON.DERIV'
6942       include 'COMMON.INTERACT'
6943       include 'COMMON.CONTACTS'
6944 #ifdef MOMENT
6945       include 'COMMON.CONTACTS.MOMENT'
6946 #endif
6947       include 'COMMON.TORSION'
6948       include 'COMMON.VAR'
6949       include 'COMMON.GEO'
6950       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6951      &  auxmat(2,2)
6952       iti1 = itortyp(itype(i+1))
6953       if (j.lt.nres-1) then
6954         itj1 = itortyp(itype(j+1))
6955       else
6956         itj1=ntortyp+1
6957       endif
6958       do iii=1,2
6959         dipi(iii,1)=Ub2(iii,i)
6960         dipderi(iii)=Ub2der(iii,i)
6961         dipi(iii,2)=b1(iii,iti1)
6962         dipj(iii,1)=Ub2(iii,j)
6963         dipderj(iii)=Ub2der(iii,j)
6964         dipj(iii,2)=b1(iii,itj1)
6965       enddo
6966       kkk=0
6967       do iii=1,2
6968         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6969         do jjj=1,2
6970           kkk=kkk+1
6971           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6972         enddo
6973       enddo
6974       do kkk=1,5
6975         do lll=1,3
6976           mmm=0
6977           do iii=1,2
6978             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6979      &        auxvec(1))
6980             do jjj=1,2
6981               mmm=mmm+1
6982               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6983             enddo
6984           enddo
6985         enddo
6986       enddo
6987       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6988       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6989       do iii=1,2
6990         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6991       enddo
6992       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6993       do iii=1,2
6994         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6995       enddo
6996       return
6997       end
6998 #endif
6999 C---------------------------------------------------------------------------
7000       subroutine calc_eello(i,j,k,l,jj,kk)
7001 C
7002 C This subroutine computes matrices and vectors needed to calculate
7003 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7004 C
7005       implicit real*8 (a-h,o-z)
7006       include 'DIMENSIONS'
7007       include 'COMMON.IOUNITS'
7008       include 'COMMON.CHAIN'
7009       include 'COMMON.DERIV'
7010       include 'COMMON.INTERACT'
7011       include 'COMMON.CONTACTS'
7012 #ifdef MOMENT
7013       include 'COMMON.CONTACTS.MOMENT'
7014 #endif
7015       include 'COMMON.TORSION'
7016       include 'COMMON.VAR'
7017       include 'COMMON.GEO'
7018       include 'COMMON.FFIELD'
7019       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7020      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7021       logical lprn
7022       common /kutas/ lprn
7023 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7024 cd     & ' jj=',jj,' kk=',kk
7025 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7026 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7027 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7028       do iii=1,2
7029         do jjj=1,2
7030           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7031           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7032         enddo
7033       enddo
7034       call transpose2(aa1(1,1),aa1t(1,1))
7035       call transpose2(aa2(1,1),aa2t(1,1))
7036       do kkk=1,5
7037         do lll=1,3
7038           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7039      &      aa1tder(1,1,lll,kkk))
7040           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7041      &      aa2tder(1,1,lll,kkk))
7042         enddo
7043       enddo
7044       if (l.eq.j+1) then
7045 C parallel orientation of the two CA-CA-CA frames.
7046         if (i.gt.1) then
7047           iti=itortyp(itype(i))
7048         else
7049           iti=ntortyp+1
7050         endif
7051         itk1=itortyp(itype(k+1))
7052         itj=itortyp(itype(j))
7053         if (l.lt.nres-1) then
7054           itl1=itortyp(itype(l+1))
7055         else
7056           itl1=ntortyp+1
7057         endif
7058 C A1 kernel(j+1) A2T
7059 cd        do iii=1,2
7060 cd          write (iout,'(3f10.5,5x,3f10.5)')
7061 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7062 cd        enddo
7063         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7064      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7065      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7066 C Following matrices are needed only for 6-th order cumulants
7067         IF (wcorr6.gt.0.0d0) THEN
7068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7069      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7070      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7071         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7072      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7073      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7074      &   ADtEAderx(1,1,1,1,1,1))
7075         lprn=.false.
7076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7077      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7078      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7079      &   ADtEA1derx(1,1,1,1,1,1))
7080         ENDIF
7081 C End 6-th order cumulants
7082 cd        lprn=.false.
7083 cd        if (lprn) then
7084 cd        write (2,*) 'In calc_eello6'
7085 cd        do iii=1,2
7086 cd          write (2,*) 'iii=',iii
7087 cd          do kkk=1,5
7088 cd            write (2,*) 'kkk=',kkk
7089 cd            do jjj=1,2
7090 cd              write (2,'(3(2f10.5),5x)')
7091 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7092 cd            enddo
7093 cd          enddo
7094 cd        enddo
7095 cd        endif
7096         call transpose2(EUgder(1,1,k),auxmat(1,1))
7097         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7098         call transpose2(EUg(1,1,k),auxmat(1,1))
7099         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7100         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7101         do iii=1,2
7102           do kkk=1,5
7103             do lll=1,3
7104               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7105      &          EAEAderx(1,1,lll,kkk,iii,1))
7106             enddo
7107           enddo
7108         enddo
7109 C A1T kernel(i+1) A2
7110         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7111      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7112      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7113 C Following matrices are needed only for 6-th order cumulants
7114         IF (wcorr6.gt.0.0d0) THEN
7115         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7116      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7117      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7118         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7119      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7120      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7121      &   ADtEAderx(1,1,1,1,1,2))
7122         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7123      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7124      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7125      &   ADtEA1derx(1,1,1,1,1,2))
7126         ENDIF
7127 C End 6-th order cumulants
7128         call transpose2(EUgder(1,1,l),auxmat(1,1))
7129         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7130         call transpose2(EUg(1,1,l),auxmat(1,1))
7131         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7132         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7133         do iii=1,2
7134           do kkk=1,5
7135             do lll=1,3
7136               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7137      &          EAEAderx(1,1,lll,kkk,iii,2))
7138             enddo
7139           enddo
7140         enddo
7141 C AEAb1 and AEAb2
7142 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7143 C They are needed only when the fifth- or the sixth-order cumulants are
7144 C indluded.
7145         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7146         call transpose2(AEA(1,1,1),auxmat(1,1))
7147         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7148         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7149         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7150         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7151         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7152         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7153         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7154         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7155         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7156         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7157         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7158         call transpose2(AEA(1,1,2),auxmat(1,1))
7159         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7160         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7161         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7162         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7163         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7164         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7165         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7166         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7167         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7168         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7169         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7170 C Calculate the Cartesian derivatives of the vectors.
7171         do iii=1,2
7172           do kkk=1,5
7173             do lll=1,3
7174               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7175               call matvec2(auxmat(1,1),b1(1,iti),
7176      &          AEAb1derx(1,lll,kkk,iii,1,1))
7177               call matvec2(auxmat(1,1),Ub2(1,i),
7178      &          AEAb2derx(1,lll,kkk,iii,1,1))
7179               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7180      &          AEAb1derx(1,lll,kkk,iii,2,1))
7181               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7182      &          AEAb2derx(1,lll,kkk,iii,2,1))
7183               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7184               call matvec2(auxmat(1,1),b1(1,itj),
7185      &          AEAb1derx(1,lll,kkk,iii,1,2))
7186               call matvec2(auxmat(1,1),Ub2(1,j),
7187      &          AEAb2derx(1,lll,kkk,iii,1,2))
7188               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7189      &          AEAb1derx(1,lll,kkk,iii,2,2))
7190               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7191      &          AEAb2derx(1,lll,kkk,iii,2,2))
7192             enddo
7193           enddo
7194         enddo
7195         ENDIF
7196 C End vectors
7197       else
7198 C Antiparallel orientation of the two CA-CA-CA frames.
7199         if (i.gt.1) then
7200           iti=itortyp(itype(i))
7201         else
7202           iti=ntortyp+1
7203         endif
7204         itk1=itortyp(itype(k+1))
7205         itl=itortyp(itype(l))
7206         itj=itortyp(itype(j))
7207         if (j.lt.nres-1) then
7208           itj1=itortyp(itype(j+1))
7209         else
7210           itj1=ntortyp+1
7211         endif
7212 C A2 kernel(j-1)T A1T
7213         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7214      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7215      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7216 C Following matrices are needed only for 6-th order cumulants
7217         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7218      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7219         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7220      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7221      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7222         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7223      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7224      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7225      &   ADtEAderx(1,1,1,1,1,1))
7226         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7227      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7228      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7229      &   ADtEA1derx(1,1,1,1,1,1))
7230         ENDIF
7231 C End 6-th order cumulants
7232         call transpose2(EUgder(1,1,k),auxmat(1,1))
7233         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7234         call transpose2(EUg(1,1,k),auxmat(1,1))
7235         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7236         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7237         do iii=1,2
7238           do kkk=1,5
7239             do lll=1,3
7240               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7241      &          EAEAderx(1,1,lll,kkk,iii,1))
7242             enddo
7243           enddo
7244         enddo
7245 C A2T kernel(i+1)T A1
7246         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7247      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7248      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7249 C Following matrices are needed only for 6-th order cumulants
7250         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7251      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7252         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7253      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7254      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7255         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7256      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7257      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7258      &   ADtEAderx(1,1,1,1,1,2))
7259         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7260      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7261      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7262      &   ADtEA1derx(1,1,1,1,1,2))
7263         ENDIF
7264 C End 6-th order cumulants
7265         call transpose2(EUgder(1,1,j),auxmat(1,1))
7266         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7267         call transpose2(EUg(1,1,j),auxmat(1,1))
7268         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7269         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7270         do iii=1,2
7271           do kkk=1,5
7272             do lll=1,3
7273               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7274      &          EAEAderx(1,1,lll,kkk,iii,2))
7275             enddo
7276           enddo
7277         enddo
7278 C AEAb1 and AEAb2
7279 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7280 C They are needed only when the fifth- or the sixth-order cumulants are
7281 C indluded.
7282         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7283      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7284         call transpose2(AEA(1,1,1),auxmat(1,1))
7285         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7286         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7287         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7288         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7289         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7290         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7291         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7292         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7293         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7294         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7295         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7296         call transpose2(AEA(1,1,2),auxmat(1,1))
7297         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7298         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7299         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7300         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7301         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7302         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7303         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7304         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7305         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7306         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7307         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7308 C Calculate the Cartesian derivatives of the vectors.
7309         do iii=1,2
7310           do kkk=1,5
7311             do lll=1,3
7312               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7313               call matvec2(auxmat(1,1),b1(1,iti),
7314      &          AEAb1derx(1,lll,kkk,iii,1,1))
7315               call matvec2(auxmat(1,1),Ub2(1,i),
7316      &          AEAb2derx(1,lll,kkk,iii,1,1))
7317               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7318      &          AEAb1derx(1,lll,kkk,iii,2,1))
7319               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7320      &          AEAb2derx(1,lll,kkk,iii,2,1))
7321               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7322               call matvec2(auxmat(1,1),b1(1,itl),
7323      &          AEAb1derx(1,lll,kkk,iii,1,2))
7324               call matvec2(auxmat(1,1),Ub2(1,l),
7325      &          AEAb2derx(1,lll,kkk,iii,1,2))
7326               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7327      &          AEAb1derx(1,lll,kkk,iii,2,2))
7328               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7329      &          AEAb2derx(1,lll,kkk,iii,2,2))
7330             enddo
7331           enddo
7332         enddo
7333         ENDIF
7334 C End vectors
7335       endif
7336       return
7337       end
7338 C---------------------------------------------------------------------------
7339       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7340      &  KK,KKderg,AKA,AKAderg,AKAderx)
7341       implicit none
7342       integer nderg
7343       logical transp
7344       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7345      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7346      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7347       integer iii,kkk,lll
7348       integer jjj,mmm
7349       logical lprn
7350       common /kutas/ lprn
7351       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7352       do iii=1,nderg
7353         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7354      &    AKAderg(1,1,iii))
7355       enddo
7356 cd      if (lprn) write (2,*) 'In kernel'
7357       do kkk=1,5
7358 cd        if (lprn) write (2,*) 'kkk=',kkk
7359         do lll=1,3
7360           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7361      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7362 cd          if (lprn) then
7363 cd            write (2,*) 'lll=',lll
7364 cd            write (2,*) 'iii=1'
7365 cd            do jjj=1,2
7366 cd              write (2,'(3(2f10.5),5x)')
7367 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7368 cd            enddo
7369 cd          endif
7370           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7371      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7372 cd          if (lprn) then
7373 cd            write (2,*) 'lll=',lll
7374 cd            write (2,*) 'iii=2'
7375 cd            do jjj=1,2
7376 cd              write (2,'(3(2f10.5),5x)')
7377 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7378 cd            enddo
7379 cd          endif
7380         enddo
7381       enddo
7382       return
7383       end
7384 C---------------------------------------------------------------------------
7385       double precision function eello4(i,j,k,l,jj,kk)
7386       implicit real*8 (a-h,o-z)
7387       include 'DIMENSIONS'
7388       include 'COMMON.IOUNITS'
7389       include 'COMMON.CHAIN'
7390       include 'COMMON.DERIV'
7391       include 'COMMON.INTERACT'
7392       include 'COMMON.CONTACTS'
7393 #ifdef MOMENT
7394       include 'COMMON.CONTACTS.MOMENT'
7395 #endif
7396       include 'COMMON.TORSION'
7397       include 'COMMON.VAR'
7398       include 'COMMON.GEO'
7399       double precision pizda(2,2),ggg1(3),ggg2(3)
7400 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7401 cd        eello4=0.0d0
7402 cd        return
7403 cd      endif
7404 cd      print *,'eello4:',i,j,k,l,jj,kk
7405 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7406 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7407 cold      eij=facont_hb(jj,i)
7408 cold      ekl=facont_hb(kk,k)
7409 cold      ekont=eij*ekl
7410       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7411 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7412       gcorr_loc(k-1)=gcorr_loc(k-1)
7413      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7414       if (l.eq.j+1) then
7415         gcorr_loc(l-1)=gcorr_loc(l-1)
7416      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7417       else
7418         gcorr_loc(j-1)=gcorr_loc(j-1)
7419      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7420       endif
7421       do iii=1,2
7422         do kkk=1,5
7423           do lll=1,3
7424             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7425      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7426 cd            derx(lll,kkk,iii)=0.0d0
7427           enddo
7428         enddo
7429       enddo
7430 cd      gcorr_loc(l-1)=0.0d0
7431 cd      gcorr_loc(j-1)=0.0d0
7432 cd      gcorr_loc(k-1)=0.0d0
7433 cd      eel4=1.0d0
7434 cd      write (iout,*)'Contacts have occurred for peptide groups',
7435 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7436 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7437       if (j.lt.nres-1) then
7438         j1=j+1
7439         j2=j-1
7440       else
7441         j1=j-1
7442         j2=j-2
7443       endif
7444       if (l.lt.nres-1) then
7445         l1=l+1
7446         l2=l-1
7447       else
7448         l1=l-1
7449         l2=l-2
7450       endif
7451       do ll=1,3
7452 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7453 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7454         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7455         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7456 cgrad        ghalf=0.5d0*ggg1(ll)
7457         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7458         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7459         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7460         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7461         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7462         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7463 cgrad        ghalf=0.5d0*ggg2(ll)
7464         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7465         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7466         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7467         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7468         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7469         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7470       enddo
7471 cgrad      do m=i+1,j-1
7472 cgrad        do ll=1,3
7473 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7474 cgrad        enddo
7475 cgrad      enddo
7476 cgrad      do m=k+1,l-1
7477 cgrad        do ll=1,3
7478 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7479 cgrad        enddo
7480 cgrad      enddo
7481 cgrad      do m=i+2,j2
7482 cgrad        do ll=1,3
7483 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7484 cgrad        enddo
7485 cgrad      enddo
7486 cgrad      do m=k+2,l2
7487 cgrad        do ll=1,3
7488 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7489 cgrad        enddo
7490 cgrad      enddo
7491 cd      do iii=1,nres-3
7492 cd        write (2,*) iii,gcorr_loc(iii)
7493 cd      enddo
7494       eello4=ekont*eel4
7495 cd      write (2,*) 'ekont',ekont
7496 cd      write (iout,*) 'eello4',ekont*eel4
7497       return
7498       end
7499 C---------------------------------------------------------------------------
7500       double precision function eello5(i,j,k,l,jj,kk)
7501       implicit real*8 (a-h,o-z)
7502       include 'DIMENSIONS'
7503       include 'COMMON.IOUNITS'
7504       include 'COMMON.CHAIN'
7505       include 'COMMON.DERIV'
7506       include 'COMMON.INTERACT'
7507       include 'COMMON.CONTACTS'
7508 #ifdef MOMENT
7509       include 'COMMON.CONTACTS.MOMENT'
7510 #endif
7511       include 'COMMON.TORSION'
7512       include 'COMMON.VAR'
7513       include 'COMMON.GEO'
7514       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7515       double precision ggg1(3),ggg2(3)
7516 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7517 C                                                                              C
7518 C                            Parallel chains                                   C
7519 C                                                                              C
7520 C          o             o                   o             o                   C
7521 C         /l\           / \             \   / \           / \   /              C
7522 C        /   \         /   \             \ /   \         /   \ /               C
7523 C       j| o |l1       | o |              o| o |         | o |o                C
7524 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7525 C      \i/   \         /   \ /             /   \         /   \                 C
7526 C       o    k1             o                                                  C
7527 C         (I)          (II)                (III)          (IV)                 C
7528 C                                                                              C
7529 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7530 C                                                                              C
7531 C                            Antiparallel chains                               C
7532 C                                                                              C
7533 C          o             o                   o             o                   C
7534 C         /j\           / \             \   / \           / \   /              C
7535 C        /   \         /   \             \ /   \         /   \ /               C
7536 C      j1| o |l        | o |              o| o |         | o |o                C
7537 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7538 C      \i/   \         /   \ /             /   \         /   \                 C
7539 C       o     k1            o                                                  C
7540 C         (I)          (II)                (III)          (IV)                 C
7541 C                                                                              C
7542 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7543 C                                                                              C
7544 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7545 C                                                                              C
7546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7547 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7548 cd        eello5=0.0d0
7549 cd        return
7550 cd      endif
7551 cd      write (iout,*)
7552 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7553 cd     &   ' and',k,l
7554       itk=itortyp(itype(k))
7555       itl=itortyp(itype(l))
7556       itj=itortyp(itype(j))
7557       eello5_1=0.0d0
7558       eello5_2=0.0d0
7559       eello5_3=0.0d0
7560       eello5_4=0.0d0
7561 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7562 cd     &   eel5_3_num,eel5_4_num)
7563       do iii=1,2
7564         do kkk=1,5
7565           do lll=1,3
7566             derx(lll,kkk,iii)=0.0d0
7567           enddo
7568         enddo
7569       enddo
7570 cd      eij=facont_hb(jj,i)
7571 cd      ekl=facont_hb(kk,k)
7572 cd      ekont=eij*ekl
7573 cd      write (iout,*)'Contacts have occurred for peptide groups',
7574 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7575 cd      goto 1111
7576 C Contribution from the graph I.
7577 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7578 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7579       call transpose2(EUg(1,1,k),auxmat(1,1))
7580       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7581       vv(1)=pizda(1,1)-pizda(2,2)
7582       vv(2)=pizda(1,2)+pizda(2,1)
7583       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7584      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7585 C Explicit gradient in virtual-dihedral angles.
7586       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7587      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7588      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7589       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7590       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7591       vv(1)=pizda(1,1)-pizda(2,2)
7592       vv(2)=pizda(1,2)+pizda(2,1)
7593       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7594      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7595      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7596       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7597       vv(1)=pizda(1,1)-pizda(2,2)
7598       vv(2)=pizda(1,2)+pizda(2,1)
7599       if (l.eq.j+1) then
7600         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7601      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7602      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7603       else
7604         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7605      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7606      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7607       endif
7608 C Cartesian gradient
7609       do iii=1,2
7610         do kkk=1,5
7611           do lll=1,3
7612             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7613      &        pizda(1,1))
7614             vv(1)=pizda(1,1)-pizda(2,2)
7615             vv(2)=pizda(1,2)+pizda(2,1)
7616             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7617      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7618      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7619           enddo
7620         enddo
7621       enddo
7622 c      goto 1112
7623 c1111  continue
7624 C Contribution from graph II
7625       call transpose2(EE(1,1,itk),auxmat(1,1))
7626       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7627       vv(1)=pizda(1,1)+pizda(2,2)
7628       vv(2)=pizda(2,1)-pizda(1,2)
7629       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7630      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7631 C Explicit gradient in virtual-dihedral angles.
7632       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7633      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7634       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7635       vv(1)=pizda(1,1)+pizda(2,2)
7636       vv(2)=pizda(2,1)-pizda(1,2)
7637       if (l.eq.j+1) then
7638         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7639      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7640      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7641       else
7642         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7643      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7644      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7645       endif
7646 C Cartesian gradient
7647       do iii=1,2
7648         do kkk=1,5
7649           do lll=1,3
7650             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7651      &        pizda(1,1))
7652             vv(1)=pizda(1,1)+pizda(2,2)
7653             vv(2)=pizda(2,1)-pizda(1,2)
7654             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7655      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7656      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7657           enddo
7658         enddo
7659       enddo
7660 cd      goto 1112
7661 cd1111  continue
7662       if (l.eq.j+1) then
7663 cd        goto 1110
7664 C Parallel orientation
7665 C Contribution from graph III
7666         call transpose2(EUg(1,1,l),auxmat(1,1))
7667         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7668         vv(1)=pizda(1,1)-pizda(2,2)
7669         vv(2)=pizda(1,2)+pizda(2,1)
7670         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7671      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7672 C Explicit gradient in virtual-dihedral angles.
7673         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7674      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7675      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7676         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7677         vv(1)=pizda(1,1)-pizda(2,2)
7678         vv(2)=pizda(1,2)+pizda(2,1)
7679         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7680      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7681      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7682         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7683         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7684         vv(1)=pizda(1,1)-pizda(2,2)
7685         vv(2)=pizda(1,2)+pizda(2,1)
7686         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7687      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7688      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7689 C Cartesian gradient
7690         do iii=1,2
7691           do kkk=1,5
7692             do lll=1,3
7693               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7694      &          pizda(1,1))
7695               vv(1)=pizda(1,1)-pizda(2,2)
7696               vv(2)=pizda(1,2)+pizda(2,1)
7697               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7698      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7699      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7700             enddo
7701           enddo
7702         enddo
7703 cd        goto 1112
7704 C Contribution from graph IV
7705 cd1110    continue
7706         call transpose2(EE(1,1,itl),auxmat(1,1))
7707         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7708         vv(1)=pizda(1,1)+pizda(2,2)
7709         vv(2)=pizda(2,1)-pizda(1,2)
7710         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7711      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7712 C Explicit gradient in virtual-dihedral angles.
7713         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7714      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7715         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7716         vv(1)=pizda(1,1)+pizda(2,2)
7717         vv(2)=pizda(2,1)-pizda(1,2)
7718         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7719      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7720      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7721 C Cartesian gradient
7722         do iii=1,2
7723           do kkk=1,5
7724             do lll=1,3
7725               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7726      &          pizda(1,1))
7727               vv(1)=pizda(1,1)+pizda(2,2)
7728               vv(2)=pizda(2,1)-pizda(1,2)
7729               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7730      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7731      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7732             enddo
7733           enddo
7734         enddo
7735       else
7736 C Antiparallel orientation
7737 C Contribution from graph III
7738 c        goto 1110
7739         call transpose2(EUg(1,1,j),auxmat(1,1))
7740         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7741         vv(1)=pizda(1,1)-pizda(2,2)
7742         vv(2)=pizda(1,2)+pizda(2,1)
7743         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7745 C Explicit gradient in virtual-dihedral angles.
7746         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7747      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7748      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7749         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7750         vv(1)=pizda(1,1)-pizda(2,2)
7751         vv(2)=pizda(1,2)+pizda(2,1)
7752         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7753      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7754      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7755         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7756         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7757         vv(1)=pizda(1,1)-pizda(2,2)
7758         vv(2)=pizda(1,2)+pizda(2,1)
7759         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7760      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7762 C Cartesian gradient
7763         do iii=1,2
7764           do kkk=1,5
7765             do lll=1,3
7766               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7767      &          pizda(1,1))
7768               vv(1)=pizda(1,1)-pizda(2,2)
7769               vv(2)=pizda(1,2)+pizda(2,1)
7770               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7771      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7772      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7773             enddo
7774           enddo
7775         enddo
7776 cd        goto 1112
7777 C Contribution from graph IV
7778 1110    continue
7779         call transpose2(EE(1,1,itj),auxmat(1,1))
7780         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7781         vv(1)=pizda(1,1)+pizda(2,2)
7782         vv(2)=pizda(2,1)-pizda(1,2)
7783         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7784      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7785 C Explicit gradient in virtual-dihedral angles.
7786         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7787      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7788         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7789         vv(1)=pizda(1,1)+pizda(2,2)
7790         vv(2)=pizda(2,1)-pizda(1,2)
7791         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7792      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7793      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7794 C Cartesian gradient
7795         do iii=1,2
7796           do kkk=1,5
7797             do lll=1,3
7798               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7799      &          pizda(1,1))
7800               vv(1)=pizda(1,1)+pizda(2,2)
7801               vv(2)=pizda(2,1)-pizda(1,2)
7802               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7803      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7804      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7805             enddo
7806           enddo
7807         enddo
7808       endif
7809 1112  continue
7810       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7811 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7812 cd        write (2,*) 'ijkl',i,j,k,l
7813 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7814 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7815 cd      endif
7816 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7817 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7818 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7819 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7820       if (j.lt.nres-1) then
7821         j1=j+1
7822         j2=j-1
7823       else
7824         j1=j-1
7825         j2=j-2
7826       endif
7827       if (l.lt.nres-1) then
7828         l1=l+1
7829         l2=l-1
7830       else
7831         l1=l-1
7832         l2=l-2
7833       endif
7834 cd      eij=1.0d0
7835 cd      ekl=1.0d0
7836 cd      ekont=1.0d0
7837 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7838 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7839 C        summed up outside the subrouine as for the other subroutines
7840 C        handling long-range interactions. The old code is commented out
7841 C        with "cgrad" to keep track of changes.
7842       do ll=1,3
7843 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7844 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7845         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7846         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7847 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7848 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7849 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7850 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7851 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7852 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7853 c     &   gradcorr5ij,
7854 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7855 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7856 cgrad        ghalf=0.5d0*ggg1(ll)
7857 cd        ghalf=0.0d0
7858         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7859         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7860         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7861         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7862         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7863         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7864 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7865 cgrad        ghalf=0.5d0*ggg2(ll)
7866 cd        ghalf=0.0d0
7867         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7868         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7869         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7870         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7871         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7872         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7873       enddo
7874 cd      goto 1112
7875 cgrad      do m=i+1,j-1
7876 cgrad        do ll=1,3
7877 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7878 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7879 cgrad        enddo
7880 cgrad      enddo
7881 cgrad      do m=k+1,l-1
7882 cgrad        do ll=1,3
7883 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7884 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7885 cgrad        enddo
7886 cgrad      enddo
7887 c1112  continue
7888 cgrad      do m=i+2,j2
7889 cgrad        do ll=1,3
7890 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7891 cgrad        enddo
7892 cgrad      enddo
7893 cgrad      do m=k+2,l2
7894 cgrad        do ll=1,3
7895 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7896 cgrad        enddo
7897 cgrad      enddo
7898 cd      do iii=1,nres-3
7899 cd        write (2,*) iii,g_corr5_loc(iii)
7900 cd      enddo
7901       eello5=ekont*eel5
7902 cd      write (2,*) 'ekont',ekont
7903 cd      write (iout,*) 'eello5',ekont*eel5
7904       return
7905       end
7906 c--------------------------------------------------------------------------
7907       double precision function eello6(i,j,k,l,jj,kk)
7908       implicit real*8 (a-h,o-z)
7909       include 'DIMENSIONS'
7910       include 'COMMON.IOUNITS'
7911       include 'COMMON.CHAIN'
7912       include 'COMMON.DERIV'
7913       include 'COMMON.INTERACT'
7914       include 'COMMON.CONTACTS'
7915 #ifdef MOMENT
7916       include 'COMMON.CONTACTS.MOMENT'
7917 #endif
7918       include 'COMMON.TORSION'
7919       include 'COMMON.VAR'
7920       include 'COMMON.GEO'
7921       include 'COMMON.FFIELD'
7922       double precision ggg1(3),ggg2(3)
7923 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7924 cd        eello6=0.0d0
7925 cd        return
7926 cd      endif
7927 cd      write (iout,*)
7928 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7929 cd     &   ' and',k,l
7930       eello6_1=0.0d0
7931       eello6_2=0.0d0
7932       eello6_3=0.0d0
7933       eello6_4=0.0d0
7934       eello6_5=0.0d0
7935       eello6_6=0.0d0
7936 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7937 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7938       do iii=1,2
7939         do kkk=1,5
7940           do lll=1,3
7941             derx(lll,kkk,iii)=0.0d0
7942           enddo
7943         enddo
7944       enddo
7945 cd      eij=facont_hb(jj,i)
7946 cd      ekl=facont_hb(kk,k)
7947 cd      ekont=eij*ekl
7948 cd      eij=1.0d0
7949 cd      ekl=1.0d0
7950 cd      ekont=1.0d0
7951       if (l.eq.j+1) then
7952         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7953         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7954         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7955         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7956         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7957         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7958       else
7959         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7960         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7961         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7962         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7963         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7964           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7965         else
7966           eello6_5=0.0d0
7967         endif
7968         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7969       endif
7970 C If turn contributions are considered, they will be handled separately.
7971       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7972 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7973 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7974 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7975 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7976 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7977 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7978 cd      goto 1112
7979       if (j.lt.nres-1) then
7980         j1=j+1
7981         j2=j-1
7982       else
7983         j1=j-1
7984         j2=j-2
7985       endif
7986       if (l.lt.nres-1) then
7987         l1=l+1
7988         l2=l-1
7989       else
7990         l1=l-1
7991         l2=l-2
7992       endif
7993       do ll=1,3
7994 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7995 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7996 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7997 cgrad        ghalf=0.5d0*ggg1(ll)
7998 cd        ghalf=0.0d0
7999         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8000         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8001         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8002         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8003         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8004         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8005         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8006         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8007 cgrad        ghalf=0.5d0*ggg2(ll)
8008 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8009 cd        ghalf=0.0d0
8010         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8011         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8012         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8013         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8014         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8015         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8016       enddo
8017 cd      goto 1112
8018 cgrad      do m=i+1,j-1
8019 cgrad        do ll=1,3
8020 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8021 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8022 cgrad        enddo
8023 cgrad      enddo
8024 cgrad      do m=k+1,l-1
8025 cgrad        do ll=1,3
8026 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8027 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8028 cgrad        enddo
8029 cgrad      enddo
8030 cgrad1112  continue
8031 cgrad      do m=i+2,j2
8032 cgrad        do ll=1,3
8033 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8034 cgrad        enddo
8035 cgrad      enddo
8036 cgrad      do m=k+2,l2
8037 cgrad        do ll=1,3
8038 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8039 cgrad        enddo
8040 cgrad      enddo
8041 cd      do iii=1,nres-3
8042 cd        write (2,*) iii,g_corr6_loc(iii)
8043 cd      enddo
8044       eello6=ekont*eel6
8045 cd      write (2,*) 'ekont',ekont
8046 cd      write (iout,*) 'eello6',ekont*eel6
8047       return
8048       end
8049 c--------------------------------------------------------------------------
8050       double precision function eello6_graph1(i,j,k,l,imat,swap)
8051       implicit real*8 (a-h,o-z)
8052       include 'DIMENSIONS'
8053       include 'COMMON.IOUNITS'
8054       include 'COMMON.CHAIN'
8055       include 'COMMON.DERIV'
8056       include 'COMMON.INTERACT'
8057       include 'COMMON.CONTACTS'
8058 #ifdef MOMENT
8059       include 'COMMON.CONTACTS.MOMENT'
8060 #endif
8061       include 'COMMON.TORSION'
8062       include 'COMMON.VAR'
8063       include 'COMMON.GEO'
8064       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8065       logical swap
8066       logical lprn
8067       common /kutas/ lprn
8068 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8069 C                                                                              C
8070 C      Parallel       Antiparallel                                             C
8071 C                                                                              C
8072 C          o             o                                                     C
8073 C         /l\           /j\                                                    C
8074 C        /   \         /   \                                                   C
8075 C       /| o |         | o |\                                                  C
8076 C     \ j|/k\|  /   \  |/k\|l /                                                C
8077 C      \ /   \ /     \ /   \ /                                                 C
8078 C       o     o       o     o                                                  C
8079 C       i             i                                                        C
8080 C                                                                              C
8081 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8082       itk=itortyp(itype(k))
8083       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8084       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8085       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8086       call transpose2(EUgC(1,1,k),auxmat(1,1))
8087       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8088       vv1(1)=pizda1(1,1)-pizda1(2,2)
8089       vv1(2)=pizda1(1,2)+pizda1(2,1)
8090       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8091       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8092       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8093       s5=scalar2(vv(1),Dtobr2(1,i))
8094 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8095       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8096       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8097      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8098      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8099      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8100      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8101      & +scalar2(vv(1),Dtobr2der(1,i)))
8102       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8103       vv1(1)=pizda1(1,1)-pizda1(2,2)
8104       vv1(2)=pizda1(1,2)+pizda1(2,1)
8105       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8106       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8107       if (l.eq.j+1) then
8108         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8109      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8110      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8111      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8112      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8113       else
8114         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8115      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8116      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8117      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8118      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8119       endif
8120       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8121       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8122       vv1(1)=pizda1(1,1)-pizda1(2,2)
8123       vv1(2)=pizda1(1,2)+pizda1(2,1)
8124       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8125      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8126      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8127      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8128       do iii=1,2
8129         if (swap) then
8130           ind=3-iii
8131         else
8132           ind=iii
8133         endif
8134         do kkk=1,5
8135           do lll=1,3
8136             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8137             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8138             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8139             call transpose2(EUgC(1,1,k),auxmat(1,1))
8140             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8141      &        pizda1(1,1))
8142             vv1(1)=pizda1(1,1)-pizda1(2,2)
8143             vv1(2)=pizda1(1,2)+pizda1(2,1)
8144             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8145             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8146      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8147             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8148      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8149             s5=scalar2(vv(1),Dtobr2(1,i))
8150             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8151           enddo
8152         enddo
8153       enddo
8154       return
8155       end
8156 c----------------------------------------------------------------------------
8157       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8158       implicit real*8 (a-h,o-z)
8159       include 'DIMENSIONS'
8160       include 'COMMON.IOUNITS'
8161       include 'COMMON.CHAIN'
8162       include 'COMMON.DERIV'
8163       include 'COMMON.INTERACT'
8164       include 'COMMON.CONTACTS'
8165 #ifdef MOMENT
8166       include 'COMMON.CONTACTS.MOMENT'
8167 #endif
8168       include 'COMMON.TORSION'
8169       include 'COMMON.VAR'
8170       include 'COMMON.GEO'
8171       logical swap
8172       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8173      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8174       logical lprn
8175       common /kutas/ lprn
8176 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8177 C                                                                              C
8178 C      Parallel       Antiparallel                                             C
8179 C                                                                              C
8180 C          o             o                                                     C
8181 C     \   /l\           /j\   /                                                C
8182 C      \ /   \         /   \ /                                                 C
8183 C       o| o |         | o |o                                                  C
8184 C     \ j|/k\|      \  |/k\|l                                                  C
8185 C      \ /   \       \ /   \                                                   C
8186 C       o             o                                                        C
8187 C       i             i                                                        C
8188 C                                                                              C
8189 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8190 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8191 C AL 7/4/01 s1 would occur in the sixth-order moment,
8192 C           but not in a cluster cumulant
8193 #ifdef MOMENT
8194       s1=dip(1,jj,i)*dip(1,kk,k)
8195 #endif
8196       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8197       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8198       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8199       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8200       call transpose2(EUg(1,1,k),auxmat(1,1))
8201       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8202       vv(1)=pizda(1,1)-pizda(2,2)
8203       vv(2)=pizda(1,2)+pizda(2,1)
8204       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8205 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8206 #ifdef MOMENT
8207       eello6_graph2=-(s1+s2+s3+s4)
8208 #else
8209       eello6_graph2=-(s2+s3+s4)
8210 #endif
8211 c      eello6_graph2=-s3
8212 C Derivatives in gamma(i-1)
8213       if (i.gt.1) then
8214 #ifdef MOMENT
8215         s1=dipderg(1,jj,i)*dip(1,kk,k)
8216 #endif
8217         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8218         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8219         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8220         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8221 #ifdef MOMENT
8222         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8223 #else
8224         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8225 #endif
8226 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8227       endif
8228 C Derivatives in gamma(k-1)
8229 #ifdef MOMENT
8230       s1=dip(1,jj,i)*dipderg(1,kk,k)
8231 #endif
8232       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8233       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8234       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8235       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8236       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8237       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8238       vv(1)=pizda(1,1)-pizda(2,2)
8239       vv(2)=pizda(1,2)+pizda(2,1)
8240       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8241 #ifdef MOMENT
8242       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8243 #else
8244       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8245 #endif
8246 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8247 C Derivatives in gamma(j-1) or gamma(l-1)
8248       if (j.gt.1) then
8249 #ifdef MOMENT
8250         s1=dipderg(3,jj,i)*dip(1,kk,k)
8251 #endif
8252         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8253         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8254         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8255         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8256         vv(1)=pizda(1,1)-pizda(2,2)
8257         vv(2)=pizda(1,2)+pizda(2,1)
8258         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8259 #ifdef MOMENT
8260         if (swap) then
8261           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8262         else
8263           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8264         endif
8265 #endif
8266         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8267 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8268       endif
8269 C Derivatives in gamma(l-1) or gamma(j-1)
8270       if (l.gt.1) then
8271 #ifdef MOMENT
8272         s1=dip(1,jj,i)*dipderg(3,kk,k)
8273 #endif
8274         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8275         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8276         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8277         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8278         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8279         vv(1)=pizda(1,1)-pizda(2,2)
8280         vv(2)=pizda(1,2)+pizda(2,1)
8281         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8282 #ifdef MOMENT
8283         if (swap) then
8284           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8285         else
8286           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8287         endif
8288 #endif
8289         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8290 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8291       endif
8292 C Cartesian derivatives.
8293       if (lprn) then
8294         write (2,*) 'In eello6_graph2'
8295         do iii=1,2
8296           write (2,*) 'iii=',iii
8297           do kkk=1,5
8298             write (2,*) 'kkk=',kkk
8299             do jjj=1,2
8300               write (2,'(3(2f10.5),5x)')
8301      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8302             enddo
8303           enddo
8304         enddo
8305       endif
8306       do iii=1,2
8307         do kkk=1,5
8308           do lll=1,3
8309 #ifdef MOMENT
8310             if (iii.eq.1) then
8311               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8312             else
8313               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8314             endif
8315 #endif
8316             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8317      &        auxvec(1))
8318             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8319             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8320      &        auxvec(1))
8321             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8322             call transpose2(EUg(1,1,k),auxmat(1,1))
8323             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8324      &        pizda(1,1))
8325             vv(1)=pizda(1,1)-pizda(2,2)
8326             vv(2)=pizda(1,2)+pizda(2,1)
8327             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8328 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8329 #ifdef MOMENT
8330             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8331 #else
8332             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8333 #endif
8334             if (swap) then
8335               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8336             else
8337               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8338             endif
8339           enddo
8340         enddo
8341       enddo
8342       return
8343       end
8344 c----------------------------------------------------------------------------
8345       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8346       implicit real*8 (a-h,o-z)
8347       include 'DIMENSIONS'
8348       include 'COMMON.IOUNITS'
8349       include 'COMMON.CHAIN'
8350       include 'COMMON.DERIV'
8351       include 'COMMON.INTERACT'
8352       include 'COMMON.CONTACTS'
8353 #ifdef MOMENT
8354       include 'COMMON.CONTACTS.MOMENT'
8355 #endif
8356       include 'COMMON.TORSION'
8357       include 'COMMON.VAR'
8358       include 'COMMON.GEO'
8359       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8360       logical swap
8361 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8362 C                                                                              C
8363 C      Parallel       Antiparallel                                             C
8364 C                                                                              C
8365 C          o             o                                                     C
8366 C         /l\   /   \   /j\                                                    C
8367 C        /   \ /     \ /   \                                                   C
8368 C       /| o |o       o| o |\                                                  C
8369 C       j|/k\|  /      |/k\|l /                                                C
8370 C        /   \ /       /   \ /                                                 C
8371 C       /     o       /     o                                                  C
8372 C       i             i                                                        C
8373 C                                                                              C
8374 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8375 C
8376 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8377 C           energy moment and not to the cluster cumulant.
8378       iti=itortyp(itype(i))
8379       if (j.lt.nres-1) then
8380         itj1=itortyp(itype(j+1))
8381       else
8382         itj1=ntortyp+1
8383       endif
8384       itk=itortyp(itype(k))
8385       itk1=itortyp(itype(k+1))
8386       if (l.lt.nres-1) then
8387         itl1=itortyp(itype(l+1))
8388       else
8389         itl1=ntortyp+1
8390       endif
8391 #ifdef MOMENT
8392       s1=dip(4,jj,i)*dip(4,kk,k)
8393 #endif
8394       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8395       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8396       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8397       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8398       call transpose2(EE(1,1,itk),auxmat(1,1))
8399       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8400       vv(1)=pizda(1,1)+pizda(2,2)
8401       vv(2)=pizda(2,1)-pizda(1,2)
8402       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8403 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8404 cd     & "sum",-(s2+s3+s4)
8405 #ifdef MOMENT
8406       eello6_graph3=-(s1+s2+s3+s4)
8407 #else
8408       eello6_graph3=-(s2+s3+s4)
8409 #endif
8410 c      eello6_graph3=-s4
8411 C Derivatives in gamma(k-1)
8412       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8413       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8414       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8415       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8416 C Derivatives in gamma(l-1)
8417       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8418       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8419       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8420       vv(1)=pizda(1,1)+pizda(2,2)
8421       vv(2)=pizda(2,1)-pizda(1,2)
8422       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8423       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8424 C Cartesian derivatives.
8425       do iii=1,2
8426         do kkk=1,5
8427           do lll=1,3
8428 #ifdef MOMENT
8429             if (iii.eq.1) then
8430               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8431             else
8432               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8433             endif
8434 #endif
8435             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8436      &        auxvec(1))
8437             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8438             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8439      &        auxvec(1))
8440             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8441             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8442      &        pizda(1,1))
8443             vv(1)=pizda(1,1)+pizda(2,2)
8444             vv(2)=pizda(2,1)-pizda(1,2)
8445             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8446 #ifdef MOMENT
8447             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8448 #else
8449             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8450 #endif
8451             if (swap) then
8452               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8453             else
8454               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8455             endif
8456 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8457           enddo
8458         enddo
8459       enddo
8460       return
8461       end
8462 c----------------------------------------------------------------------------
8463       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8464       implicit real*8 (a-h,o-z)
8465       include 'DIMENSIONS'
8466       include 'COMMON.IOUNITS'
8467       include 'COMMON.CHAIN'
8468       include 'COMMON.DERIV'
8469       include 'COMMON.INTERACT'
8470       include 'COMMON.CONTACTS'
8471 #ifdef MOMENT
8472       include 'COMMON.CONTACTS.MOMENT'
8473 #endif
8474       include 'COMMON.TORSION'
8475       include 'COMMON.VAR'
8476       include 'COMMON.GEO'
8477       include 'COMMON.FFIELD'
8478       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8479      & auxvec1(2),auxmat1(2,2)
8480       logical swap
8481 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8482 C                                                                              C
8483 C      Parallel       Antiparallel                                             C
8484 C                                                                              C
8485 C          o             o                                                     C
8486 C         /l\   /   \   /j\                                                    C
8487 C        /   \ /     \ /   \                                                   C
8488 C       /| o |o       o| o |\                                                  C
8489 C     \ j|/k\|      \  |/k\|l                                                  C
8490 C      \ /   \       \ /   \                                                   C
8491 C       o     \       o     \                                                  C
8492 C       i             i                                                        C
8493 C                                                                              C
8494 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8495 C
8496 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8497 C           energy moment and not to the cluster cumulant.
8498 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8499       iti=itortyp(itype(i))
8500       itj=itortyp(itype(j))
8501       if (j.lt.nres-1) then
8502         itj1=itortyp(itype(j+1))
8503       else
8504         itj1=ntortyp+1
8505       endif
8506       itk=itortyp(itype(k))
8507       if (k.lt.nres-1) then
8508         itk1=itortyp(itype(k+1))
8509       else
8510         itk1=ntortyp+1
8511       endif
8512       itl=itortyp(itype(l))
8513       if (l.lt.nres-1) then
8514         itl1=itortyp(itype(l+1))
8515       else
8516         itl1=ntortyp+1
8517       endif
8518 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8519 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8520 cd     & ' itl',itl,' itl1',itl1
8521 #ifdef MOMENT
8522       if (imat.eq.1) then
8523         s1=dip(3,jj,i)*dip(3,kk,k)
8524       else
8525         s1=dip(2,jj,j)*dip(2,kk,l)
8526       endif
8527 #endif
8528       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8529       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8530       if (j.eq.l+1) then
8531         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8532         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8533       else
8534         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8535         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8536       endif
8537       call transpose2(EUg(1,1,k),auxmat(1,1))
8538       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8539       vv(1)=pizda(1,1)-pizda(2,2)
8540       vv(2)=pizda(2,1)+pizda(1,2)
8541       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8542 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8543 #ifdef MOMENT
8544       eello6_graph4=-(s1+s2+s3+s4)
8545 #else
8546       eello6_graph4=-(s2+s3+s4)
8547 #endif
8548 C Derivatives in gamma(i-1)
8549       if (i.gt.1) then
8550 #ifdef MOMENT
8551         if (imat.eq.1) then
8552           s1=dipderg(2,jj,i)*dip(3,kk,k)
8553         else
8554           s1=dipderg(4,jj,j)*dip(2,kk,l)
8555         endif
8556 #endif
8557         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8558         if (j.eq.l+1) then
8559           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8560           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8561         else
8562           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8563           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8564         endif
8565         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8566         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8567 cd          write (2,*) 'turn6 derivatives'
8568 #ifdef MOMENT
8569           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8570 #else
8571           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8572 #endif
8573         else
8574 #ifdef MOMENT
8575           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8576 #else
8577           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8578 #endif
8579         endif
8580       endif
8581 C Derivatives in gamma(k-1)
8582 #ifdef MOMENT
8583       if (imat.eq.1) then
8584         s1=dip(3,jj,i)*dipderg(2,kk,k)
8585       else
8586         s1=dip(2,jj,j)*dipderg(4,kk,l)
8587       endif
8588 #endif
8589       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8590       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8591       if (j.eq.l+1) then
8592         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8593         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8594       else
8595         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8596         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8597       endif
8598       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8599       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8600       vv(1)=pizda(1,1)-pizda(2,2)
8601       vv(2)=pizda(2,1)+pizda(1,2)
8602       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8603       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8604 #ifdef MOMENT
8605         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8606 #else
8607         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8608 #endif
8609       else
8610 #ifdef MOMENT
8611         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8612 #else
8613         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8614 #endif
8615       endif
8616 C Derivatives in gamma(j-1) or gamma(l-1)
8617       if (l.eq.j+1 .and. l.gt.1) then
8618         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8619         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8620         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8621         vv(1)=pizda(1,1)-pizda(2,2)
8622         vv(2)=pizda(2,1)+pizda(1,2)
8623         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8624         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8625       else if (j.gt.1) then
8626         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8627         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8628         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8629         vv(1)=pizda(1,1)-pizda(2,2)
8630         vv(2)=pizda(2,1)+pizda(1,2)
8631         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8632         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8633           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8634         else
8635           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8636         endif
8637       endif
8638 C Cartesian derivatives.
8639       do iii=1,2
8640         do kkk=1,5
8641           do lll=1,3
8642 #ifdef MOMENT
8643             if (iii.eq.1) then
8644               if (imat.eq.1) then
8645                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8646               else
8647                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8648               endif
8649             else
8650               if (imat.eq.1) then
8651                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8652               else
8653                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8654               endif
8655             endif
8656 #endif
8657             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8658      &        auxvec(1))
8659             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8660             if (j.eq.l+1) then
8661               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8662      &          b1(1,itj1),auxvec(1))
8663               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8664             else
8665               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8666      &          b1(1,itl1),auxvec(1))
8667               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8668             endif
8669             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8670      &        pizda(1,1))
8671             vv(1)=pizda(1,1)-pizda(2,2)
8672             vv(2)=pizda(2,1)+pizda(1,2)
8673             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8674             if (swap) then
8675               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8676 #ifdef MOMENT
8677                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8678      &             -(s1+s2+s4)
8679 #else
8680                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8681      &             -(s2+s4)
8682 #endif
8683                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8684               else
8685 #ifdef MOMENT
8686                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8687 #else
8688                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8689 #endif
8690                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8691               endif
8692             else
8693 #ifdef MOMENT
8694               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8695 #else
8696               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8697 #endif
8698               if (l.eq.j+1) then
8699                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8700               else
8701                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8702               endif
8703             endif
8704           enddo
8705         enddo
8706       enddo
8707       return
8708       end
8709 c----------------------------------------------------------------------------
8710       double precision function eello_turn6(i,jj,kk)
8711       implicit real*8 (a-h,o-z)
8712       include 'DIMENSIONS'
8713       include 'COMMON.IOUNITS'
8714       include 'COMMON.CHAIN'
8715       include 'COMMON.DERIV'
8716       include 'COMMON.INTERACT'
8717       include 'COMMON.CONTACTS'
8718 #ifdef MOMENT
8719       include 'COMMON.CONTACTS.MOMENT'
8720 #endif
8721       include 'COMMON.TORSION'
8722       include 'COMMON.VAR'
8723       include 'COMMON.GEO'
8724       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8725      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8726      &  ggg1(3),ggg2(3)
8727       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8728      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8729 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8730 C           the respective energy moment and not to the cluster cumulant.
8731       s1=0.0d0
8732       s8=0.0d0
8733       s13=0.0d0
8734 c
8735       eello_turn6=0.0d0
8736       j=i+4
8737       k=i+1
8738       l=i+3
8739       iti=itortyp(itype(i))
8740       itk=itortyp(itype(k))
8741       itk1=itortyp(itype(k+1))
8742       itl=itortyp(itype(l))
8743       itj=itortyp(itype(j))
8744 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8745 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8746 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8747 cd        eello6=0.0d0
8748 cd        return
8749 cd      endif
8750 cd      write (iout,*)
8751 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8752 cd     &   ' and',k,l
8753 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8754       do iii=1,2
8755         do kkk=1,5
8756           do lll=1,3
8757             derx_turn(lll,kkk,iii)=0.0d0
8758           enddo
8759         enddo
8760       enddo
8761 cd      eij=1.0d0
8762 cd      ekl=1.0d0
8763 cd      ekont=1.0d0
8764       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8765 cd      eello6_5=0.0d0
8766 cd      write (2,*) 'eello6_5',eello6_5
8767 #ifdef MOMENT
8768       call transpose2(AEA(1,1,1),auxmat(1,1))
8769       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8770       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8771       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8772 #endif
8773       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8774       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8775       s2 = scalar2(b1(1,itk),vtemp1(1))
8776 #ifdef MOMENT
8777       call transpose2(AEA(1,1,2),atemp(1,1))
8778       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8779       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8780       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8781 #endif
8782       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8783       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8784       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8785 #ifdef MOMENT
8786       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8787       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8788       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8789       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8790       ss13 = scalar2(b1(1,itk),vtemp4(1))
8791       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8792 #endif
8793 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8794 c      s1=0.0d0
8795 c      s2=0.0d0
8796 c      s8=0.0d0
8797 c      s12=0.0d0
8798 c      s13=0.0d0
8799       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8800 C Derivatives in gamma(i+2)
8801       s1d =0.0d0
8802       s8d =0.0d0
8803 #ifdef MOMENT
8804       call transpose2(AEA(1,1,1),auxmatd(1,1))
8805       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8806       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8807       call transpose2(AEAderg(1,1,2),atempd(1,1))
8808       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8809       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8810 #endif
8811       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),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       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8820 C Derivatives in gamma(i+3)
8821 #ifdef MOMENT
8822       call transpose2(AEA(1,1,1),auxmatd(1,1))
8823       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8824       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8825       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8826 #endif
8827       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8828       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8829       s2d = scalar2(b1(1,itk),vtemp1d(1))
8830 #ifdef MOMENT
8831       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8832       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8833 #endif
8834       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8835 #ifdef MOMENT
8836       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8837       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8838       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8839 #endif
8840 c      s1d=0.0d0
8841 c      s2d=0.0d0
8842 c      s8d=0.0d0
8843 c      s12d=0.0d0
8844 c      s13d=0.0d0
8845 #ifdef MOMENT
8846       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8847      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8848 #else
8849       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8850      &               -0.5d0*ekont*(s2d+s12d)
8851 #endif
8852 C Derivatives in gamma(i+4)
8853       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8854       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8855       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8856 #ifdef MOMENT
8857       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8858       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8859       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8860 #endif
8861 c      s1d=0.0d0
8862 c      s2d=0.0d0
8863 c      s8d=0.0d0
8864 C      s12d=0.0d0
8865 c      s13d=0.0d0
8866 #ifdef MOMENT
8867       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8868 #else
8869       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8870 #endif
8871 C Derivatives in gamma(i+5)
8872 #ifdef MOMENT
8873       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8874       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8875       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8876 #endif
8877       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8878       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8879       s2d = scalar2(b1(1,itk),vtemp1d(1))
8880 #ifdef MOMENT
8881       call transpose2(AEA(1,1,2),atempd(1,1))
8882       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8883       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8884 #endif
8885       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8886       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8887 #ifdef MOMENT
8888       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8889       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8890       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8891 #endif
8892 c      s1d=0.0d0
8893 c      s2d=0.0d0
8894 c      s8d=0.0d0
8895 c      s12d=0.0d0
8896 c      s13d=0.0d0
8897 #ifdef MOMENT
8898       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8899      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8900 #else
8901       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8902      &               -0.5d0*ekont*(s2d+s12d)
8903 #endif
8904 C Cartesian derivatives
8905       do iii=1,2
8906         do kkk=1,5
8907           do lll=1,3
8908 #ifdef MOMENT
8909             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8910             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8911             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8912 #endif
8913             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8914             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8915      &          vtemp1d(1))
8916             s2d = scalar2(b1(1,itk),vtemp1d(1))
8917 #ifdef MOMENT
8918             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8919             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8920             s8d = -(atempd(1,1)+atempd(2,2))*
8921      &           scalar2(cc(1,1,itl),vtemp2(1))
8922 #endif
8923             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8924      &           auxmatd(1,1))
8925             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8926             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8927 c      s1d=0.0d0
8928 c      s2d=0.0d0
8929 c      s8d=0.0d0
8930 c      s12d=0.0d0
8931 c      s13d=0.0d0
8932 #ifdef MOMENT
8933             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8934      &        - 0.5d0*(s1d+s2d)
8935 #else
8936             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8937      &        - 0.5d0*s2d
8938 #endif
8939 #ifdef MOMENT
8940             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8941      &        - 0.5d0*(s8d+s12d)
8942 #else
8943             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8944      &        - 0.5d0*s12d
8945 #endif
8946           enddo
8947         enddo
8948       enddo
8949 #ifdef MOMENT
8950       do kkk=1,5
8951         do lll=1,3
8952           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8953      &      achuj_tempd(1,1))
8954           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8955           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8956           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8957           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8958           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8959      &      vtemp4d(1))
8960           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8961           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8962           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8963         enddo
8964       enddo
8965 #endif
8966 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8967 cd     &  16*eel_turn6_num
8968 cd      goto 1112
8969       if (j.lt.nres-1) then
8970         j1=j+1
8971         j2=j-1
8972       else
8973         j1=j-1
8974         j2=j-2
8975       endif
8976       if (l.lt.nres-1) then
8977         l1=l+1
8978         l2=l-1
8979       else
8980         l1=l-1
8981         l2=l-2
8982       endif
8983       do ll=1,3
8984 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8985 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8986 cgrad        ghalf=0.5d0*ggg1(ll)
8987 cd        ghalf=0.0d0
8988         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8989         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8990         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8991      &    +ekont*derx_turn(ll,2,1)
8992         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8993         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8994      &    +ekont*derx_turn(ll,4,1)
8995         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8996         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8997         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8998 cgrad        ghalf=0.5d0*ggg2(ll)
8999 cd        ghalf=0.0d0
9000         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9001      &    +ekont*derx_turn(ll,2,2)
9002         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9003         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9004      &    +ekont*derx_turn(ll,4,2)
9005         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9006         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9007         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9008       enddo
9009 cd      goto 1112
9010 cgrad      do m=i+1,j-1
9011 cgrad        do ll=1,3
9012 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9013 cgrad        enddo
9014 cgrad      enddo
9015 cgrad      do m=k+1,l-1
9016 cgrad        do ll=1,3
9017 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9018 cgrad        enddo
9019 cgrad      enddo
9020 cgrad1112  continue
9021 cgrad      do m=i+2,j2
9022 cgrad        do ll=1,3
9023 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9024 cgrad        enddo
9025 cgrad      enddo
9026 cgrad      do m=k+2,l2
9027 cgrad        do ll=1,3
9028 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9029 cgrad        enddo
9030 cgrad      enddo
9031 cd      do iii=1,nres-3
9032 cd        write (2,*) iii,g_corr6_loc(iii)
9033 cd      enddo
9034       eello_turn6=ekont*eel_turn6
9035 cd      write (2,*) 'ekont',ekont
9036 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9037       return
9038       end
9039
9040 C-----------------------------------------------------------------------------
9041       double precision function scalar(u,v)
9042 !DIR$ INLINEALWAYS scalar
9043 #ifndef OSF
9044 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9045 #endif
9046       implicit none
9047       double precision u(3),v(3)
9048 cd      double precision sc
9049 cd      integer i
9050 cd      sc=0.0d0
9051 cd      do i=1,3
9052 cd        sc=sc+u(i)*v(i)
9053 cd      enddo
9054 cd      scalar=sc
9055
9056       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9057       return
9058       end
9059 crc-------------------------------------------------
9060       SUBROUTINE MATVEC2(A1,V1,V2)
9061 !DIR$ INLINEALWAYS MATVEC2
9062 #ifndef OSF
9063 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9064 #endif
9065       implicit real*8 (a-h,o-z)
9066       include 'DIMENSIONS'
9067       DIMENSION A1(2,2),V1(2),V2(2)
9068 c      DO 1 I=1,2
9069 c        VI=0.0
9070 c        DO 3 K=1,2
9071 c    3     VI=VI+A1(I,K)*V1(K)
9072 c        Vaux(I)=VI
9073 c    1 CONTINUE
9074
9075       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9076       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9077
9078       v2(1)=vaux1
9079       v2(2)=vaux2
9080       END
9081 C---------------------------------------
9082       SUBROUTINE MATMAT2(A1,A2,A3)
9083 #ifndef OSF
9084 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9085 #endif
9086       implicit real*8 (a-h,o-z)
9087       include 'DIMENSIONS'
9088       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9089 c      DIMENSION AI3(2,2)
9090 c        DO  J=1,2
9091 c          A3IJ=0.0
9092 c          DO K=1,2
9093 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9094 c          enddo
9095 c          A3(I,J)=A3IJ
9096 c       enddo
9097 c      enddo
9098
9099       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9100       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9101       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9102       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9103
9104       A3(1,1)=AI3_11
9105       A3(2,1)=AI3_21
9106       A3(1,2)=AI3_12
9107       A3(2,2)=AI3_22
9108       END
9109
9110 c-------------------------------------------------------------------------
9111       double precision function scalar2(u,v)
9112 !DIR$ INLINEALWAYS scalar2
9113       implicit none
9114       double precision u(2),v(2)
9115       double precision sc
9116       integer i
9117       scalar2=u(1)*v(1)+u(2)*v(2)
9118       return
9119       end
9120
9121 C-----------------------------------------------------------------------------
9122
9123       subroutine transpose2(a,at)
9124 !DIR$ INLINEALWAYS transpose2
9125 #ifndef OSF
9126 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9127 #endif
9128       implicit none
9129       double precision a(2,2),at(2,2)
9130       at(1,1)=a(1,1)
9131       at(1,2)=a(2,1)
9132       at(2,1)=a(1,2)
9133       at(2,2)=a(2,2)
9134       return
9135       end
9136 c--------------------------------------------------------------------------
9137       subroutine transpose(n,a,at)
9138       implicit none
9139       integer n,i,j
9140       double precision a(n,n),at(n,n)
9141       do i=1,n
9142         do j=1,n
9143           at(j,i)=a(i,j)
9144         enddo
9145       enddo
9146       return
9147       end
9148 C---------------------------------------------------------------------------
9149       subroutine prodmat3(a1,a2,kk,transp,prod)
9150 !DIR$ INLINEALWAYS prodmat3
9151 #ifndef OSF
9152 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9153 #endif
9154       implicit none
9155       integer i,j
9156       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9157       logical transp
9158 crc      double precision auxmat(2,2),prod_(2,2)
9159
9160       if (transp) then
9161 crc        call transpose2(kk(1,1),auxmat(1,1))
9162 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9163 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9164
9165            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9166      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9167            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9168      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9169            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9170      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9171            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9172      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9173
9174       else
9175 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9176 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9177
9178            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9179      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9180            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9181      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9182            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9183      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9184            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9185      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9186
9187       endif
9188 c      call transpose2(a2(1,1),a2t(1,1))
9189
9190 crc      print *,transp
9191 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9192 crc      print *,((prod(i,j),i=1,2),j=1,2)
9193
9194       return
9195       end
9196