source/unres/src_CSA/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       call edfad(edfadis)
 129 c      print*, 'edfad is finished!', edfadis
 130       call edfat(edfator)
 131 c      print*, 'edfat is finished!', edfator
 132       call edfan(edfanei)
 133 c      print*, 'edfan is finished!', edfanei
 134       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       dimension gg(3)
1086 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1087       evdw=0.0D0
1088       do i=iatsc_s,iatsc_e
1089         itypi=itype(i)
1090         itypi1=itype(i+1)
1091         xi=c(1,nres+i)
1092         yi=c(2,nres+i)
1093         zi=c(3,nres+i)
1094 C Change 12/1/95
1095         num_conti=0
1096 C
1097 C Calculate SC interaction energy.
1098 C
1099         do iint=1,nint_gr(i)
1100 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1101 cd   &                  'iend=',iend(i,iint)
1102           do j=istart(i,iint),iend(i,iint)
1103             itypj=itype(j)
1104             xj=c(1,nres+j)-xi
1105             yj=c(2,nres+j)-yi
1106             zj=c(3,nres+j)-zi
1107 C Change 12/1/95 to calculate four-body interactions
1108             rij=xj*xj+yj*yj+zj*zj
1109             rrij=1.0D0/rij
1110 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1111             eps0ij=eps(itypi,itypj)
1112             fac=rrij**expon2
1113             e1=fac*fac*aa(itypi,itypj)
1114             e2=fac*bb(itypi,itypj)
1115             evdwij=e1+e2
1116 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1117 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1118 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1119 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1120 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1121 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1122 #ifdef TSCSC
1123             if (bb(itypi,itypj).gt.0) then
1124                evdw_p=evdw_p+evdwij
1125             else
1126                evdw_m=evdw_m+evdwij
1127             endif
1128 #else
1129             evdw=evdw+evdwij
1130 #endif
1131 C
1132 C Calculate the components of the gradient in DC and X
1133 C
1134             fac=-rrij*(e1+evdwij)
1135             gg(1)=xj*fac
1136             gg(2)=yj*fac
1137             gg(3)=zj*fac
1138 #ifdef TSCSC
1139             if (bb(itypi,itypj).gt.0.0d0) then
1140               do k=1,3
1141                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1142                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1143                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1144                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1145               enddo
1146             else
1147               do k=1,3
1148                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1149                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1150                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1151                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1152               enddo
1153             endif
1154 #else
1155             do k=1,3
1156               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1157               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1158               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1159               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1160             enddo
1161 #endif
1162 cgrad            do k=i,j-1
1163 cgrad              do l=1,3
1164 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1165 cgrad              enddo
1166 cgrad            enddo
1167 C
1168 C 12/1/95, revised on 5/20/97
1169 C
1170 C Calculate the contact function. The ith column of the array JCONT will
1171 C contain the numbers of atoms that make contacts with the atom I (of numbers
1172 C greater than I). The arrays FACONT and GACONT will contain the values of
1173 C the contact function and its derivative.
1174 C
1175 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1176 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1177 C Uncomment next line, if the correlation interactions are contact function only
1178             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1179               rij=dsqrt(rij)
1180               sigij=sigma(itypi,itypj)
1181               r0ij=rs0(itypi,itypj)
1182 C
1183 C Check whether the SC's are not too far to make a contact.
1184 C
1185               rcut=1.5d0*r0ij
1186               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1187 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1188 C
1189               if (fcont.gt.0.0D0) then
1190 C If the SC-SC distance if close to sigma, apply spline.
1191 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1192 cAdam &             fcont1,fprimcont1)
1193 cAdam           fcont1=1.0d0-fcont1
1194 cAdam           if (fcont1.gt.0.0d0) then
1195 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1196 cAdam             fcont=fcont*fcont1
1197 cAdam           endif
1198 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1199 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1200 cga             do k=1,3
1201 cga               gg(k)=gg(k)*eps0ij
1202 cga             enddo
1203 cga             eps0ij=-evdwij*eps0ij
1204 C Uncomment for AL's type of SC correlation interactions.
1205 cadam           eps0ij=-evdwij
1206                 num_conti=num_conti+1
1207                 jcont(num_conti,i)=j
1208                 facont(num_conti,i)=fcont*eps0ij
1209                 fprimcont=eps0ij*fprimcont/rij
1210                 fcont=expon*fcont
1211 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1212 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1213 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1214 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1215                 gacont(1,num_conti,i)=-fprimcont*xj
1216                 gacont(2,num_conti,i)=-fprimcont*yj
1217                 gacont(3,num_conti,i)=-fprimcont*zj
1218 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1219 cd              write (iout,'(2i3,3f10.5)')
1220 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1221               endif
1222             endif
1223           enddo      ! j
1224         enddo        ! iint
1225 C Change 12/1/95
1226         num_cont(i)=num_conti
1227       enddo          ! i
1228       do i=1,nct
1229         do j=1,3
1230           gvdwc(j,i)=expon*gvdwc(j,i)
1231           gvdwx(j,i)=expon*gvdwx(j,i)
1232         enddo
1233       enddo
1234 C******************************************************************************
1235 C
1236 C                              N O T E !!!
1237 C
1238 C To save time, the factor of EXPON has been extracted from ALL components
1239 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1240 C use!
1241 C
1242 C******************************************************************************
1243       return
1244       end
1245 C-----------------------------------------------------------------------------
1246       subroutine eljk(evdw,evdw_p,evdw_m)
1247 C
1248 C This subroutine calculates the interaction energy of nonbonded side chains
1249 C assuming the LJK potential of interaction.
1250 C
1251       implicit real*8 (a-h,o-z)
1252       include 'DIMENSIONS'
1253       include 'COMMON.GEO'
1254       include 'COMMON.VAR'
1255       include 'COMMON.LOCAL'
1256       include 'COMMON.CHAIN'
1257       include 'COMMON.DERIV'
1258       include 'COMMON.INTERACT'
1259       include 'COMMON.IOUNITS'
1260       include 'COMMON.NAMES'
1261       dimension gg(3)
1262       logical scheck
1263 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1264       evdw=0.0D0
1265       do i=iatsc_s,iatsc_e
1266         itypi=itype(i)
1267         itypi1=itype(i+1)
1268         xi=c(1,nres+i)
1269         yi=c(2,nres+i)
1270         zi=c(3,nres+i)
1271 C
1272 C Calculate SC interaction energy.
1273 C
1274         do iint=1,nint_gr(i)
1275           do j=istart(i,iint),iend(i,iint)
1276             itypj=itype(j)
1277             xj=c(1,nres+j)-xi
1278             yj=c(2,nres+j)-yi
1279             zj=c(3,nres+j)-zi
1280             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1281             fac_augm=rrij**expon
1282             e_augm=augm(itypi,itypj)*fac_augm
1283             r_inv_ij=dsqrt(rrij)
1284             rij=1.0D0/r_inv_ij
1285             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1286             fac=r_shift_inv**expon
1287             e1=fac*fac*aa(itypi,itypj)
1288             e2=fac*bb(itypi,itypj)
1289             evdwij=e_augm+e1+e2
1290 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1291 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1292 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1293 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1294 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1295 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1296 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1297 #ifdef TSCSC
1298             if (bb(itypi,itypj).gt.0) then
1299                evdw_p=evdw_p+evdwij
1300             else
1301                evdw_m=evdw_m+evdwij
1302             endif
1303 #else
1304             evdw=evdw+evdwij
1305 #endif
1306 C
1307 C Calculate the components of the gradient in DC and X
1308 C
1309             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1310             gg(1)=xj*fac
1311             gg(2)=yj*fac
1312             gg(3)=zj*fac
1313 #ifdef TSCSC
1314             if (bb(itypi,itypj).gt.0.0d0) then
1315               do k=1,3
1316                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1317                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1318                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1319                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1320               enddo
1321             else
1322               do k=1,3
1323                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1324                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1325                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1326                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1327               enddo
1328             endif
1329 #else
1330             do k=1,3
1331               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1332               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1333               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1334               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1335             enddo
1336 #endif
1337 cgrad            do k=i,j-1
1338 cgrad              do l=1,3
1339 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1340 cgrad              enddo
1341 cgrad            enddo
1342           enddo      ! j
1343         enddo        ! iint
1344       enddo          ! i
1345       do i=1,nct
1346         do j=1,3
1347           gvdwc(j,i)=expon*gvdwc(j,i)
1348           gvdwx(j,i)=expon*gvdwx(j,i)
1349         enddo
1350       enddo
1351       return
1352       end
1353 C-----------------------------------------------------------------------------
1354       subroutine ebp(evdw,evdw_p,evdw_m)
1355 C
1356 C This subroutine calculates the interaction energy of nonbonded side chains
1357 C assuming the Berne-Pechukas potential of interaction.
1358 C
1359       implicit real*8 (a-h,o-z)
1360       include 'DIMENSIONS'
1361       include 'COMMON.GEO'
1362       include 'COMMON.VAR'
1363       include 'COMMON.LOCAL'
1364       include 'COMMON.CHAIN'
1365       include 'COMMON.DERIV'
1366       include 'COMMON.NAMES'
1367       include 'COMMON.INTERACT'
1368       include 'COMMON.IOUNITS'
1369       include 'COMMON.CALC'
1370       common /srutu/ icall
1371 c     double precision rrsave(maxdim)
1372       logical lprn
1373       evdw=0.0D0
1374 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1375       evdw=0.0D0
1376 c     if (icall.eq.0) then
1377 c       lprn=.true.
1378 c     else
1379         lprn=.false.
1380 c     endif
1381       ind=0
1382       do i=iatsc_s,iatsc_e
1383         itypi=itype(i)
1384         itypi1=itype(i+1)
1385         xi=c(1,nres+i)
1386         yi=c(2,nres+i)
1387         zi=c(3,nres+i)
1388         dxi=dc_norm(1,nres+i)
1389         dyi=dc_norm(2,nres+i)
1390         dzi=dc_norm(3,nres+i)
1391 c        dsci_inv=dsc_inv(itypi)
1392         dsci_inv=vbld_inv(i+nres)
1393 C
1394 C Calculate SC interaction energy.
1395 C
1396         do iint=1,nint_gr(i)
1397           do j=istart(i,iint),iend(i,iint)
1398             ind=ind+1
1399             itypj=itype(j)
1400 c            dscj_inv=dsc_inv(itypj)
1401             dscj_inv=vbld_inv(j+nres)
1402             chi1=chi(itypi,itypj)
1403             chi2=chi(itypj,itypi)
1404             chi12=chi1*chi2
1405             chip1=chip(itypi)
1406             chip2=chip(itypj)
1407             chip12=chip1*chip2
1408             alf1=alp(itypi)
1409             alf2=alp(itypj)
1410             alf12=0.5D0*(alf1+alf2)
1411 C For diagnostics only!!!
1412 c           chi1=0.0D0
1413 c           chi2=0.0D0
1414 c           chi12=0.0D0
1415 c           chip1=0.0D0
1416 c           chip2=0.0D0
1417 c           chip12=0.0D0
1418 c           alf1=0.0D0
1419 c           alf2=0.0D0
1420 c           alf12=0.0D0
1421             xj=c(1,nres+j)-xi
1422             yj=c(2,nres+j)-yi
1423             zj=c(3,nres+j)-zi
1424             dxj=dc_norm(1,nres+j)
1425             dyj=dc_norm(2,nres+j)
1426             dzj=dc_norm(3,nres+j)
1427             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1428 cd          if (icall.eq.0) then
1429 cd            rrsave(ind)=rrij
1430 cd          else
1431 cd            rrij=rrsave(ind)
1432 cd          endif
1433             rij=dsqrt(rrij)
1434 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1435             call sc_angular
1436 C Calculate whole angle-dependent part of epsilon and contributions
1437 C to its derivatives
1438             fac=(rrij*sigsq)**expon2
1439             e1=fac*fac*aa(itypi,itypj)
1440             e2=fac*bb(itypi,itypj)
1441             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1442             eps2der=evdwij*eps3rt
1443             eps3der=evdwij*eps2rt
1444             evdwij=evdwij*eps2rt*eps3rt
1445 #ifdef TSCSC
1446             if (bb(itypi,itypj).gt.0) then
1447                evdw_p=evdw_p+evdwij
1448             else
1449                evdw_m=evdw_m+evdwij
1450             endif
1451 #else
1452             evdw=evdw+evdwij
1453 #endif
1454             if (lprn) then
1455             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1456             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1457 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1458 cd     &        restyp(itypi),i,restyp(itypj),j,
1459 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1460 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1461 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1462 cd     &        evdwij
1463             endif
1464 C Calculate gradient components.
1465             e1=e1*eps1*eps2rt**2*eps3rt**2
1466             fac=-expon*(e1+evdwij)
1467             sigder=fac/sigsq
1468             fac=rrij*fac
1469 C Calculate radial part of the gradient
1470             gg(1)=xj*fac
1471             gg(2)=yj*fac
1472             gg(3)=zj*fac
1473 C Calculate the angular part of the gradient and sum add the contributions
1474 C to the appropriate components of the Cartesian gradient.
1475 #ifdef TSCSC
1476             if (bb(itypi,itypj).gt.0) then
1477                call sc_grad
1478             else
1479                call sc_grad_T
1480             endif
1481 #else
1482             call sc_grad
1483 #endif
1484           enddo      ! j
1485         enddo        ! iint
1486       enddo          ! i
1487 c     stop
1488       return
1489       end
1490 C-----------------------------------------------------------------------------
1491       subroutine egb(evdw,evdw_p,evdw_m)
1492 C
1493 C This subroutine calculates the interaction energy of nonbonded side chains
1494 C assuming the Gay-Berne potential of interaction.
1495 C
1496       implicit real*8 (a-h,o-z)
1497       include 'DIMENSIONS'
1498       include 'COMMON.GEO'
1499       include 'COMMON.VAR'
1500       include 'COMMON.LOCAL'
1501       include 'COMMON.CHAIN'
1502       include 'COMMON.DERIV'
1503       include 'COMMON.NAMES'
1504       include 'COMMON.INTERACT'
1505       include 'COMMON.IOUNITS'
1506       include 'COMMON.CALC'
1507       include 'COMMON.CONTROL'
1508       logical lprn
1509       evdw=0.0D0
1510 ccccc      energy_dec=.false.
1511 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1512       evdw=0.0D0
1513       evdw_p=0.0D0
1514       evdw_m=0.0D0
1515       lprn=.false.
1516 c     if (icall.eq.0) lprn=.false.
1517       ind=0
1518       do i=iatsc_s,iatsc_e
1519         itypi=itype(i)
1520         itypi1=itype(i+1)
1521         xi=c(1,nres+i)
1522         yi=c(2,nres+i)
1523         zi=c(3,nres+i)
1524         dxi=dc_norm(1,nres+i)
1525         dyi=dc_norm(2,nres+i)
1526         dzi=dc_norm(3,nres+i)
1527 c        dsci_inv=dsc_inv(itypi)
1528         dsci_inv=vbld_inv(i+nres)
1529 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1530 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1531 C
1532 C Calculate SC interaction energy.
1533 C
1534         do iint=1,nint_gr(i)
1535           do j=istart(i,iint),iend(i,iint)
1536             ind=ind+1
1537             itypj=itype(j)
1538 c            dscj_inv=dsc_inv(itypj)
1539             dscj_inv=vbld_inv(j+nres)
1540 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1541 c     &       1.0d0/vbld(j+nres)
1542 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1543             sig0ij=sigma(itypi,itypj)
1544             chi1=chi(itypi,itypj)
1545             chi2=chi(itypj,itypi)
1546             chi12=chi1*chi2
1547             chip1=chip(itypi)
1548             chip2=chip(itypj)
1549             chip12=chip1*chip2
1550             alf1=alp(itypi)
1551             alf2=alp(itypj)
1552             alf12=0.5D0*(alf1+alf2)
1553 C For diagnostics only!!!
1554 c           chi1=0.0D0
1555 c           chi2=0.0D0
1556 c           chi12=0.0D0
1557 c           chip1=0.0D0
1558 c           chip2=0.0D0
1559 c           chip12=0.0D0
1560 c           alf1=0.0D0
1561 c           alf2=0.0D0
1562 c           alf12=0.0D0
1563             xj=c(1,nres+j)-xi
1564             yj=c(2,nres+j)-yi
1565             zj=c(3,nres+j)-zi
1566             dxj=dc_norm(1,nres+j)
1567             dyj=dc_norm(2,nres+j)
1568             dzj=dc_norm(3,nres+j)
1569 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1570 c            write (iout,*) "j",j," dc_norm",
1571 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1572             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1573             rij=dsqrt(rrij)
1574 C Calculate angle-dependent terms of energy and contributions to their
1575 C derivatives.
1576             call sc_angular
1577             sigsq=1.0D0/sigsq
1578             sig=sig0ij*dsqrt(sigsq)
1579             rij_shift=1.0D0/rij-sig+sig0ij
1580 c for diagnostics; uncomment
1581 c            rij_shift=1.2*sig0ij
1582 C I hate to put IF's in the loops, but here don't have another choice!!!!
1583             if (rij_shift.le.0.0D0) then
1584               evdw=1.0D20
1585 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1586 cd     &        restyp(itypi),i,restyp(itypj),j,
1587 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1588               return
1589             endif
1590             sigder=-sig*sigsq
1591 c---------------------------------------------------------------
1592             rij_shift=1.0D0/rij_shift
1593             fac=rij_shift**expon
1594             e1=fac*fac*aa(itypi,itypj)
1595             e2=fac*bb(itypi,itypj)
1596             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597             eps2der=evdwij*eps3rt
1598             eps3der=evdwij*eps2rt
1599 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1600 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1601             evdwij=evdwij*eps2rt*eps3rt
1602 #ifdef TSCSC
1603             if (bb(itypi,itypj).gt.0) then
1604                evdw_p=evdw_p+evdwij
1605             else
1606                evdw_m=evdw_m+evdwij
1607             endif
1608 #else
1609             evdw=evdw+evdwij
1610 #endif
1611             if (lprn) then
1612             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1613             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1614             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1615      &        restyp(itypi),i,restyp(itypj),j,
1616      &        epsi,sigm,chi1,chi2,chip1,chip2,
1617      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1618      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1619      &        evdwij
1620             endif
1621
1622             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1623      &                        'evdw',i,j,evdwij
1624
1625 C Calculate gradient components.
1626             e1=e1*eps1*eps2rt**2*eps3rt**2
1627             fac=-expon*(e1+evdwij)*rij_shift
1628             sigder=fac*sigder
1629             fac=rij*fac
1630 c            fac=0.0d0
1631 C Calculate the radial part of the gradient
1632             gg(1)=xj*fac
1633             gg(2)=yj*fac
1634             gg(3)=zj*fac
1635 C Calculate angular part of the gradient.
1636 #ifdef TSCSC
1637             if (bb(itypi,itypj).gt.0) then
1638                call sc_grad
1639             else
1640                call sc_grad_T
1641             endif
1642 #else
1643             call sc_grad
1644 #endif
1645           enddo      ! j
1646         enddo        ! iint
1647       enddo          ! i
1648 c      write (iout,*) "Number of loop steps in EGB:",ind
1649 cccc      energy_dec=.false.
1650       return
1651       end
1652 C-----------------------------------------------------------------------------
1653       subroutine egbv(evdw,evdw_p,evdw_m)
1654 C
1655 C This subroutine calculates the interaction energy of nonbonded side chains
1656 C assuming the Gay-Berne-Vorobjev potential of interaction.
1657 C
1658       implicit real*8 (a-h,o-z)
1659       include 'DIMENSIONS'
1660       include 'COMMON.GEO'
1661       include 'COMMON.VAR'
1662       include 'COMMON.LOCAL'
1663       include 'COMMON.CHAIN'
1664       include 'COMMON.DERIV'
1665       include 'COMMON.NAMES'
1666       include 'COMMON.INTERACT'
1667       include 'COMMON.IOUNITS'
1668       include 'COMMON.CALC'
1669       common /srutu/ icall
1670       logical lprn
1671       evdw=0.0D0
1672 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1673       evdw=0.0D0
1674       lprn=.false.
1675 c     if (icall.eq.0) lprn=.true.
1676       ind=0
1677       do i=iatsc_s,iatsc_e
1678         itypi=itype(i)
1679         itypi1=itype(i+1)
1680         xi=c(1,nres+i)
1681         yi=c(2,nres+i)
1682         zi=c(3,nres+i)
1683         dxi=dc_norm(1,nres+i)
1684         dyi=dc_norm(2,nres+i)
1685         dzi=dc_norm(3,nres+i)
1686 c        dsci_inv=dsc_inv(itypi)
1687         dsci_inv=vbld_inv(i+nres)
1688 C
1689 C Calculate SC interaction energy.
1690 C
1691         do iint=1,nint_gr(i)
1692           do j=istart(i,iint),iend(i,iint)
1693             ind=ind+1
1694             itypj=itype(j)
1695 c            dscj_inv=dsc_inv(itypj)
1696             dscj_inv=vbld_inv(j+nres)
1697             sig0ij=sigma(itypi,itypj)
1698             r0ij=r0(itypi,itypj)
1699             chi1=chi(itypi,itypj)
1700             chi2=chi(itypj,itypi)
1701             chi12=chi1*chi2
1702             chip1=chip(itypi)
1703             chip2=chip(itypj)
1704             chip12=chip1*chip2
1705             alf1=alp(itypi)
1706             alf2=alp(itypj)
1707             alf12=0.5D0*(alf1+alf2)
1708 C For diagnostics only!!!
1709 c           chi1=0.0D0
1710 c           chi2=0.0D0
1711 c           chi12=0.0D0
1712 c           chip1=0.0D0
1713 c           chip2=0.0D0
1714 c           chip12=0.0D0
1715 c           alf1=0.0D0
1716 c           alf2=0.0D0
1717 c           alf12=0.0D0
1718             xj=c(1,nres+j)-xi
1719             yj=c(2,nres+j)-yi
1720             zj=c(3,nres+j)-zi
1721             dxj=dc_norm(1,nres+j)
1722             dyj=dc_norm(2,nres+j)
1723             dzj=dc_norm(3,nres+j)
1724             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1725             rij=dsqrt(rrij)
1726 C Calculate angle-dependent terms of energy and contributions to their
1727 C derivatives.
1728             call sc_angular
1729             sigsq=1.0D0/sigsq
1730             sig=sig0ij*dsqrt(sigsq)
1731             rij_shift=1.0D0/rij-sig+r0ij
1732 C I hate to put IF's in the loops, but here don't have another choice!!!!
1733             if (rij_shift.le.0.0D0) then
1734               evdw=1.0D20
1735               return
1736             endif
1737             sigder=-sig*sigsq
1738 c---------------------------------------------------------------
1739             rij_shift=1.0D0/rij_shift
1740             fac=rij_shift**expon
1741             e1=fac*fac*aa(itypi,itypj)
1742             e2=fac*bb(itypi,itypj)
1743             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1744             eps2der=evdwij*eps3rt
1745             eps3der=evdwij*eps2rt
1746             fac_augm=rrij**expon
1747             e_augm=augm(itypi,itypj)*fac_augm
1748             evdwij=evdwij*eps2rt*eps3rt
1749 #ifdef TSCSC
1750             if (bb(itypi,itypj).gt.0) then
1751                evdw_p=evdw_p+evdwij+e_augm
1752             else
1753                evdw_m=evdw_m+evdwij+e_augm
1754             endif
1755 #else
1756             evdw=evdw+evdwij+e_augm
1757 #endif
1758             if (lprn) then
1759             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1760             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1761             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1762      &        restyp(itypi),i,restyp(itypj),j,
1763      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1764      &        chi1,chi2,chip1,chip2,
1765      &        eps1,eps2rt**2,eps3rt**2,
1766      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1767      &        evdwij+e_augm
1768             endif
1769 C Calculate gradient components.
1770             e1=e1*eps1*eps2rt**2*eps3rt**2
1771             fac=-expon*(e1+evdwij)*rij_shift
1772             sigder=fac*sigder
1773             fac=rij*fac-2*expon*rrij*e_augm
1774 C Calculate the radial part of the gradient
1775             gg(1)=xj*fac
1776             gg(2)=yj*fac
1777             gg(3)=zj*fac
1778 C Calculate angular part of the gradient.
1779 #ifdef TSCSC
1780             if (bb(itypi,itypj).gt.0) then
1781                call sc_grad
1782             else
1783                call sc_grad_T
1784             endif
1785 #else
1786             call sc_grad
1787 #endif
1788           enddo      ! j
1789         enddo        ! iint
1790       enddo          ! i
1791       end
1792 C-----------------------------------------------------------------------------
1793       subroutine sc_angular
1794 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1795 C om12. Called by ebp, egb, and egbv.
1796       implicit none
1797       include 'COMMON.CALC'
1798       include 'COMMON.IOUNITS'
1799       erij(1)=xj*rij
1800       erij(2)=yj*rij
1801       erij(3)=zj*rij
1802       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1803       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1804       om12=dxi*dxj+dyi*dyj+dzi*dzj
1805       chiom12=chi12*om12
1806 C Calculate eps1(om12) and its derivative in om12
1807       faceps1=1.0D0-om12*chiom12
1808       faceps1_inv=1.0D0/faceps1
1809       eps1=dsqrt(faceps1_inv)
1810 C Following variable is eps1*deps1/dom12
1811       eps1_om12=faceps1_inv*chiom12
1812 c diagnostics only
1813 c      faceps1_inv=om12
1814 c      eps1=om12
1815 c      eps1_om12=1.0d0
1816 c      write (iout,*) "om12",om12," eps1",eps1
1817 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1818 C and om12.
1819       om1om2=om1*om2
1820       chiom1=chi1*om1
1821       chiom2=chi2*om2
1822       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1823       sigsq=1.0D0-facsig*faceps1_inv
1824       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1825       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1826       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1827 c diagnostics only
1828 c      sigsq=1.0d0
1829 c      sigsq_om1=0.0d0
1830 c      sigsq_om2=0.0d0
1831 c      sigsq_om12=0.0d0
1832 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1833 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1834 c     &    " eps1",eps1
1835 C Calculate eps2 and its derivatives in om1, om2, and om12.
1836       chipom1=chip1*om1
1837       chipom2=chip2*om2
1838       chipom12=chip12*om12
1839       facp=1.0D0-om12*chipom12
1840       facp_inv=1.0D0/facp
1841       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1842 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1843 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1844 C Following variable is the square root of eps2
1845       eps2rt=1.0D0-facp1*facp_inv
1846 C Following three variables are the derivatives of the square root of eps
1847 C in om1, om2, and om12.
1848       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1849       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1850       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1851 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1852       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1853 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1854 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1855 c     &  " eps2rt_om12",eps2rt_om12
1856 C Calculate whole angle-dependent part of epsilon and contributions
1857 C to its derivatives
1858       return
1859       end
1860
1861 C----------------------------------------------------------------------------
1862       subroutine sc_grad_T
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'COMMON.CHAIN'
1866       include 'COMMON.DERIV'
1867       include 'COMMON.CALC'
1868       include 'COMMON.IOUNITS'
1869       double precision dcosom1(3),dcosom2(3)
1870       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1871       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1872       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1873      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1874 c diagnostics only
1875 c      eom1=0.0d0
1876 c      eom2=0.0d0
1877 c      eom12=evdwij*eps1_om12
1878 c end diagnostics
1879 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1880 c     &  " sigder",sigder
1881 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1882 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1883       do k=1,3
1884         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1885         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1886       enddo
1887       do k=1,3
1888         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1889       enddo
1890 c      write (iout,*) "gg",(gg(k),k=1,3)
1891       do k=1,3
1892         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1893      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1894      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1895         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1896      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1897      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1898 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1899 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1900 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1901 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1902       enddo
1903 C
1904 C Calculate the components of the gradient in DC and X
1905 C
1906 cgrad      do k=i,j-1
1907 cgrad        do l=1,3
1908 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1909 cgrad        enddo
1910 cgrad      enddo
1911       do l=1,3
1912         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1913         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1914       enddo
1915       return
1916       end
1917
1918 C----------------------------------------------------------------------------
1919       subroutine sc_grad
1920       implicit real*8 (a-h,o-z)
1921       include 'DIMENSIONS'
1922       include 'COMMON.CHAIN'
1923       include 'COMMON.DERIV'
1924       include 'COMMON.CALC'
1925       include 'COMMON.IOUNITS'
1926       double precision dcosom1(3),dcosom2(3)
1927       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1928       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1929       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1930      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1931 c diagnostics only
1932 c      eom1=0.0d0
1933 c      eom2=0.0d0
1934 c      eom12=evdwij*eps1_om12
1935 c end diagnostics
1936 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1937 c     &  " sigder",sigder
1938 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1939 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1940       do k=1,3
1941         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1942         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1943       enddo
1944       do k=1,3
1945         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1946       enddo
1947 c      write (iout,*) "gg",(gg(k),k=1,3)
1948       do k=1,3
1949         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1950      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1951      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1952         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1953      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1954      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1955 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1956 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1957 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1958 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1959       enddo
1960 C
1961 C Calculate the components of the gradient in DC and X
1962 C
1963 cgrad      do k=i,j-1
1964 cgrad        do l=1,3
1965 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1966 cgrad        enddo
1967 cgrad      enddo
1968       do l=1,3
1969         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1970         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1971       enddo
1972       return
1973       end
1974 C-----------------------------------------------------------------------
1975       subroutine e_softsphere(evdw)
1976 C
1977 C This subroutine calculates the interaction energy of nonbonded side chains
1978 C assuming the LJ potential of interaction.
1979 C
1980       implicit real*8 (a-h,o-z)
1981       include 'DIMENSIONS'
1982       parameter (accur=1.0d-10)
1983       include 'COMMON.GEO'
1984       include 'COMMON.VAR'
1985       include 'COMMON.LOCAL'
1986       include 'COMMON.CHAIN'
1987       include 'COMMON.DERIV'
1988       include 'COMMON.INTERACT'
1989       include 'COMMON.TORSION'
1990       include 'COMMON.SBRIDGE'
1991       include 'COMMON.NAMES'
1992       include 'COMMON.IOUNITS'
1993       include 'COMMON.CONTACTS'
1994       dimension gg(3)
1995 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1996       evdw=0.0D0
1997       do i=iatsc_s,iatsc_e
1998         itypi=itype(i)
1999         itypi1=itype(i+1)
2000         xi=c(1,nres+i)
2001         yi=c(2,nres+i)
2002         zi=c(3,nres+i)
2003 C
2004 C Calculate SC interaction energy.
2005 C
2006         do iint=1,nint_gr(i)
2007 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2008 cd   &                  'iend=',iend(i,iint)
2009           do j=istart(i,iint),iend(i,iint)
2010             itypj=itype(j)
2011             xj=c(1,nres+j)-xi
2012             yj=c(2,nres+j)-yi
2013             zj=c(3,nres+j)-zi
2014             rij=xj*xj+yj*yj+zj*zj
2015 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2016             r0ij=r0(itypi,itypj)
2017             r0ijsq=r0ij*r0ij
2018 c            print *,i,j,r0ij,dsqrt(rij)
2019             if (rij.lt.r0ijsq) then
2020               evdwij=0.25d0*(rij-r0ijsq)**2
2021               fac=rij-r0ijsq
2022             else
2023               evdwij=0.0d0
2024               fac=0.0d0
2025             endif
2026             evdw=evdw+evdwij
2027 C
2028 C Calculate the components of the gradient in DC and X
2029 C
2030             gg(1)=xj*fac
2031             gg(2)=yj*fac
2032             gg(3)=zj*fac
2033             do k=1,3
2034               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2035               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2036               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2037               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2038             enddo
2039 cgrad            do k=i,j-1
2040 cgrad              do l=1,3
2041 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2042 cgrad              enddo
2043 cgrad            enddo
2044           enddo ! j
2045         enddo ! iint
2046       enddo ! i
2047       return
2048       end
2049 C--------------------------------------------------------------------------
2050       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2051      &              eello_turn4)
2052 C
2053 C Soft-sphere potential of p-p interaction
2054 C
2055       implicit real*8 (a-h,o-z)
2056       include 'DIMENSIONS'
2057       include 'COMMON.CONTROL'
2058       include 'COMMON.IOUNITS'
2059       include 'COMMON.GEO'
2060       include 'COMMON.VAR'
2061       include 'COMMON.LOCAL'
2062       include 'COMMON.CHAIN'
2063       include 'COMMON.DERIV'
2064       include 'COMMON.INTERACT'
2065       include 'COMMON.CONTACTS'
2066       include 'COMMON.TORSION'
2067       include 'COMMON.VECTORS'
2068       include 'COMMON.FFIELD'
2069       dimension ggg(3)
2070 cd      write(iout,*) 'In EELEC_soft_sphere'
2071       ees=0.0D0
2072       evdw1=0.0D0
2073       eel_loc=0.0d0
2074       eello_turn3=0.0d0
2075       eello_turn4=0.0d0
2076       ind=0
2077       do i=iatel_s,iatel_e
2078         dxi=dc(1,i)
2079         dyi=dc(2,i)
2080         dzi=dc(3,i)
2081         xmedi=c(1,i)+0.5d0*dxi
2082         ymedi=c(2,i)+0.5d0*dyi
2083         zmedi=c(3,i)+0.5d0*dzi
2084         num_conti=0
2085 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2086         do j=ielstart(i),ielend(i)
2087           ind=ind+1
2088           iteli=itel(i)
2089           itelj=itel(j)
2090           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2091           r0ij=rpp(iteli,itelj)
2092           r0ijsq=r0ij*r0ij
2093           dxj=dc(1,j)
2094           dyj=dc(2,j)
2095           dzj=dc(3,j)
2096           xj=c(1,j)+0.5D0*dxj-xmedi
2097           yj=c(2,j)+0.5D0*dyj-ymedi
2098           zj=c(3,j)+0.5D0*dzj-zmedi
2099           rij=xj*xj+yj*yj+zj*zj
2100           if (rij.lt.r0ijsq) then
2101             evdw1ij=0.25d0*(rij-r0ijsq)**2
2102             fac=rij-r0ijsq
2103           else
2104             evdw1ij=0.0d0
2105             fac=0.0d0
2106           endif
2107           evdw1=evdw1+evdw1ij
2108 C
2109 C Calculate contributions to the Cartesian gradient.
2110 C
2111           ggg(1)=fac*xj
2112           ggg(2)=fac*yj
2113           ggg(3)=fac*zj
2114           do k=1,3
2115             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2116             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2117           enddo
2118 *
2119 * Loop over residues i+1 thru j-1.
2120 *
2121 cgrad          do k=i+1,j-1
2122 cgrad            do l=1,3
2123 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2124 cgrad            enddo
2125 cgrad          enddo
2126         enddo ! j
2127       enddo   ! i
2128 cgrad      do i=nnt,nct-1
2129 cgrad        do k=1,3
2130 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2131 cgrad        enddo
2132 cgrad        do j=i+1,nct-1
2133 cgrad          do k=1,3
2134 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2135 cgrad          enddo
2136 cgrad        enddo
2137 cgrad      enddo
2138       return
2139       end
2140 c------------------------------------------------------------------------------
2141       subroutine vec_and_deriv
2142       implicit real*8 (a-h,o-z)
2143       include 'DIMENSIONS'
2144 #ifdef MPI
2145       include 'mpif.h'
2146 #endif
2147       include 'COMMON.IOUNITS'
2148       include 'COMMON.GEO'
2149       include 'COMMON.VAR'
2150       include 'COMMON.LOCAL'
2151       include 'COMMON.CHAIN'
2152       include 'COMMON.VECTORS'
2153       include 'COMMON.SETUP'
2154       include 'COMMON.TIME1'
2155       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2156 C Compute the local reference systems. For reference system (i), the
2157 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2158 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2159 #ifdef PARVEC
2160       do i=ivec_start,ivec_end
2161 #else
2162       do i=1,nres-1
2163 #endif
2164           if (i.eq.nres-1) then
2165 C Case of the last full residue
2166 C Compute the Z-axis
2167             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2168             costh=dcos(pi-theta(nres))
2169             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2170             do k=1,3
2171               uz(k,i)=fac*uz(k,i)
2172             enddo
2173 C Compute the derivatives of uz
2174             uzder(1,1,1)= 0.0d0
2175             uzder(2,1,1)=-dc_norm(3,i-1)
2176             uzder(3,1,1)= dc_norm(2,i-1)
2177             uzder(1,2,1)= dc_norm(3,i-1)
2178             uzder(2,2,1)= 0.0d0
2179             uzder(3,2,1)=-dc_norm(1,i-1)
2180             uzder(1,3,1)=-dc_norm(2,i-1)
2181             uzder(2,3,1)= dc_norm(1,i-1)
2182             uzder(3,3,1)= 0.0d0
2183             uzder(1,1,2)= 0.0d0
2184             uzder(2,1,2)= dc_norm(3,i)
2185             uzder(3,1,2)=-dc_norm(2,i)
2186             uzder(1,2,2)=-dc_norm(3,i)
2187             uzder(2,2,2)= 0.0d0
2188             uzder(3,2,2)= dc_norm(1,i)
2189             uzder(1,3,2)= dc_norm(2,i)
2190             uzder(2,3,2)=-dc_norm(1,i)
2191             uzder(3,3,2)= 0.0d0
2192 C Compute the Y-axis
2193             facy=fac
2194             do k=1,3
2195               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2196             enddo
2197 C Compute the derivatives of uy
2198             do j=1,3
2199               do k=1,3
2200                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2201      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2202                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2203               enddo
2204               uyder(j,j,1)=uyder(j,j,1)-costh
2205               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2206             enddo
2207             do j=1,2
2208               do k=1,3
2209                 do l=1,3
2210                   uygrad(l,k,j,i)=uyder(l,k,j)
2211                   uzgrad(l,k,j,i)=uzder(l,k,j)
2212                 enddo
2213               enddo
2214             enddo
2215             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2216             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2217             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2218             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2219           else
2220 C Other residues
2221 C Compute the Z-axis
2222             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2223             costh=dcos(pi-theta(i+2))
2224             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2225             do k=1,3
2226               uz(k,i)=fac*uz(k,i)
2227             enddo
2228 C Compute the derivatives of uz
2229             uzder(1,1,1)= 0.0d0
2230             uzder(2,1,1)=-dc_norm(3,i+1)
2231             uzder(3,1,1)= dc_norm(2,i+1)
2232             uzder(1,2,1)= dc_norm(3,i+1)
2233             uzder(2,2,1)= 0.0d0
2234             uzder(3,2,1)=-dc_norm(1,i+1)
2235             uzder(1,3,1)=-dc_norm(2,i+1)
2236             uzder(2,3,1)= dc_norm(1,i+1)
2237             uzder(3,3,1)= 0.0d0
2238             uzder(1,1,2)= 0.0d0
2239             uzder(2,1,2)= dc_norm(3,i)
2240             uzder(3,1,2)=-dc_norm(2,i)
2241             uzder(1,2,2)=-dc_norm(3,i)
2242             uzder(2,2,2)= 0.0d0
2243             uzder(3,2,2)= dc_norm(1,i)
2244             uzder(1,3,2)= dc_norm(2,i)
2245             uzder(2,3,2)=-dc_norm(1,i)
2246             uzder(3,3,2)= 0.0d0
2247 C Compute the Y-axis
2248             facy=fac
2249             do k=1,3
2250               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2251             enddo
2252 C Compute the derivatives of uy
2253             do j=1,3
2254               do k=1,3
2255                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2256      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2257                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2258               enddo
2259               uyder(j,j,1)=uyder(j,j,1)-costh
2260               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2261             enddo
2262             do j=1,2
2263               do k=1,3
2264                 do l=1,3
2265                   uygrad(l,k,j,i)=uyder(l,k,j)
2266                   uzgrad(l,k,j,i)=uzder(l,k,j)
2267                 enddo
2268               enddo
2269             enddo
2270             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2271             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2272             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2273             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2274           endif
2275       enddo
2276       do i=1,nres-1
2277         vbld_inv_temp(1)=vbld_inv(i+1)
2278         if (i.lt.nres-1) then
2279           vbld_inv_temp(2)=vbld_inv(i+2)
2280           else
2281           vbld_inv_temp(2)=vbld_inv(i)
2282           endif
2283         do j=1,2
2284           do k=1,3
2285             do l=1,3
2286               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2287               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2288             enddo
2289           enddo
2290         enddo
2291       enddo
2292 #if defined(PARVEC) && defined(MPI)
2293       if (nfgtasks1.gt.1) then
2294         time00=MPI_Wtime()
2295 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2296 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2297 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2298         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2299      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2300      &   FG_COMM1,IERR)
2301         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2302      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2303      &   FG_COMM1,IERR)
2304         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2305      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2306      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2307         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2308      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2309      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2310         time_gather=time_gather+MPI_Wtime()-time00
2311       endif
2312 c      if (fg_rank.eq.0) then
2313 c        write (iout,*) "Arrays UY and UZ"
2314 c        do i=1,nres-1
2315 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2316 c     &     (uz(k,i),k=1,3)
2317 c        enddo
2318 c      endif
2319 #endif
2320       return
2321       end
2322 C-----------------------------------------------------------------------------
2323       subroutine check_vecgrad
2324       implicit real*8 (a-h,o-z)
2325       include 'DIMENSIONS'
2326       include 'COMMON.IOUNITS'
2327       include 'COMMON.GEO'
2328       include 'COMMON.VAR'
2329       include 'COMMON.LOCAL'
2330       include 'COMMON.CHAIN'
2331       include 'COMMON.VECTORS'
2332       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2333       dimension uyt(3,maxres),uzt(3,maxres)
2334       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2335       double precision delta /1.0d-7/
2336       call vec_and_deriv
2337 cd      do i=1,nres
2338 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2339 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2340 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2341 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2342 cd     &     (dc_norm(if90,i),if90=1,3)
2343 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2344 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2345 cd          write(iout,'(a)')
2346 cd      enddo
2347       do i=1,nres
2348         do j=1,2
2349           do k=1,3
2350             do l=1,3
2351               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2352               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2353             enddo
2354           enddo
2355         enddo
2356       enddo
2357       call vec_and_deriv
2358       do i=1,nres
2359         do j=1,3
2360           uyt(j,i)=uy(j,i)
2361           uzt(j,i)=uz(j,i)
2362         enddo
2363       enddo
2364       do i=1,nres
2365 cd        write (iout,*) 'i=',i
2366         do k=1,3
2367           erij(k)=dc_norm(k,i)
2368         enddo
2369         do j=1,3
2370           do k=1,3
2371             dc_norm(k,i)=erij(k)
2372           enddo
2373           dc_norm(j,i)=dc_norm(j,i)+delta
2374 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2375 c          do k=1,3
2376 c            dc_norm(k,i)=dc_norm(k,i)/fac
2377 c          enddo
2378 c          write (iout,*) (dc_norm(k,i),k=1,3)
2379 c          write (iout,*) (erij(k),k=1,3)
2380           call vec_and_deriv
2381           do k=1,3
2382             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2383             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2384             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2385             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2386           enddo
2387 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2388 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2389 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2390         enddo
2391         do k=1,3
2392           dc_norm(k,i)=erij(k)
2393         enddo
2394 cd        do k=1,3
2395 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2396 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2397 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2398 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2399 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2400 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2401 cd          write (iout,'(a)')
2402 cd        enddo
2403       enddo
2404       return
2405       end
2406 C--------------------------------------------------------------------------
2407       subroutine set_matrices
2408       implicit real*8 (a-h,o-z)
2409       include 'DIMENSIONS'
2410 #ifdef MPI
2411       include "mpif.h"
2412       include "COMMON.SETUP"
2413       integer IERR
2414       integer status(MPI_STATUS_SIZE)
2415 #endif
2416       include 'COMMON.IOUNITS'
2417       include 'COMMON.GEO'
2418       include 'COMMON.VAR'
2419       include 'COMMON.LOCAL'
2420       include 'COMMON.CHAIN'
2421       include 'COMMON.DERIV'
2422       include 'COMMON.INTERACT'
2423       include 'COMMON.CONTACTS'
2424       include 'COMMON.TORSION'
2425       include 'COMMON.VECTORS'
2426       include 'COMMON.FFIELD'
2427       double precision auxvec(2),auxmat(2,2)
2428 C
2429 C Compute the virtual-bond-torsional-angle dependent quantities needed
2430 C to calculate the el-loc multibody terms of various order.
2431 C
2432 #ifdef PARMAT
2433       do i=ivec_start+2,ivec_end+2
2434 #else
2435       do i=3,nres+1
2436 #endif
2437         if (i .lt. nres+1) then
2438           sin1=dsin(phi(i))
2439           cos1=dcos(phi(i))
2440           sintab(i-2)=sin1
2441           costab(i-2)=cos1
2442           obrot(1,i-2)=cos1
2443           obrot(2,i-2)=sin1
2444           sin2=dsin(2*phi(i))
2445           cos2=dcos(2*phi(i))
2446           sintab2(i-2)=sin2
2447           costab2(i-2)=cos2
2448           obrot2(1,i-2)=cos2
2449           obrot2(2,i-2)=sin2
2450           Ug(1,1,i-2)=-cos1
2451           Ug(1,2,i-2)=-sin1
2452           Ug(2,1,i-2)=-sin1
2453           Ug(2,2,i-2)= cos1
2454           Ug2(1,1,i-2)=-cos2
2455           Ug2(1,2,i-2)=-sin2
2456           Ug2(2,1,i-2)=-sin2
2457           Ug2(2,2,i-2)= cos2
2458         else
2459           costab(i-2)=1.0d0
2460           sintab(i-2)=0.0d0
2461           obrot(1,i-2)=1.0d0
2462           obrot(2,i-2)=0.0d0
2463           obrot2(1,i-2)=0.0d0
2464           obrot2(2,i-2)=0.0d0
2465           Ug(1,1,i-2)=1.0d0
2466           Ug(1,2,i-2)=0.0d0
2467           Ug(2,1,i-2)=0.0d0
2468           Ug(2,2,i-2)=1.0d0
2469           Ug2(1,1,i-2)=0.0d0
2470           Ug2(1,2,i-2)=0.0d0
2471           Ug2(2,1,i-2)=0.0d0
2472           Ug2(2,2,i-2)=0.0d0
2473         endif
2474         if (i .gt. 3 .and. i .lt. nres+1) then
2475           obrot_der(1,i-2)=-sin1
2476           obrot_der(2,i-2)= cos1
2477           Ugder(1,1,i-2)= sin1
2478           Ugder(1,2,i-2)=-cos1
2479           Ugder(2,1,i-2)=-cos1
2480           Ugder(2,2,i-2)=-sin1
2481           dwacos2=cos2+cos2
2482           dwasin2=sin2+sin2
2483           obrot2_der(1,i-2)=-dwasin2
2484           obrot2_der(2,i-2)= dwacos2
2485           Ug2der(1,1,i-2)= dwasin2
2486           Ug2der(1,2,i-2)=-dwacos2
2487           Ug2der(2,1,i-2)=-dwacos2
2488           Ug2der(2,2,i-2)=-dwasin2
2489         else
2490           obrot_der(1,i-2)=0.0d0
2491           obrot_der(2,i-2)=0.0d0
2492           Ugder(1,1,i-2)=0.0d0
2493           Ugder(1,2,i-2)=0.0d0
2494           Ugder(2,1,i-2)=0.0d0
2495           Ugder(2,2,i-2)=0.0d0
2496           obrot2_der(1,i-2)=0.0d0
2497           obrot2_der(2,i-2)=0.0d0
2498           Ug2der(1,1,i-2)=0.0d0
2499           Ug2der(1,2,i-2)=0.0d0
2500           Ug2der(2,1,i-2)=0.0d0
2501           Ug2der(2,2,i-2)=0.0d0
2502         endif
2503 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2504         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2505           iti = itortyp(itype(i-2))
2506         else
2507           iti=ntortyp+1
2508         endif
2509 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2510         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2511           iti1 = itortyp(itype(i-1))
2512         else
2513           iti1=ntortyp+1
2514         endif
2515 cd        write (iout,*) '*******i',i,' iti1',iti
2516 cd        write (iout,*) 'b1',b1(:,iti)
2517 cd        write (iout,*) 'b2',b2(:,iti)
2518 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2519 c        if (i .gt. iatel_s+2) then
2520         if (i .gt. nnt+2) then
2521           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2522           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2523           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2524      &    then
2525           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2526           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2527           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2528           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2529           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2530           endif
2531         else
2532           do k=1,2
2533             Ub2(k,i-2)=0.0d0
2534             Ctobr(k,i-2)=0.0d0
2535             Dtobr2(k,i-2)=0.0d0
2536             do l=1,2
2537               EUg(l,k,i-2)=0.0d0
2538               CUg(l,k,i-2)=0.0d0
2539               DUg(l,k,i-2)=0.0d0
2540               DtUg2(l,k,i-2)=0.0d0
2541             enddo
2542           enddo
2543         endif
2544         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2545         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2546         do k=1,2
2547           muder(k,i-2)=Ub2der(k,i-2)
2548         enddo
2549 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2550         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2551           iti1 = itortyp(itype(i-1))
2552         else
2553           iti1=ntortyp+1
2554         endif
2555         do k=1,2
2556           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2557         enddo
2558 cd        write (iout,*) 'mu ',mu(:,i-2)
2559 cd        write (iout,*) 'mu1',mu1(:,i-2)
2560 cd        write (iout,*) 'mu2',mu2(:,i-2)
2561         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2562      &  then
2563         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2564         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2565         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2566         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2567         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2568 C Vectors and matrices dependent on a single virtual-bond dihedral.
2569         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2570         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2571         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2572         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2573         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2574         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2575         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2576         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2577         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2578         endif
2579       enddo
2580 C Matrices dependent on two consecutive virtual-bond dihedrals.
2581 C The order of matrices is from left to right.
2582       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2583      &then
2584 c      do i=max0(ivec_start,2),ivec_end
2585       do i=2,nres-1
2586         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2587         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2588         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2589         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2590         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2591         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2592         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2593         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2594       enddo
2595       endif
2596 #if defined(MPI) && defined(PARMAT)
2597 #ifdef DEBUG
2598 c      if (fg_rank.eq.0) then
2599         write (iout,*) "Arrays UG and UGDER before GATHER"
2600         do i=1,nres-1
2601           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2602      &     ((ug(l,k,i),l=1,2),k=1,2),
2603      &     ((ugder(l,k,i),l=1,2),k=1,2)
2604         enddo
2605         write (iout,*) "Arrays UG2 and UG2DER"
2606         do i=1,nres-1
2607           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2608      &     ((ug2(l,k,i),l=1,2),k=1,2),
2609      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2610         enddo
2611         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2612         do i=1,nres-1
2613           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2614      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2615      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2616         enddo
2617         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2618         do i=1,nres-1
2619           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2620      &     costab(i),sintab(i),costab2(i),sintab2(i)
2621         enddo
2622         write (iout,*) "Array MUDER"
2623         do i=1,nres-1
2624           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2625         enddo
2626 c      endif
2627 #endif
2628       if (nfgtasks.gt.1) then
2629         time00=MPI_Wtime()
2630 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2631 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2632 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2633 #ifdef MATGATHER
2634         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2641      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2642      &   FG_COMM1,IERR)
2643         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2644      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2645      &   FG_COMM1,IERR)
2646         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2653      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2654      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2655         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2656      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2657      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2658         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2659      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2660      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2661         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2662      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2663      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2664         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2665      &  then
2666         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2667      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2668      &   FG_COMM1,IERR)
2669         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2670      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2671      &   FG_COMM1,IERR)
2672         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2673      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2674      &   FG_COMM1,IERR)
2675        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2676      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2677      &   FG_COMM1,IERR)
2678         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2679      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2680      &   FG_COMM1,IERR)
2681         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2682      &   ivec_count(fg_rank1),
2683      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2684      &   FG_COMM1,IERR)
2685         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2686      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2687      &   FG_COMM1,IERR)
2688         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2689      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2690      &   FG_COMM1,IERR)
2691         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2692      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2693      &   FG_COMM1,IERR)
2694         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2695      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2707      &   ivec_count(fg_rank1),
2708      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2712      &   FG_COMM1,IERR)
2713        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2714      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2715      &   FG_COMM1,IERR)
2716         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2717      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2718      &   FG_COMM1,IERR)
2719        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2723      &   ivec_count(fg_rank1),
2724      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2725      &   FG_COMM1,IERR)
2726         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2727      &   ivec_count(fg_rank1),
2728      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2731      &   ivec_count(fg_rank1),
2732      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2733      &   MPI_MAT2,FG_COMM1,IERR)
2734         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2735      &   ivec_count(fg_rank1),
2736      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2737      &   MPI_MAT2,FG_COMM1,IERR)
2738         endif
2739 #else
2740 c Passes matrix info through the ring
2741       isend=fg_rank1
2742       irecv=fg_rank1-1
2743       if (irecv.lt.0) irecv=nfgtasks1-1
2744       iprev=irecv
2745       inext=fg_rank1+1
2746       if (inext.ge.nfgtasks1) inext=0
2747       do i=1,nfgtasks1-1
2748 c        write (iout,*) "isend",isend," irecv",irecv
2749 c        call flush(iout)
2750         lensend=lentyp(isend)
2751         lenrecv=lentyp(irecv)
2752 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2753 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2754 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2755 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2756 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2757 c        write (iout,*) "Gather ROTAT1"
2758 c        call flush(iout)
2759 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2760 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2761 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2762 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2763 c        write (iout,*) "Gather ROTAT2"
2764 c        call flush(iout)
2765         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2766      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2767      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2768      &   iprev,4400+irecv,FG_COMM,status,IERR)
2769 c        write (iout,*) "Gather ROTAT_OLD"
2770 c        call flush(iout)
2771         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2772      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2773      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2774      &   iprev,5500+irecv,FG_COMM,status,IERR)
2775 c        write (iout,*) "Gather PRECOMP11"
2776 c        call flush(iout)
2777         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2778      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2779      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2780      &   iprev,6600+irecv,FG_COMM,status,IERR)
2781 c        write (iout,*) "Gather PRECOMP12"
2782 c        call flush(iout)
2783         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2784      &  then
2785         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2786      &   MPI_ROTAT2(lensend),inext,7700+isend,
2787      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2788      &   iprev,7700+irecv,FG_COMM,status,IERR)
2789 c        write (iout,*) "Gather PRECOMP21"
2790 c        call flush(iout)
2791         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2792      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2793      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2794      &   iprev,8800+irecv,FG_COMM,status,IERR)
2795 c        write (iout,*) "Gather PRECOMP22"
2796 c        call flush(iout)
2797         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2798      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2799      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2800      &   MPI_PRECOMP23(lenrecv),
2801      &   iprev,9900+irecv,FG_COMM,status,IERR)
2802 c        write (iout,*) "Gather PRECOMP23"
2803 c        call flush(iout)
2804         endif
2805         isend=irecv
2806         irecv=irecv-1
2807         if (irecv.lt.0) irecv=nfgtasks1-1
2808       enddo
2809 #endif
2810         time_gather=time_gather+MPI_Wtime()-time00
2811       endif
2812 #ifdef DEBUG
2813 c      if (fg_rank.eq.0) then
2814         write (iout,*) "Arrays UG and UGDER"
2815         do i=1,nres-1
2816           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2817      &     ((ug(l,k,i),l=1,2),k=1,2),
2818      &     ((ugder(l,k,i),l=1,2),k=1,2)
2819         enddo
2820         write (iout,*) "Arrays UG2 and UG2DER"
2821         do i=1,nres-1
2822           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2823      &     ((ug2(l,k,i),l=1,2),k=1,2),
2824      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2825         enddo
2826         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2827         do i=1,nres-1
2828           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2829      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2830      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2831         enddo
2832         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2833         do i=1,nres-1
2834           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2835      &     costab(i),sintab(i),costab2(i),sintab2(i)
2836         enddo
2837         write (iout,*) "Array MUDER"
2838         do i=1,nres-1
2839           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2840         enddo
2841 c      endif
2842 #endif
2843 #endif
2844 cd      do i=1,nres
2845 cd        iti = itortyp(itype(i))
2846 cd        write (iout,*) i
2847 cd        do j=1,2
2848 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2849 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2850 cd        enddo
2851 cd      enddo
2852       return
2853       end
2854 C--------------------------------------------------------------------------
2855       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2856 C
2857 C This subroutine calculates the average interaction energy and its gradient
2858 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2859 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2860 C The potential depends both on the distance of peptide-group centers and on
2861 C the orientation of the CA-CA virtual bonds.
2862 C
2863       implicit real*8 (a-h,o-z)
2864 #ifdef MPI
2865       include 'mpif.h'
2866 #endif
2867       include 'DIMENSIONS'
2868       include 'COMMON.CONTROL'
2869       include 'COMMON.SETUP'
2870       include 'COMMON.IOUNITS'
2871       include 'COMMON.GEO'
2872       include 'COMMON.VAR'
2873       include 'COMMON.LOCAL'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.INTERACT'
2877       include 'COMMON.CONTACTS'
2878       include 'COMMON.TORSION'
2879       include 'COMMON.VECTORS'
2880       include 'COMMON.FFIELD'
2881       include 'COMMON.TIME1'
2882       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2883      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2884       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2885      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2886       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2887      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2888      &    num_conti,j1,j2
2889 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2890 #ifdef MOMENT
2891       double precision scal_el /1.0d0/
2892 #else
2893       double precision scal_el /0.5d0/
2894 #endif
2895 C 12/13/98
2896 C 13-go grudnia roku pamietnego...
2897       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2898      &                   0.0d0,1.0d0,0.0d0,
2899      &                   0.0d0,0.0d0,1.0d0/
2900 cd      write(iout,*) 'In EELEC'
2901 cd      do i=1,nloctyp
2902 cd        write(iout,*) 'Type',i
2903 cd        write(iout,*) 'B1',B1(:,i)
2904 cd        write(iout,*) 'B2',B2(:,i)
2905 cd        write(iout,*) 'CC',CC(:,:,i)
2906 cd        write(iout,*) 'DD',DD(:,:,i)
2907 cd        write(iout,*) 'EE',EE(:,:,i)
2908 cd      enddo
2909 cd      call check_vecgrad
2910 cd      stop
2911       if (icheckgrad.eq.1) then
2912         do i=1,nres-1
2913           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2914           do k=1,3
2915             dc_norm(k,i)=dc(k,i)*fac
2916           enddo
2917 c          write (iout,*) 'i',i,' fac',fac
2918         enddo
2919       endif
2920       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2921      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2922      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2923 c        call vec_and_deriv
2924 #ifdef TIMING
2925         time01=MPI_Wtime()
2926 #endif
2927         call set_matrices
2928 #ifdef TIMING
2929         time_mat=time_mat+MPI_Wtime()-time01
2930 #endif
2931       endif
2932 cd      do i=1,nres-1
2933 cd        write (iout,*) 'i=',i
2934 cd        do k=1,3
2935 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2936 cd        enddo
2937 cd        do k=1,3
2938 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2939 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2940 cd        enddo
2941 cd      enddo
2942       t_eelecij=0.0d0
2943       ees=0.0D0
2944       evdw1=0.0D0
2945       eel_loc=0.0d0
2946       eello_turn3=0.0d0
2947       eello_turn4=0.0d0
2948       ind=0
2949       do i=1,nres
2950         num_cont_hb(i)=0
2951       enddo
2952 cd      print '(a)','Enter EELEC'
2953 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2954       do i=1,nres
2955         gel_loc_loc(i)=0.0d0
2956         gcorr_loc(i)=0.0d0
2957       enddo
2958 c
2959 c
2960 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2961 C
2962 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2963 C
2964       do i=iturn3_start,iturn3_end
2965         dxi=dc(1,i)
2966         dyi=dc(2,i)
2967         dzi=dc(3,i)
2968         dx_normi=dc_norm(1,i)
2969         dy_normi=dc_norm(2,i)
2970         dz_normi=dc_norm(3,i)
2971         xmedi=c(1,i)+0.5d0*dxi
2972         ymedi=c(2,i)+0.5d0*dyi
2973         zmedi=c(3,i)+0.5d0*dzi
2974         num_conti=0
2975         call eelecij(i,i+2,ees,evdw1,eel_loc)
2976         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2977         num_cont_hb(i)=num_conti
2978       enddo
2979       do i=iturn4_start,iturn4_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=num_cont_hb(i)
2990         call eelecij(i,i+3,ees,evdw1,eel_loc)
2991         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2992         num_cont_hb(i)=num_conti
2993       enddo   ! i
2994 c
2995 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2996 c
2997       do i=iatel_s,iatel_e
2998         dxi=dc(1,i)
2999         dyi=dc(2,i)
3000         dzi=dc(3,i)
3001         dx_normi=dc_norm(1,i)
3002         dy_normi=dc_norm(2,i)
3003         dz_normi=dc_norm(3,i)
3004         xmedi=c(1,i)+0.5d0*dxi
3005         ymedi=c(2,i)+0.5d0*dyi
3006         zmedi=c(3,i)+0.5d0*dzi
3007 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3008         num_conti=num_cont_hb(i)
3009         do j=ielstart(i),ielend(i)
3010           call eelecij(i,j,ees,evdw1,eel_loc)
3011         enddo ! j
3012         num_cont_hb(i)=num_conti
3013       enddo   ! i
3014 c      write (iout,*) "Number of loop steps in EELEC:",ind
3015 cd      do i=1,nres
3016 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3017 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3018 cd      enddo
3019 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3020 ccc      eel_loc=eel_loc+eello_turn3
3021 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3022       return
3023       end
3024 C-------------------------------------------------------------------------------
3025       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3026       implicit real*8 (a-h,o-z)
3027       include 'DIMENSIONS'
3028 #ifdef MPI
3029       include "mpif.h"
3030 #endif
3031       include 'COMMON.CONTROL'
3032       include 'COMMON.IOUNITS'
3033       include 'COMMON.GEO'
3034       include 'COMMON.VAR'
3035       include 'COMMON.LOCAL'
3036       include 'COMMON.CHAIN'
3037       include 'COMMON.DERIV'
3038       include 'COMMON.INTERACT'
3039       include 'COMMON.CONTACTS'
3040       include 'COMMON.TORSION'
3041       include 'COMMON.VECTORS'
3042       include 'COMMON.FFIELD'
3043       include 'COMMON.TIME1'
3044       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3045      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3046       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3047      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3048       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3049      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3050      &    num_conti,j1,j2
3051 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3052 #ifdef MOMENT
3053       double precision scal_el /1.0d0/
3054 #else
3055       double precision scal_el /0.5d0/
3056 #endif
3057 C 12/13/98
3058 C 13-go grudnia roku pamietnego...
3059       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3060      &                   0.0d0,1.0d0,0.0d0,
3061      &                   0.0d0,0.0d0,1.0d0/
3062 c          time00=MPI_Wtime()
3063 cd      write (iout,*) "eelecij",i,j
3064 c          ind=ind+1
3065           iteli=itel(i)
3066           itelj=itel(j)
3067           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3068           aaa=app(iteli,itelj)
3069           bbb=bpp(iteli,itelj)
3070           ael6i=ael6(iteli,itelj)
3071           ael3i=ael3(iteli,itelj)
3072           dxj=dc(1,j)
3073           dyj=dc(2,j)
3074           dzj=dc(3,j)
3075           dx_normj=dc_norm(1,j)
3076           dy_normj=dc_norm(2,j)
3077           dz_normj=dc_norm(3,j)
3078           xj=c(1,j)+0.5D0*dxj-xmedi
3079           yj=c(2,j)+0.5D0*dyj-ymedi
3080           zj=c(3,j)+0.5D0*dzj-zmedi
3081           rij=xj*xj+yj*yj+zj*zj
3082           rrmij=1.0D0/rij
3083           rij=dsqrt(rij)
3084           rmij=1.0D0/rij
3085           r3ij=rrmij*rmij
3086           r6ij=r3ij*r3ij
3087           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3088           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3089           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3090           fac=cosa-3.0D0*cosb*cosg
3091           ev1=aaa*r6ij*r6ij
3092 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3093           if (j.eq.i+2) ev1=scal_el*ev1
3094           ev2=bbb*r6ij
3095           fac3=ael6i*r6ij
3096           fac4=ael3i*r3ij
3097           evdwij=ev1+ev2
3098           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3099           el2=fac4*fac
3100           eesij=el1+el2
3101 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3102           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3103           ees=ees+eesij
3104           evdw1=evdw1+evdwij
3105 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3106 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3107 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3108 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3109
3110           if (energy_dec) then
3111               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3112               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3113           endif
3114
3115 C
3116 C Calculate contributions to the Cartesian gradient.
3117 C
3118 #ifdef SPLITELE
3119           facvdw=-6*rrmij*(ev1+evdwij)
3120           facel=-3*rrmij*(el1+eesij)
3121           fac1=fac
3122           erij(1)=xj*rmij
3123           erij(2)=yj*rmij
3124           erij(3)=zj*rmij
3125 *
3126 * Radial derivatives. First process both termini of the fragment (i,j)
3127 *
3128           ggg(1)=facel*xj
3129           ggg(2)=facel*yj
3130           ggg(3)=facel*zj
3131 c          do k=1,3
3132 c            ghalf=0.5D0*ggg(k)
3133 c            gelc(k,i)=gelc(k,i)+ghalf
3134 c            gelc(k,j)=gelc(k,j)+ghalf
3135 c          enddo
3136 c 9/28/08 AL Gradient compotents will be summed only at the end
3137           do k=1,3
3138             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3139             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3140           enddo
3141 *
3142 * Loop over residues i+1 thru j-1.
3143 *
3144 cgrad          do k=i+1,j-1
3145 cgrad            do l=1,3
3146 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3147 cgrad            enddo
3148 cgrad          enddo
3149           ggg(1)=facvdw*xj
3150           ggg(2)=facvdw*yj
3151           ggg(3)=facvdw*zj
3152 c          do k=1,3
3153 c            ghalf=0.5D0*ggg(k)
3154 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3155 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3156 c          enddo
3157 c 9/28/08 AL Gradient compotents will be summed only at the end
3158           do k=1,3
3159             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3160             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3161           enddo
3162 *
3163 * Loop over residues i+1 thru j-1.
3164 *
3165 cgrad          do k=i+1,j-1
3166 cgrad            do l=1,3
3167 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3168 cgrad            enddo
3169 cgrad          enddo
3170 #else
3171           facvdw=ev1+evdwij
3172           facel=el1+eesij
3173           fac1=fac
3174           fac=-3*rrmij*(facvdw+facvdw+facel)
3175           erij(1)=xj*rmij
3176           erij(2)=yj*rmij
3177           erij(3)=zj*rmij
3178 *
3179 * Radial derivatives. First process both termini of the fragment (i,j)
3180 *
3181           ggg(1)=fac*xj
3182           ggg(2)=fac*yj
3183           ggg(3)=fac*zj
3184 c          do k=1,3
3185 c            ghalf=0.5D0*ggg(k)
3186 c            gelc(k,i)=gelc(k,i)+ghalf
3187 c            gelc(k,j)=gelc(k,j)+ghalf
3188 c          enddo
3189 c 9/28/08 AL Gradient compotents will be summed only at the end
3190           do k=1,3
3191             gelc_long(k,j)=gelc(k,j)+ggg(k)
3192             gelc_long(k,i)=gelc(k,i)-ggg(k)
3193           enddo
3194 *
3195 * Loop over residues i+1 thru j-1.
3196 *
3197 cgrad          do k=i+1,j-1
3198 cgrad            do l=1,3
3199 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3200 cgrad            enddo
3201 cgrad          enddo
3202 c 9/28/08 AL Gradient compotents will be summed only at the end
3203           ggg(1)=facvdw*xj
3204           ggg(2)=facvdw*yj
3205           ggg(3)=facvdw*zj
3206           do k=1,3
3207             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3208             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3209           enddo
3210 #endif
3211 *
3212 * Angular part
3213 *
3214           ecosa=2.0D0*fac3*fac1+fac4
3215           fac4=-3.0D0*fac4
3216           fac3=-6.0D0*fac3
3217           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3218           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3219           do k=1,3
3220             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3221             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3222           enddo
3223 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3224 cd   &          (dcosg(k),k=1,3)
3225           do k=1,3
3226             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3227           enddo
3228 c          do k=1,3
3229 c            ghalf=0.5D0*ggg(k)
3230 c            gelc(k,i)=gelc(k,i)+ghalf
3231 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3232 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3233 c            gelc(k,j)=gelc(k,j)+ghalf
3234 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3235 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3236 c          enddo
3237 cgrad          do k=i+1,j-1
3238 cgrad            do l=1,3
3239 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3240 cgrad            enddo
3241 cgrad          enddo
3242           do k=1,3
3243             gelc(k,i)=gelc(k,i)
3244      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3245      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3246             gelc(k,j)=gelc(k,j)
3247      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3248      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3249             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3250             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3251           enddo
3252           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3253      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3254      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3255 C
3256 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3257 C   energy of a peptide unit is assumed in the form of a second-order
3258 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3259 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3260 C   are computed for EVERY pair of non-contiguous peptide groups.
3261 C
3262           if (j.lt.nres-1) then
3263             j1=j+1
3264             j2=j-1
3265           else
3266             j1=j-1
3267             j2=j-2
3268           endif
3269           kkk=0
3270           do k=1,2
3271             do l=1,2
3272               kkk=kkk+1
3273               muij(kkk)=mu(k,i)*mu(l,j)
3274             enddo
3275           enddo
3276 cd         write (iout,*) 'EELEC: i',i,' j',j
3277 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3278 cd          write(iout,*) 'muij',muij
3279           ury=scalar(uy(1,i),erij)
3280           urz=scalar(uz(1,i),erij)
3281           vry=scalar(uy(1,j),erij)
3282           vrz=scalar(uz(1,j),erij)
3283           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3284           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3285           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3286           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3287           fac=dsqrt(-ael6i)*r3ij
3288           a22=a22*fac
3289           a23=a23*fac
3290           a32=a32*fac
3291           a33=a33*fac
3292 cd          write (iout,'(4i5,4f10.5)')
3293 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3294 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3295 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3296 cd     &      uy(:,j),uz(:,j)
3297 cd          write (iout,'(4f10.5)')
3298 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3299 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3300 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3301 cd           write (iout,'(9f10.5/)')
3302 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3303 C Derivatives of the elements of A in virtual-bond vectors
3304           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3305           do k=1,3
3306             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3307             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3308             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3309             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3310             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3311             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3312             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3313             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3314             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3315             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3316             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3317             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3318           enddo
3319 C Compute radial contributions to the gradient
3320           facr=-3.0d0*rrmij
3321           a22der=a22*facr
3322           a23der=a23*facr
3323           a32der=a32*facr
3324           a33der=a33*facr
3325           agg(1,1)=a22der*xj
3326           agg(2,1)=a22der*yj
3327           agg(3,1)=a22der*zj
3328           agg(1,2)=a23der*xj
3329           agg(2,2)=a23der*yj
3330           agg(3,2)=a23der*zj
3331           agg(1,3)=a32der*xj
3332           agg(2,3)=a32der*yj
3333           agg(3,3)=a32der*zj
3334           agg(1,4)=a33der*xj
3335           agg(2,4)=a33der*yj
3336           agg(3,4)=a33der*zj
3337 C Add the contributions coming from er
3338           fac3=-3.0d0*fac
3339           do k=1,3
3340             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3341             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3342             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3343             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3344           enddo
3345           do k=1,3
3346 C Derivatives in DC(i)
3347 cgrad            ghalf1=0.5d0*agg(k,1)
3348 cgrad            ghalf2=0.5d0*agg(k,2)
3349 cgrad            ghalf3=0.5d0*agg(k,3)
3350 cgrad            ghalf4=0.5d0*agg(k,4)
3351             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3352      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3353             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3354      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3355             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3356      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3357             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3358      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3359 C Derivatives in DC(i+1)
3360             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3361      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3362             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3363      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3364             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3365      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3366             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3367      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3368 C Derivatives in DC(j)
3369             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3370      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3371             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3372      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3373             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3374      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3375             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3376      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3377 C Derivatives in DC(j+1) or DC(nres-1)
3378             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3379      &      -3.0d0*vryg(k,3)*ury)
3380             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3381      &      -3.0d0*vrzg(k,3)*ury)
3382             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3383      &      -3.0d0*vryg(k,3)*urz)
3384             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3385      &      -3.0d0*vrzg(k,3)*urz)
3386 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3387 cgrad              do l=1,4
3388 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3389 cgrad              enddo
3390 cgrad            endif
3391           enddo
3392           acipa(1,1)=a22
3393           acipa(1,2)=a23
3394           acipa(2,1)=a32
3395           acipa(2,2)=a33
3396           a22=-a22
3397           a23=-a23
3398           do l=1,2
3399             do k=1,3
3400               agg(k,l)=-agg(k,l)
3401               aggi(k,l)=-aggi(k,l)
3402               aggi1(k,l)=-aggi1(k,l)
3403               aggj(k,l)=-aggj(k,l)
3404               aggj1(k,l)=-aggj1(k,l)
3405             enddo
3406           enddo
3407           if (j.lt.nres-1) then
3408             a22=-a22
3409             a32=-a32
3410             do l=1,3,2
3411               do k=1,3
3412                 agg(k,l)=-agg(k,l)
3413                 aggi(k,l)=-aggi(k,l)
3414                 aggi1(k,l)=-aggi1(k,l)
3415                 aggj(k,l)=-aggj(k,l)
3416                 aggj1(k,l)=-aggj1(k,l)
3417               enddo
3418             enddo
3419           else
3420             a22=-a22
3421             a23=-a23
3422             a32=-a32
3423             a33=-a33
3424             do l=1,4
3425               do k=1,3
3426                 agg(k,l)=-agg(k,l)
3427                 aggi(k,l)=-aggi(k,l)
3428                 aggi1(k,l)=-aggi1(k,l)
3429                 aggj(k,l)=-aggj(k,l)
3430                 aggj1(k,l)=-aggj1(k,l)
3431               enddo
3432             enddo
3433           endif
3434           ENDIF ! WCORR
3435           IF (wel_loc.gt.0.0d0) THEN
3436 C Contribution to the local-electrostatic energy coming from the i-j pair
3437           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3438      &     +a33*muij(4)
3439 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3440
3441           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3442      &            'eelloc',i,j,eel_loc_ij
3443
3444           eel_loc=eel_loc+eel_loc_ij
3445 C Partial derivatives in virtual-bond dihedral angles gamma
3446           if (i.gt.1)
3447      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3448      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3449      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3450           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3451      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3452      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3453 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3454           do l=1,3
3455             ggg(l)=agg(l,1)*muij(1)+
3456      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3457             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3458             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3459 cgrad            ghalf=0.5d0*ggg(l)
3460 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3461 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3462           enddo
3463 cgrad          do k=i+1,j2
3464 cgrad            do l=1,3
3465 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3466 cgrad            enddo
3467 cgrad          enddo
3468 C Remaining derivatives of eello
3469           do l=1,3
3470             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3471      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3472             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3473      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3474             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3475      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3476             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3477      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3478           enddo
3479           ENDIF
3480 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3481 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3482           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3483      &       .and. num_conti.le.maxconts) then
3484 c            write (iout,*) i,j," entered corr"
3485 C
3486 C Calculate the contact function. The ith column of the array JCONT will
3487 C contain the numbers of atoms that make contacts with the atom I (of numbers
3488 C greater than I). The arrays FACONT and GACONT will contain the values of
3489 C the contact function and its derivative.
3490 c           r0ij=1.02D0*rpp(iteli,itelj)
3491 c           r0ij=1.11D0*rpp(iteli,itelj)
3492             r0ij=2.20D0*rpp(iteli,itelj)
3493 c           r0ij=1.55D0*rpp(iteli,itelj)
3494             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3495             if (fcont.gt.0.0D0) then
3496               num_conti=num_conti+1
3497               if (num_conti.gt.maxconts) then
3498                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3499      &                         ' will skip next contacts for this conf.'
3500               else
3501                 jcont_hb(num_conti,i)=j
3502 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3503 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3504                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3505      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3506 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3507 C  terms.
3508                 d_cont(num_conti,i)=rij
3509 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3510 C     --- Electrostatic-interaction matrix ---
3511                 a_chuj(1,1,num_conti,i)=a22
3512                 a_chuj(1,2,num_conti,i)=a23
3513                 a_chuj(2,1,num_conti,i)=a32
3514                 a_chuj(2,2,num_conti,i)=a33
3515 C     --- Gradient of rij
3516                 do kkk=1,3
3517                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3518                 enddo
3519                 kkll=0
3520                 do k=1,2
3521                   do l=1,2
3522                     kkll=kkll+1
3523                     do m=1,3
3524                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3525                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3526                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3527                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3528                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3529                     enddo
3530                   enddo
3531                 enddo
3532                 ENDIF
3533                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3534 C Calculate contact energies
3535                 cosa4=4.0D0*cosa
3536                 wij=cosa-3.0D0*cosb*cosg
3537                 cosbg1=cosb+cosg
3538                 cosbg2=cosb-cosg
3539 c               fac3=dsqrt(-ael6i)/r0ij**3
3540                 fac3=dsqrt(-ael6i)*r3ij
3541 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3542                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3543                 if (ees0tmp.gt.0) then
3544                   ees0pij=dsqrt(ees0tmp)
3545                 else
3546                   ees0pij=0
3547                 endif
3548 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3549                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3550                 if (ees0tmp.gt.0) then
3551                   ees0mij=dsqrt(ees0tmp)
3552                 else
3553                   ees0mij=0
3554                 endif
3555 c               ees0mij=0.0D0
3556                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3557                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3558 C Diagnostics. Comment out or remove after debugging!
3559 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3560 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3561 c               ees0m(num_conti,i)=0.0D0
3562 C End diagnostics.
3563 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3564 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3565 C Angular derivatives of the contact function
3566                 ees0pij1=fac3/ees0pij
3567                 ees0mij1=fac3/ees0mij
3568                 fac3p=-3.0D0*fac3*rrmij
3569                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3570                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3571 c               ees0mij1=0.0D0
3572                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3573                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3574                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3575                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3576                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3577                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3578                 ecosap=ecosa1+ecosa2
3579                 ecosbp=ecosb1+ecosb2
3580                 ecosgp=ecosg1+ecosg2
3581                 ecosam=ecosa1-ecosa2
3582                 ecosbm=ecosb1-ecosb2
3583                 ecosgm=ecosg1-ecosg2
3584 C Diagnostics
3585 c               ecosap=ecosa1
3586 c               ecosbp=ecosb1
3587 c               ecosgp=ecosg1
3588 c               ecosam=0.0D0
3589 c               ecosbm=0.0D0
3590 c               ecosgm=0.0D0
3591 C End diagnostics
3592                 facont_hb(num_conti,i)=fcont
3593                 fprimcont=fprimcont/rij
3594 cd              facont_hb(num_conti,i)=1.0D0
3595 C Following line is for diagnostics.
3596 cd              fprimcont=0.0D0
3597                 do k=1,3
3598                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3599                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3600                 enddo
3601                 do k=1,3
3602                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3603                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3604                 enddo
3605                 gggp(1)=gggp(1)+ees0pijp*xj
3606                 gggp(2)=gggp(2)+ees0pijp*yj
3607                 gggp(3)=gggp(3)+ees0pijp*zj
3608                 gggm(1)=gggm(1)+ees0mijp*xj
3609                 gggm(2)=gggm(2)+ees0mijp*yj
3610                 gggm(3)=gggm(3)+ees0mijp*zj
3611 C Derivatives due to the contact function
3612                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3613                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3614                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3615                 do k=1,3
3616 c
3617 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3618 c          following the change of gradient-summation algorithm.
3619 c
3620 cgrad                  ghalfp=0.5D0*gggp(k)
3621 cgrad                  ghalfm=0.5D0*gggm(k)
3622                   gacontp_hb1(k,num_conti,i)=!ghalfp
3623      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3624      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3625                   gacontp_hb2(k,num_conti,i)=!ghalfp
3626      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3627      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3628                   gacontp_hb3(k,num_conti,i)=gggp(k)
3629                   gacontm_hb1(k,num_conti,i)=!ghalfm
3630      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3631      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3632                   gacontm_hb2(k,num_conti,i)=!ghalfm
3633      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3634      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3635                   gacontm_hb3(k,num_conti,i)=gggm(k)
3636                 enddo
3637 C Diagnostics. Comment out or remove after debugging!
3638 cdiag           do k=1,3
3639 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3640 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3641 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3642 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3643 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3644 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3645 cdiag           enddo
3646               ENDIF ! wcorr
3647               endif  ! num_conti.le.maxconts
3648             endif  ! fcont.gt.0
3649           endif    ! j.gt.i+1
3650           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3651             do k=1,4
3652               do l=1,3
3653                 ghalf=0.5d0*agg(l,k)
3654                 aggi(l,k)=aggi(l,k)+ghalf
3655                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3656                 aggj(l,k)=aggj(l,k)+ghalf
3657               enddo
3658             enddo
3659             if (j.eq.nres-1 .and. i.lt.j-2) then
3660               do k=1,4
3661                 do l=1,3
3662                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3663                 enddo
3664               enddo
3665             endif
3666           endif
3667 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3668       return
3669       end
3670 C-----------------------------------------------------------------------------
3671       subroutine eturn3(i,eello_turn3)
3672 C Third- and fourth-order contributions from turns
3673       implicit real*8 (a-h,o-z)
3674       include 'DIMENSIONS'
3675       include 'COMMON.IOUNITS'
3676       include 'COMMON.GEO'
3677       include 'COMMON.VAR'
3678       include 'COMMON.LOCAL'
3679       include 'COMMON.CHAIN'
3680       include 'COMMON.DERIV'
3681       include 'COMMON.INTERACT'
3682       include 'COMMON.CONTACTS'
3683       include 'COMMON.TORSION'
3684       include 'COMMON.VECTORS'
3685       include 'COMMON.FFIELD'
3686       include 'COMMON.CONTROL'
3687       dimension ggg(3)
3688       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3689      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3690      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3691       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3692      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3693       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3694      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3695      &    num_conti,j1,j2
3696       j=i+2
3697 c      write (iout,*) "eturn3",i,j,j1,j2
3698       a_temp(1,1)=a22
3699       a_temp(1,2)=a23
3700       a_temp(2,1)=a32
3701       a_temp(2,2)=a33
3702 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3703 C
3704 C               Third-order contributions
3705 C
3706 C                 (i+2)o----(i+3)
3707 C                      | |
3708 C                      | |
3709 C                 (i+1)o----i
3710 C
3711 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3712 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3713         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3714         call transpose2(auxmat(1,1),auxmat1(1,1))
3715         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3716         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3717         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3718      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3719 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3720 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3721 cd     &    ' eello_turn3_num',4*eello_turn3_num
3722 C Derivatives in gamma(i)
3723         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3724         call transpose2(auxmat2(1,1),auxmat3(1,1))
3725         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3726         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3727 C Derivatives in gamma(i+1)
3728         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3729         call transpose2(auxmat2(1,1),auxmat3(1,1))
3730         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3731         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3732      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3733 C Cartesian derivatives
3734         do l=1,3
3735 c            ghalf1=0.5d0*agg(l,1)
3736 c            ghalf2=0.5d0*agg(l,2)
3737 c            ghalf3=0.5d0*agg(l,3)
3738 c            ghalf4=0.5d0*agg(l,4)
3739           a_temp(1,1)=aggi(l,1)!+ghalf1
3740           a_temp(1,2)=aggi(l,2)!+ghalf2
3741           a_temp(2,1)=aggi(l,3)!+ghalf3
3742           a_temp(2,2)=aggi(l,4)!+ghalf4
3743           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3744           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3745      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3746           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3747           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3748           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3749           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3750           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3751           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3752      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3753           a_temp(1,1)=aggj(l,1)!+ghalf1
3754           a_temp(1,2)=aggj(l,2)!+ghalf2
3755           a_temp(2,1)=aggj(l,3)!+ghalf3
3756           a_temp(2,2)=aggj(l,4)!+ghalf4
3757           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3758           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3759      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3760           a_temp(1,1)=aggj1(l,1)
3761           a_temp(1,2)=aggj1(l,2)
3762           a_temp(2,1)=aggj1(l,3)
3763           a_temp(2,2)=aggj1(l,4)
3764           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3765           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3766      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3767         enddo
3768       return
3769       end
3770 C-------------------------------------------------------------------------------
3771       subroutine eturn4(i,eello_turn4)
3772 C Third- and fourth-order contributions from turns
3773       implicit real*8 (a-h,o-z)
3774       include 'DIMENSIONS'
3775       include 'COMMON.IOUNITS'
3776       include 'COMMON.GEO'
3777       include 'COMMON.VAR'
3778       include 'COMMON.LOCAL'
3779       include 'COMMON.CHAIN'
3780       include 'COMMON.DERIV'
3781       include 'COMMON.INTERACT'
3782       include 'COMMON.CONTACTS'
3783       include 'COMMON.TORSION'
3784       include 'COMMON.VECTORS'
3785       include 'COMMON.FFIELD'
3786       include 'COMMON.CONTROL'
3787       dimension ggg(3)
3788       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3789      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3790      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3791       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3792      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3793       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3794      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3795      &    num_conti,j1,j2
3796       j=i+3
3797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3798 C
3799 C               Fourth-order contributions
3800 C
3801 C                 (i+3)o----(i+4)
3802 C                     /  |
3803 C               (i+2)o   |
3804 C                     \  |
3805 C                 (i+1)o----i
3806 C
3807 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3808 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3809 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3810         a_temp(1,1)=a22
3811         a_temp(1,2)=a23
3812         a_temp(2,1)=a32
3813         a_temp(2,2)=a33
3814         iti1=itortyp(itype(i+1))
3815         iti2=itortyp(itype(i+2))
3816         iti3=itortyp(itype(i+3))
3817 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3818         call transpose2(EUg(1,1,i+1),e1t(1,1))
3819         call transpose2(Eug(1,1,i+2),e2t(1,1))
3820         call transpose2(Eug(1,1,i+3),e3t(1,1))
3821         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3822         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3823         s1=scalar2(b1(1,iti2),auxvec(1))
3824         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3825         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3826         s2=scalar2(b1(1,iti1),auxvec(1))
3827         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3828         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3829         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3830         eello_turn4=eello_turn4-(s1+s2+s3)
3831         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3832      &      'eturn4',i,j,-(s1+s2+s3)
3833 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3834 cd     &    ' eello_turn4_num',8*eello_turn4_num
3835 C Derivatives in gamma(i)
3836         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3837         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3838         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3839         s1=scalar2(b1(1,iti2),auxvec(1))
3840         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3841         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3842         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3843 C Derivatives in gamma(i+1)
3844         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3845         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3846         s2=scalar2(b1(1,iti1),auxvec(1))
3847         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3848         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3849         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3850         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3851 C Derivatives in gamma(i+2)
3852         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3853         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3854         s1=scalar2(b1(1,iti2),auxvec(1))
3855         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3856         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3857         s2=scalar2(b1(1,iti1),auxvec(1))
3858         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3859         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3860         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3861         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3862 C Cartesian derivatives
3863 C Derivatives of this turn contributions in DC(i+2)
3864         if (j.lt.nres-1) then
3865           do l=1,3
3866             a_temp(1,1)=agg(l,1)
3867             a_temp(1,2)=agg(l,2)
3868             a_temp(2,1)=agg(l,3)
3869             a_temp(2,2)=agg(l,4)
3870             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3871             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3872             s1=scalar2(b1(1,iti2),auxvec(1))
3873             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3874             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3875             s2=scalar2(b1(1,iti1),auxvec(1))
3876             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3877             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3878             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3879             ggg(l)=-(s1+s2+s3)
3880             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3881           enddo
3882         endif
3883 C Remaining derivatives of this turn contribution
3884         do l=1,3
3885           a_temp(1,1)=aggi(l,1)
3886           a_temp(1,2)=aggi(l,2)
3887           a_temp(2,1)=aggi(l,3)
3888           a_temp(2,2)=aggi(l,4)
3889           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3890           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3891           s1=scalar2(b1(1,iti2),auxvec(1))
3892           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3893           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3894           s2=scalar2(b1(1,iti1),auxvec(1))
3895           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3896           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3897           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3898           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3899           a_temp(1,1)=aggi1(l,1)
3900           a_temp(1,2)=aggi1(l,2)
3901           a_temp(2,1)=aggi1(l,3)
3902           a_temp(2,2)=aggi1(l,4)
3903           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3904           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3905           s1=scalar2(b1(1,iti2),auxvec(1))
3906           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3907           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3908           s2=scalar2(b1(1,iti1),auxvec(1))
3909           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3910           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3911           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3912           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3913           a_temp(1,1)=aggj(l,1)
3914           a_temp(1,2)=aggj(l,2)
3915           a_temp(2,1)=aggj(l,3)
3916           a_temp(2,2)=aggj(l,4)
3917           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3918           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3919           s1=scalar2(b1(1,iti2),auxvec(1))
3920           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3921           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3922           s2=scalar2(b1(1,iti1),auxvec(1))
3923           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3924           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3925           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3927           a_temp(1,1)=aggj1(l,1)
3928           a_temp(1,2)=aggj1(l,2)
3929           a_temp(2,1)=aggj1(l,3)
3930           a_temp(2,2)=aggj1(l,4)
3931           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3932           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3933           s1=scalar2(b1(1,iti2),auxvec(1))
3934           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3935           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3936           s2=scalar2(b1(1,iti1),auxvec(1))
3937           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3938           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3939           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3940 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3941           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3942         enddo
3943       return
3944       end
3945 C-----------------------------------------------------------------------------
3946       subroutine vecpr(u,v,w)
3947       implicit real*8(a-h,o-z)
3948       dimension u(3),v(3),w(3)
3949       w(1)=u(2)*v(3)-u(3)*v(2)
3950       w(2)=-u(1)*v(3)+u(3)*v(1)
3951       w(3)=u(1)*v(2)-u(2)*v(1)
3952       return
3953       end
3954 C-----------------------------------------------------------------------------
3955       subroutine unormderiv(u,ugrad,unorm,ungrad)
3956 C This subroutine computes the derivatives of a normalized vector u, given
3957 C the derivatives computed without normalization conditions, ugrad. Returns
3958 C ungrad.
3959       implicit none
3960       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3961       double precision vec(3)
3962       double precision scalar
3963       integer i,j
3964 c      write (2,*) 'ugrad',ugrad
3965 c      write (2,*) 'u',u
3966       do i=1,3
3967         vec(i)=scalar(ugrad(1,i),u(1))
3968       enddo
3969 c      write (2,*) 'vec',vec
3970       do i=1,3
3971         do j=1,3
3972           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3973         enddo
3974       enddo
3975 c      write (2,*) 'ungrad',ungrad
3976       return
3977       end
3978 C-----------------------------------------------------------------------------
3979       subroutine escp_soft_sphere(evdw2,evdw2_14)
3980 C
3981 C This subroutine calculates the excluded-volume interaction energy between
3982 C peptide-group centers and side chains and its gradient in virtual-bond and
3983 C side-chain vectors.
3984 C
3985       implicit real*8 (a-h,o-z)
3986       include 'DIMENSIONS'
3987       include 'COMMON.GEO'
3988       include 'COMMON.VAR'
3989       include 'COMMON.LOCAL'
3990       include 'COMMON.CHAIN'
3991       include 'COMMON.DERIV'
3992       include 'COMMON.INTERACT'
3993       include 'COMMON.FFIELD'
3994       include 'COMMON.IOUNITS'
3995       include 'COMMON.CONTROL'
3996       dimension ggg(3)
3997       evdw2=0.0D0
3998       evdw2_14=0.0d0
3999       r0_scp=4.5d0
4000 cd    print '(a)','Enter ESCP'
4001 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4002       do i=iatscp_s,iatscp_e
4003         iteli=itel(i)
4004         xi=0.5D0*(c(1,i)+c(1,i+1))
4005         yi=0.5D0*(c(2,i)+c(2,i+1))
4006         zi=0.5D0*(c(3,i)+c(3,i+1))
4007
4008         do iint=1,nscp_gr(i)
4009
4010         do j=iscpstart(i,iint),iscpend(i,iint)
4011           itypj=itype(j)
4012 C Uncomment following three lines for SC-p interactions
4013 c         xj=c(1,nres+j)-xi
4014 c         yj=c(2,nres+j)-yi
4015 c         zj=c(3,nres+j)-zi
4016 C Uncomment following three lines for Ca-p interactions
4017           xj=c(1,j)-xi
4018           yj=c(2,j)-yi
4019           zj=c(3,j)-zi
4020           rij=xj*xj+yj*yj+zj*zj
4021           r0ij=r0_scp
4022           r0ijsq=r0ij*r0ij
4023           if (rij.lt.r0ijsq) then
4024             evdwij=0.25d0*(rij-r0ijsq)**2
4025             fac=rij-r0ijsq
4026           else
4027             evdwij=0.0d0
4028             fac=0.0d0
4029           endif
4030           evdw2=evdw2+evdwij
4031 C
4032 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4033 C
4034           ggg(1)=xj*fac
4035           ggg(2)=yj*fac
4036           ggg(3)=zj*fac
4037 cgrad          if (j.lt.i) then
4038 cd          write (iout,*) 'j<i'
4039 C Uncomment following three lines for SC-p interactions
4040 c           do k=1,3
4041 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4042 c           enddo
4043 cgrad          else
4044 cd          write (iout,*) 'j>i'
4045 cgrad            do k=1,3
4046 cgrad              ggg(k)=-ggg(k)
4047 C Uncomment following line for SC-p interactions
4048 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4049 cgrad            enddo
4050 cgrad          endif
4051 cgrad          do k=1,3
4052 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4053 cgrad          enddo
4054 cgrad          kstart=min0(i+1,j)
4055 cgrad          kend=max0(i-1,j-1)
4056 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4057 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4058 cgrad          do k=kstart,kend
4059 cgrad            do l=1,3
4060 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4061 cgrad            enddo
4062 cgrad          enddo
4063           do k=1,3
4064             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4065             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4066           enddo
4067         enddo
4068
4069         enddo ! iint
4070       enddo ! i
4071       return
4072       end
4073 C-----------------------------------------------------------------------------
4074       subroutine escp(evdw2,evdw2_14)
4075 C
4076 C This subroutine calculates the excluded-volume interaction energy between
4077 C peptide-group centers and side chains and its gradient in virtual-bond and
4078 C side-chain vectors.
4079 C
4080       implicit real*8 (a-h,o-z)
4081       include 'DIMENSIONS'
4082       include 'COMMON.GEO'
4083       include 'COMMON.VAR'
4084       include 'COMMON.LOCAL'
4085       include 'COMMON.CHAIN'
4086       include 'COMMON.DERIV'
4087       include 'COMMON.INTERACT'
4088       include 'COMMON.FFIELD'
4089       include 'COMMON.IOUNITS'
4090       include 'COMMON.CONTROL'
4091       dimension ggg(3)
4092       evdw2=0.0D0
4093       evdw2_14=0.0d0
4094 cd    print '(a)','Enter ESCP'
4095 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4096       do i=iatscp_s,iatscp_e
4097         iteli=itel(i)
4098         xi=0.5D0*(c(1,i)+c(1,i+1))
4099         yi=0.5D0*(c(2,i)+c(2,i+1))
4100         zi=0.5D0*(c(3,i)+c(3,i+1))
4101
4102         do iint=1,nscp_gr(i)
4103
4104         do j=iscpstart(i,iint),iscpend(i,iint)
4105           itypj=itype(j)
4106 C Uncomment following three lines for SC-p interactions
4107 c         xj=c(1,nres+j)-xi
4108 c         yj=c(2,nres+j)-yi
4109 c         zj=c(3,nres+j)-zi
4110 C Uncomment following three lines for Ca-p interactions
4111           xj=c(1,j)-xi
4112           yj=c(2,j)-yi
4113           zj=c(3,j)-zi
4114           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4115           fac=rrij**expon2
4116           e1=fac*fac*aad(itypj,iteli)
4117           e2=fac*bad(itypj,iteli)
4118           if (iabs(j-i) .le. 2) then
4119             e1=scal14*e1
4120             e2=scal14*e2
4121             evdw2_14=evdw2_14+e1+e2
4122           endif
4123           evdwij=e1+e2
4124           evdw2=evdw2+evdwij
4125           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4126      &        'evdw2',i,j,evdwij
4127 C
4128 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4129 C
4130           fac=-(evdwij+e1)*rrij
4131           ggg(1)=xj*fac
4132           ggg(2)=yj*fac
4133           ggg(3)=zj*fac
4134 cgrad          if (j.lt.i) then
4135 cd          write (iout,*) 'j<i'
4136 C Uncomment following three lines for SC-p interactions
4137 c           do k=1,3
4138 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4139 c           enddo
4140 cgrad          else
4141 cd          write (iout,*) 'j>i'
4142 cgrad            do k=1,3
4143 cgrad              ggg(k)=-ggg(k)
4144 C Uncomment following line for SC-p interactions
4145 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4146 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4147 cgrad            enddo
4148 cgrad          endif
4149 cgrad          do k=1,3
4150 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4151 cgrad          enddo
4152 cgrad          kstart=min0(i+1,j)
4153 cgrad          kend=max0(i-1,j-1)
4154 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4155 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4156 cgrad          do k=kstart,kend
4157 cgrad            do l=1,3
4158 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4159 cgrad            enddo
4160 cgrad          enddo
4161           do k=1,3
4162             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4163             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4164           enddo
4165         enddo
4166
4167         enddo ! iint
4168       enddo ! i
4169       do i=1,nct
4170         do j=1,3
4171           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4172           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4173           gradx_scp(j,i)=expon*gradx_scp(j,i)
4174         enddo
4175       enddo
4176 C******************************************************************************
4177 C
4178 C                              N O T E !!!
4179 C
4180 C To save time the factor EXPON has been extracted from ALL components
4181 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4182 C use!
4183 C
4184 C******************************************************************************
4185       return
4186       end
4187 C--------------------------------------------------------------------------
4188       subroutine edis(ehpb)
4189 C
4190 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4191 C
4192       implicit real*8 (a-h,o-z)
4193       include 'DIMENSIONS'
4194       include 'COMMON.SBRIDGE'
4195       include 'COMMON.CHAIN'
4196       include 'COMMON.DERIV'
4197       include 'COMMON.VAR'
4198       include 'COMMON.INTERACT'
4199       include 'COMMON.IOUNITS'
4200       dimension ggg(3)
4201       ehpb=0.0D0
4202 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4203 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4204       if (link_end.eq.0) return
4205       do i=link_start,link_end
4206 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4207 C CA-CA distance used in regularization of structure.
4208         ii=ihpb(i)
4209         jj=jhpb(i)
4210 C iii and jjj point to the residues for which the distance is assigned.
4211         if (ii.gt.nres) then
4212           iii=ii-nres
4213           jjj=jj-nres
4214         else
4215           iii=ii
4216           jjj=jj
4217         endif
4218 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4219 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4220 C    distance and angle dependent SS bond potential.
4221         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4222           call ssbond_ene(iii,jjj,eij)
4223           ehpb=ehpb+2*eij
4224 cd          write (iout,*) "eij",eij
4225         else
4226 C Calculate the distance between the two points and its difference from the
4227 C target distance.
4228         dd=dist(ii,jj)
4229         rdis=dd-dhpb(i)
4230 C Get the force constant corresponding to this distance.
4231         waga=forcon(i)
4232 C Calculate the contribution to energy.
4233         ehpb=ehpb+waga*rdis*rdis
4234 C
4235 C Evaluate gradient.
4236 C
4237         fac=waga*rdis/dd
4238 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4239 cd   &   ' waga=',waga,' fac=',fac
4240         do j=1,3
4241           ggg(j)=fac*(c(j,jj)-c(j,ii))
4242         enddo
4243 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4244 C If this is a SC-SC distance, we need to calculate the contributions to the
4245 C Cartesian gradient in the SC vectors (ghpbx).
4246         if (iii.lt.ii) then
4247           do j=1,3
4248             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4249             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4250           enddo
4251         endif
4252 cgrad        do j=iii,jjj-1
4253 cgrad          do k=1,3
4254 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4255 cgrad          enddo
4256 cgrad        enddo
4257         do k=1,3
4258           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4259           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4260         enddo
4261         endif
4262       enddo
4263       ehpb=0.5D0*ehpb
4264       return
4265       end
4266 C--------------------------------------------------------------------------
4267       subroutine ssbond_ene(i,j,eij)
4268 C
4269 C Calculate the distance and angle dependent SS-bond potential energy
4270 C using a free-energy function derived based on RHF/6-31G** ab initio
4271 C calculations of diethyl disulfide.
4272 C
4273 C A. Liwo and U. Kozlowska, 11/24/03
4274 C
4275       implicit real*8 (a-h,o-z)
4276       include 'DIMENSIONS'
4277       include 'COMMON.SBRIDGE'
4278       include 'COMMON.CHAIN'
4279       include 'COMMON.DERIV'
4280       include 'COMMON.LOCAL'
4281       include 'COMMON.INTERACT'
4282       include 'COMMON.VAR'
4283       include 'COMMON.IOUNITS'
4284       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4285       itypi=itype(i)
4286       xi=c(1,nres+i)
4287       yi=c(2,nres+i)
4288       zi=c(3,nres+i)
4289       dxi=dc_norm(1,nres+i)
4290       dyi=dc_norm(2,nres+i)
4291       dzi=dc_norm(3,nres+i)
4292 c      dsci_inv=dsc_inv(itypi)
4293       dsci_inv=vbld_inv(nres+i)
4294       itypj=itype(j)
4295 c      dscj_inv=dsc_inv(itypj)
4296       dscj_inv=vbld_inv(nres+j)
4297       xj=c(1,nres+j)-xi
4298       yj=c(2,nres+j)-yi
4299       zj=c(3,nres+j)-zi
4300       dxj=dc_norm(1,nres+j)
4301       dyj=dc_norm(2,nres+j)
4302       dzj=dc_norm(3,nres+j)
4303       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4304       rij=dsqrt(rrij)
4305       erij(1)=xj*rij
4306       erij(2)=yj*rij
4307       erij(3)=zj*rij
4308       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4309       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4310       om12=dxi*dxj+dyi*dyj+dzi*dzj
4311       do k=1,3
4312         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4313         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4314       enddo
4315       rij=1.0d0/rij
4316       deltad=rij-d0cm
4317       deltat1=1.0d0-om1
4318       deltat2=1.0d0+om2
4319       deltat12=om2-om1+2.0d0
4320       cosphi=om12-om1*om2
4321       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4322      &  +akct*deltad*deltat12
4323      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4324 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4325 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4326 c     &  " deltat12",deltat12," eij",eij
4327       ed=2*akcm*deltad+akct*deltat12
4328       pom1=akct*deltad
4329       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4330       eom1=-2*akth*deltat1-pom1-om2*pom2
4331       eom2= 2*akth*deltat2+pom1-om1*pom2
4332       eom12=pom2
4333       do k=1,3
4334         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4335         ghpbx(k,i)=ghpbx(k,i)-ggk
4336      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4337      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4338         ghpbx(k,j)=ghpbx(k,j)+ggk
4339      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4340      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4341         ghpbc(k,i)=ghpbc(k,i)-ggk
4342         ghpbc(k,j)=ghpbc(k,j)+ggk
4343       enddo
4344 C
4345 C Calculate the components of the gradient in DC and X
4346 C
4347 cgrad      do k=i,j-1
4348 cgrad        do l=1,3
4349 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4350 cgrad        enddo
4351 cgrad      enddo
4352       return
4353       end
4354 C--------------------------------------------------------------------------
4355       subroutine ebond(estr)
4356 c
4357 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4358 c
4359       implicit real*8 (a-h,o-z)
4360       include 'DIMENSIONS'
4361       include 'COMMON.LOCAL'
4362       include 'COMMON.GEO'
4363       include 'COMMON.INTERACT'
4364       include 'COMMON.DERIV'
4365       include 'COMMON.VAR'
4366       include 'COMMON.CHAIN'
4367       include 'COMMON.IOUNITS'
4368       include 'COMMON.NAMES'
4369       include 'COMMON.FFIELD'
4370       include 'COMMON.CONTROL'
4371       include 'COMMON.SETUP'
4372       double precision u(3),ud(3)
4373       estr=0.0d0
4374       do i=ibondp_start,ibondp_end
4375         diff = vbld(i)-vbldp0
4376 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4377         estr=estr+diff*diff
4378         do j=1,3
4379           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4380         enddo
4381 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4382       enddo
4383       estr=0.5d0*AKP*estr
4384 c
4385 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4386 c
4387       do i=ibond_start,ibond_end
4388         iti=itype(i)
4389         if (iti.ne.10) then
4390           nbi=nbondterm(iti)
4391           if (nbi.eq.1) then
4392             diff=vbld(i+nres)-vbldsc0(1,iti)
4393 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4394 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4395             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4396             do j=1,3
4397               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4398             enddo
4399           else
4400             do j=1,nbi
4401               diff=vbld(i+nres)-vbldsc0(j,iti)
4402               ud(j)=aksc(j,iti)*diff
4403               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4404             enddo
4405             uprod=u(1)
4406             do j=2,nbi
4407               uprod=uprod*u(j)
4408             enddo
4409             usum=0.0d0
4410             usumsqder=0.0d0
4411             do j=1,nbi
4412               uprod1=1.0d0
4413               uprod2=1.0d0
4414               do k=1,nbi
4415                 if (k.ne.j) then
4416                   uprod1=uprod1*u(k)
4417                   uprod2=uprod2*u(k)*u(k)
4418                 endif
4419               enddo
4420               usum=usum+uprod1
4421               usumsqder=usumsqder+ud(j)*uprod2
4422             enddo
4423             estr=estr+uprod/usum
4424             do j=1,3
4425              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4426             enddo
4427           endif
4428         endif
4429       enddo
4430       return
4431       end
4432 #ifdef CRYST_THETA
4433 C--------------------------------------------------------------------------
4434       subroutine ebend(etheta)
4435 C
4436 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4437 C angles gamma and its derivatives in consecutive thetas and gammas.
4438 C
4439       implicit real*8 (a-h,o-z)
4440       include 'DIMENSIONS'
4441       include 'COMMON.LOCAL'
4442       include 'COMMON.GEO'
4443       include 'COMMON.INTERACT'
4444       include 'COMMON.DERIV'
4445       include 'COMMON.VAR'
4446       include 'COMMON.CHAIN'
4447       include 'COMMON.IOUNITS'
4448       include 'COMMON.NAMES'
4449       include 'COMMON.FFIELD'
4450       include 'COMMON.CONTROL'
4451       common /calcthet/ term1,term2,termm,diffak,ratak,
4452      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4453      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4454       double precision y(2),z(2)
4455       delta=0.02d0*pi
4456 c      time11=dexp(-2*time)
4457 c      time12=1.0d0
4458       etheta=0.0D0
4459 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4460       do i=ithet_start,ithet_end
4461 C Zero the energy function and its derivative at 0 or pi.
4462         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4463         it=itype(i-1)
4464         if (i.gt.3) then
4465 #ifdef OSF
4466           phii=phi(i)
4467           if (phii.ne.phii) phii=150.0
4468 #else
4469           phii=phi(i)
4470 #endif
4471           y(1)=dcos(phii)
4472           y(2)=dsin(phii)
4473         else
4474           y(1)=0.0D0
4475           y(2)=0.0D0
4476         endif
4477         if (i.lt.nres) then
4478 #ifdef OSF
4479           phii1=phi(i+1)
4480           if (phii1.ne.phii1) phii1=150.0
4481           phii1=pinorm(phii1)
4482           z(1)=cos(phii1)
4483 #else
4484           phii1=phi(i+1)
4485           z(1)=dcos(phii1)
4486 #endif
4487           z(2)=dsin(phii1)
4488         else
4489           z(1)=0.0D0
4490           z(2)=0.0D0
4491         endif
4492 C Calculate the "mean" value of theta from the part of the distribution
4493 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4494 C In following comments this theta will be referred to as t_c.
4495         thet_pred_mean=0.0d0
4496         do k=1,2
4497           athetk=athet(k,it)
4498           bthetk=bthet(k,it)
4499           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4500         enddo
4501         dthett=thet_pred_mean*ssd
4502         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4503 C Derivatives of the "mean" values in gamma1 and gamma2.
4504         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4505         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4506         if (theta(i).gt.pi-delta) then
4507           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4508      &         E_tc0)
4509           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4510           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4511           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4512      &        E_theta)
4513           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4514      &        E_tc)
4515         else if (theta(i).lt.delta) then
4516           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4517           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4518           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4519      &        E_theta)
4520           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4521           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4522      &        E_tc)
4523         else
4524           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4525      &        E_theta,E_tc)
4526         endif
4527         etheta=etheta+ethetai
4528         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4529      &      'ebend',i,ethetai
4530         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4531         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4532         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4533       enddo
4534 C Ufff.... We've done all this!!!
4535       return
4536       end
4537 C---------------------------------------------------------------------------
4538       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4539      &     E_tc)
4540       implicit real*8 (a-h,o-z)
4541       include 'DIMENSIONS'
4542       include 'COMMON.LOCAL'
4543       include 'COMMON.IOUNITS'
4544       common /calcthet/ term1,term2,termm,diffak,ratak,
4545      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4546      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4547 C Calculate the contributions to both Gaussian lobes.
4548 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4549 C The "polynomial part" of the "standard deviation" of this part of
4550 C the distribution.
4551         sig=polthet(3,it)
4552         do j=2,0,-1
4553           sig=sig*thet_pred_mean+polthet(j,it)
4554         enddo
4555 C Derivative of the "interior part" of the "standard deviation of the"
4556 C gamma-dependent Gaussian lobe in t_c.
4557         sigtc=3*polthet(3,it)
4558         do j=2,1,-1
4559           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4560         enddo
4561         sigtc=sig*sigtc
4562 C Set the parameters of both Gaussian lobes of the distribution.
4563 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4564         fac=sig*sig+sigc0(it)
4565         sigcsq=fac+fac
4566         sigc=1.0D0/sigcsq
4567 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4568         sigsqtc=-4.0D0*sigcsq*sigtc
4569 c       print *,i,sig,sigtc,sigsqtc
4570 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4571         sigtc=-sigtc/(fac*fac)
4572 C Following variable is sigma(t_c)**(-2)
4573         sigcsq=sigcsq*sigcsq
4574         sig0i=sig0(it)
4575         sig0inv=1.0D0/sig0i**2
4576         delthec=thetai-thet_pred_mean
4577         delthe0=thetai-theta0i
4578         term1=-0.5D0*sigcsq*delthec*delthec
4579         term2=-0.5D0*sig0inv*delthe0*delthe0
4580 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4581 C NaNs in taking the logarithm. We extract the largest exponent which is added
4582 C to the energy (this being the log of the distribution) at the end of energy
4583 C term evaluation for this virtual-bond angle.
4584         if (term1.gt.term2) then
4585           termm=term1
4586           term2=dexp(term2-termm)
4587           term1=1.0d0
4588         else
4589           termm=term2
4590           term1=dexp(term1-termm)
4591           term2=1.0d0
4592         endif
4593 C The ratio between the gamma-independent and gamma-dependent lobes of
4594 C the distribution is a Gaussian function of thet_pred_mean too.
4595         diffak=gthet(2,it)-thet_pred_mean
4596         ratak=diffak/gthet(3,it)**2
4597         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4598 C Let's differentiate it in thet_pred_mean NOW.
4599         aktc=ak*ratak
4600 C Now put together the distribution terms to make complete distribution.
4601         termexp=term1+ak*term2
4602         termpre=sigc+ak*sig0i
4603 C Contribution of the bending energy from this theta is just the -log of
4604 C the sum of the contributions from the two lobes and the pre-exponential
4605 C factor. Simple enough, isn't it?
4606         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4607 C NOW the derivatives!!!
4608 C 6/6/97 Take into account the deformation.
4609         E_theta=(delthec*sigcsq*term1
4610      &       +ak*delthe0*sig0inv*term2)/termexp
4611         E_tc=((sigtc+aktc*sig0i)/termpre
4612      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4613      &       aktc*term2)/termexp)
4614       return
4615       end
4616 c-----------------------------------------------------------------------------
4617       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4618       implicit real*8 (a-h,o-z)
4619       include 'DIMENSIONS'
4620       include 'COMMON.LOCAL'
4621       include 'COMMON.IOUNITS'
4622       common /calcthet/ term1,term2,termm,diffak,ratak,
4623      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4624      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4625       delthec=thetai-thet_pred_mean
4626       delthe0=thetai-theta0i
4627 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4628       t3 = thetai-thet_pred_mean
4629       t6 = t3**2
4630       t9 = term1
4631       t12 = t3*sigcsq
4632       t14 = t12+t6*sigsqtc
4633       t16 = 1.0d0
4634       t21 = thetai-theta0i
4635       t23 = t21**2
4636       t26 = term2
4637       t27 = t21*t26
4638       t32 = termexp
4639       t40 = t32**2
4640       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4641      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4642      & *(-t12*t9-ak*sig0inv*t27)
4643       return
4644       end
4645 #else
4646 C--------------------------------------------------------------------------
4647       subroutine ebend(etheta)
4648 C
4649 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4650 C angles gamma and its derivatives in consecutive thetas and gammas.
4651 C ab initio-derived potentials from
4652 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4653 C
4654       implicit real*8 (a-h,o-z)
4655       include 'DIMENSIONS'
4656       include 'COMMON.LOCAL'
4657       include 'COMMON.GEO'
4658       include 'COMMON.INTERACT'
4659       include 'COMMON.DERIV'
4660       include 'COMMON.VAR'
4661       include 'COMMON.CHAIN'
4662       include 'COMMON.IOUNITS'
4663       include 'COMMON.NAMES'
4664       include 'COMMON.FFIELD'
4665       include 'COMMON.CONTROL'
4666       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4667      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4668      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4669      & sinph1ph2(maxdouble,maxdouble)
4670       logical lprn /.false./, lprn1 /.false./
4671       etheta=0.0D0
4672       do i=ithet_start,ithet_end
4673         dethetai=0.0d0
4674         dephii=0.0d0
4675         dephii1=0.0d0
4676         theti2=0.5d0*theta(i)
4677         ityp2=ithetyp(itype(i-1))
4678         do k=1,nntheterm
4679           coskt(k)=dcos(k*theti2)
4680           sinkt(k)=dsin(k*theti2)
4681         enddo
4682         if (i.gt.3) then
4683 #ifdef OSF
4684           phii=phi(i)
4685           if (phii.ne.phii) phii=150.0
4686 #else
4687           phii=phi(i)
4688 #endif
4689           ityp1=ithetyp(itype(i-2))
4690           do k=1,nsingle
4691             cosph1(k)=dcos(k*phii)
4692             sinph1(k)=dsin(k*phii)
4693           enddo
4694         else
4695           phii=0.0d0
4696           ityp1=nthetyp+1
4697           do k=1,nsingle
4698             cosph1(k)=0.0d0
4699             sinph1(k)=0.0d0
4700           enddo
4701         endif
4702         if (i.lt.nres) then
4703 #ifdef OSF
4704           phii1=phi(i+1)
4705           if (phii1.ne.phii1) phii1=150.0
4706           phii1=pinorm(phii1)
4707 #else
4708           phii1=phi(i+1)
4709 #endif
4710           ityp3=ithetyp(itype(i))
4711           do k=1,nsingle
4712             cosph2(k)=dcos(k*phii1)
4713             sinph2(k)=dsin(k*phii1)
4714           enddo
4715         else
4716           phii1=0.0d0
4717           ityp3=nthetyp+1
4718           do k=1,nsingle
4719             cosph2(k)=0.0d0
4720             sinph2(k)=0.0d0
4721           enddo
4722         endif
4723         ethetai=aa0thet(ityp1,ityp2,ityp3)
4724         do k=1,ndouble
4725           do l=1,k-1
4726             ccl=cosph1(l)*cosph2(k-l)
4727             ssl=sinph1(l)*sinph2(k-l)
4728             scl=sinph1(l)*cosph2(k-l)
4729             csl=cosph1(l)*sinph2(k-l)
4730             cosph1ph2(l,k)=ccl-ssl
4731             cosph1ph2(k,l)=ccl+ssl
4732             sinph1ph2(l,k)=scl+csl
4733             sinph1ph2(k,l)=scl-csl
4734           enddo
4735         enddo
4736         if (lprn) then
4737         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4738      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4739         write (iout,*) "coskt and sinkt"
4740         do k=1,nntheterm
4741           write (iout,*) k,coskt(k),sinkt(k)
4742         enddo
4743         endif
4744         do k=1,ntheterm
4745           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4746           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4747      &      *coskt(k)
4748           if (lprn)
4749      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4750      &     " ethetai",ethetai
4751         enddo
4752         if (lprn) then
4753         write (iout,*) "cosph and sinph"
4754         do k=1,nsingle
4755           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4756         enddo
4757         write (iout,*) "cosph1ph2 and sinph2ph2"
4758         do k=2,ndouble
4759           do l=1,k-1
4760             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4761      &         sinph1ph2(l,k),sinph1ph2(k,l)
4762           enddo
4763         enddo
4764         write(iout,*) "ethetai",ethetai
4765         endif
4766         do m=1,ntheterm2
4767           do k=1,nsingle
4768             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4769      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4770      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4771      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4772             ethetai=ethetai+sinkt(m)*aux
4773             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4774             dephii=dephii+k*sinkt(m)*(
4775      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4776      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4777             dephii1=dephii1+k*sinkt(m)*(
4778      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4779      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4780             if (lprn)
4781      &      write (iout,*) "m",m," k",k," bbthet",
4782      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4783      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4784      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4785      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4786           enddo
4787         enddo
4788         if (lprn)
4789      &  write(iout,*) "ethetai",ethetai
4790         do m=1,ntheterm3
4791           do k=2,ndouble
4792             do l=1,k-1
4793               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4794      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4795      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4796      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4797               ethetai=ethetai+sinkt(m)*aux
4798               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4799               dephii=dephii+l*sinkt(m)*(
4800      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4801      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4802      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4803      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4804               dephii1=dephii1+(k-l)*sinkt(m)*(
4805      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4806      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4807      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4808      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4809               if (lprn) then
4810               write (iout,*) "m",m," k",k," l",l," ffthet",
4811      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4812      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4813      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4814      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4815               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4816      &            cosph1ph2(k,l)*sinkt(m),
4817      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4818               endif
4819             enddo
4820           enddo
4821         enddo
4822 10      continue
4823         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4824      &   i,theta(i)*rad2deg,phii*rad2deg,
4825      &   phii1*rad2deg,ethetai
4826         etheta=etheta+ethetai
4827         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4828         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4829         gloc(nphi+i-2,icg)=wang*dethetai
4830       enddo
4831       return
4832       end
4833 #endif
4834 #ifdef CRYST_SC
4835 c-----------------------------------------------------------------------------
4836       subroutine esc(escloc)
4837 C Calculate the local energy of a side chain and its derivatives in the
4838 C corresponding virtual-bond valence angles THETA and the spherical angles
4839 C ALPHA and OMEGA.
4840       implicit real*8 (a-h,o-z)
4841       include 'DIMENSIONS'
4842       include 'COMMON.GEO'
4843       include 'COMMON.LOCAL'
4844       include 'COMMON.VAR'
4845       include 'COMMON.INTERACT'
4846       include 'COMMON.DERIV'
4847       include 'COMMON.CHAIN'
4848       include 'COMMON.IOUNITS'
4849       include 'COMMON.NAMES'
4850       include 'COMMON.FFIELD'
4851       include 'COMMON.CONTROL'
4852       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4853      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4854       common /sccalc/ time11,time12,time112,theti,it,nlobit
4855       delta=0.02d0*pi
4856       escloc=0.0D0
4857 c     write (iout,'(a)') 'ESC'
4858       do i=loc_start,loc_end
4859         it=itype(i)
4860         if (it.eq.10) goto 1
4861         nlobit=nlob(it)
4862 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4863 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4864         theti=theta(i+1)-pipol
4865         x(1)=dtan(theti)
4866         x(2)=alph(i)
4867         x(3)=omeg(i)
4868
4869         if (x(2).gt.pi-delta) then
4870           xtemp(1)=x(1)
4871           xtemp(2)=pi-delta
4872           xtemp(3)=x(3)
4873           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4874           xtemp(2)=pi
4875           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4876           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4877      &        escloci,dersc(2))
4878           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4879      &        ddersc0(1),dersc(1))
4880           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4881      &        ddersc0(3),dersc(3))
4882           xtemp(2)=pi-delta
4883           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4884           xtemp(2)=pi
4885           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4886           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4887      &            dersc0(2),esclocbi,dersc02)
4888           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4889      &            dersc12,dersc01)
4890           call splinthet(x(2),0.5d0*delta,ss,ssd)
4891           dersc0(1)=dersc01
4892           dersc0(2)=dersc02
4893           dersc0(3)=0.0d0
4894           do k=1,3
4895             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4896           enddo
4897           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4898 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4899 c    &             esclocbi,ss,ssd
4900           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4901 c         escloci=esclocbi
4902 c         write (iout,*) escloci
4903         else if (x(2).lt.delta) then
4904           xtemp(1)=x(1)
4905           xtemp(2)=delta
4906           xtemp(3)=x(3)
4907           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4908           xtemp(2)=0.0d0
4909           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4910           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4911      &        escloci,dersc(2))
4912           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4913      &        ddersc0(1),dersc(1))
4914           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4915      &        ddersc0(3),dersc(3))
4916           xtemp(2)=delta
4917           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4918           xtemp(2)=0.0d0
4919           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4920           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4921      &            dersc0(2),esclocbi,dersc02)
4922           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4923      &            dersc12,dersc01)
4924           dersc0(1)=dersc01
4925           dersc0(2)=dersc02
4926           dersc0(3)=0.0d0
4927           call splinthet(x(2),0.5d0*delta,ss,ssd)
4928           do k=1,3
4929             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4930           enddo
4931           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4932 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4933 c    &             esclocbi,ss,ssd
4934           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4935 c         write (iout,*) escloci
4936         else
4937           call enesc(x,escloci,dersc,ddummy,.false.)
4938         endif
4939
4940         escloc=escloc+escloci
4941         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4942      &     'escloc',i,escloci
4943 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4944
4945         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4946      &   wscloc*dersc(1)
4947         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4948         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4949     1   continue
4950       enddo
4951       return
4952       end
4953 C---------------------------------------------------------------------------
4954       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4955       implicit real*8 (a-h,o-z)
4956       include 'DIMENSIONS'
4957       include 'COMMON.GEO'
4958       include 'COMMON.LOCAL'
4959       include 'COMMON.IOUNITS'
4960       common /sccalc/ time11,time12,time112,theti,it,nlobit
4961       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4962       double precision contr(maxlob,-1:1)
4963       logical mixed
4964 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4965         escloc_i=0.0D0
4966         do j=1,3
4967           dersc(j)=0.0D0
4968           if (mixed) ddersc(j)=0.0d0
4969         enddo
4970         x3=x(3)
4971
4972 C Because of periodicity of the dependence of the SC energy in omega we have
4973 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4974 C To avoid underflows, first compute & store the exponents.
4975
4976         do iii=-1,1
4977
4978           x(3)=x3+iii*dwapi
4979
4980           do j=1,nlobit
4981             do k=1,3
4982               z(k)=x(k)-censc(k,j,it)
4983             enddo
4984             do k=1,3
4985               Axk=0.0D0
4986               do l=1,3
4987                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4988               enddo
4989               Ax(k,j,iii)=Axk
4990             enddo
4991             expfac=0.0D0
4992             do k=1,3
4993               expfac=expfac+Ax(k,j,iii)*z(k)
4994             enddo
4995             contr(j,iii)=expfac
4996           enddo ! j
4997
4998         enddo ! iii
4999
5000         x(3)=x3
5001 C As in the case of ebend, we want to avoid underflows in exponentiation and
5002 C subsequent NaNs and INFs in energy calculation.
5003 C Find the largest exponent
5004         emin=contr(1,-1)
5005         do iii=-1,1
5006           do j=1,nlobit
5007             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5008           enddo
5009         enddo
5010         emin=0.5D0*emin
5011 cd      print *,'it=',it,' emin=',emin
5012
5013 C Compute the contribution to SC energy and derivatives
5014         do iii=-1,1
5015
5016           do j=1,nlobit
5017 #ifdef OSF
5018             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5019             if(adexp.ne.adexp) adexp=1.0
5020             expfac=dexp(adexp)
5021 #else
5022             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5023 #endif
5024 cd          print *,'j=',j,' expfac=',expfac
5025             escloc_i=escloc_i+expfac
5026             do k=1,3
5027               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5028             enddo
5029             if (mixed) then
5030               do k=1,3,2
5031                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5032      &            +gaussc(k,2,j,it))*expfac
5033               enddo
5034             endif
5035           enddo
5036
5037         enddo ! iii
5038
5039         dersc(1)=dersc(1)/cos(theti)**2
5040         ddersc(1)=ddersc(1)/cos(theti)**2
5041         ddersc(3)=ddersc(3)
5042
5043         escloci=-(dlog(escloc_i)-emin)
5044         do j=1,3
5045           dersc(j)=dersc(j)/escloc_i
5046         enddo
5047         if (mixed) then
5048           do j=1,3,2
5049             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5050           enddo
5051         endif
5052       return
5053       end
5054 C------------------------------------------------------------------------------
5055       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5056       implicit real*8 (a-h,o-z)
5057       include 'DIMENSIONS'
5058       include 'COMMON.GEO'
5059       include 'COMMON.LOCAL'
5060       include 'COMMON.IOUNITS'
5061       common /sccalc/ time11,time12,time112,theti,it,nlobit
5062       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5063       double precision contr(maxlob)
5064       logical mixed
5065
5066       escloc_i=0.0D0
5067
5068       do j=1,3
5069         dersc(j)=0.0D0
5070       enddo
5071
5072       do j=1,nlobit
5073         do k=1,2
5074           z(k)=x(k)-censc(k,j,it)
5075         enddo
5076         z(3)=dwapi
5077         do k=1,3
5078           Axk=0.0D0
5079           do l=1,3
5080             Axk=Axk+gaussc(l,k,j,it)*z(l)
5081           enddo
5082           Ax(k,j)=Axk
5083         enddo
5084         expfac=0.0D0
5085         do k=1,3
5086           expfac=expfac+Ax(k,j)*z(k)
5087         enddo
5088         contr(j)=expfac
5089       enddo ! j
5090
5091 C As in the case of ebend, we want to avoid underflows in exponentiation and
5092 C subsequent NaNs and INFs in energy calculation.
5093 C Find the largest exponent
5094       emin=contr(1)
5095       do j=1,nlobit
5096         if (emin.gt.contr(j)) emin=contr(j)
5097       enddo
5098       emin=0.5D0*emin
5099
5100 C Compute the contribution to SC energy and derivatives
5101
5102       dersc12=0.0d0
5103       do j=1,nlobit
5104         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5105         escloc_i=escloc_i+expfac
5106         do k=1,2
5107           dersc(k)=dersc(k)+Ax(k,j)*expfac
5108         enddo
5109         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5110      &            +gaussc(1,2,j,it))*expfac
5111         dersc(3)=0.0d0
5112       enddo
5113
5114       dersc(1)=dersc(1)/cos(theti)**2
5115       dersc12=dersc12/cos(theti)**2
5116       escloci=-(dlog(escloc_i)-emin)
5117       do j=1,2
5118         dersc(j)=dersc(j)/escloc_i
5119       enddo
5120       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5121       return
5122       end
5123 #else
5124 c----------------------------------------------------------------------------------
5125       subroutine esc(escloc)
5126 C Calculate the local energy of a side chain and its derivatives in the
5127 C corresponding virtual-bond valence angles THETA and the spherical angles
5128 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5129 C added by Urszula Kozlowska. 07/11/2007
5130 C
5131       implicit real*8 (a-h,o-z)
5132       include 'DIMENSIONS'
5133       include 'COMMON.GEO'
5134       include 'COMMON.LOCAL'
5135       include 'COMMON.VAR'
5136       include 'COMMON.SCROT'
5137       include 'COMMON.INTERACT'
5138       include 'COMMON.DERIV'
5139       include 'COMMON.CHAIN'
5140       include 'COMMON.IOUNITS'
5141       include 'COMMON.NAMES'
5142       include 'COMMON.FFIELD'
5143       include 'COMMON.CONTROL'
5144       include 'COMMON.VECTORS'
5145       double precision x_prime(3),y_prime(3),z_prime(3)
5146      &    , sumene,dsc_i,dp2_i,x(65),
5147      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5148      &    de_dxx,de_dyy,de_dzz,de_dt
5149       double precision s1_t,s1_6_t,s2_t,s2_6_t
5150       double precision
5151      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5152      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5153      & dt_dCi(3),dt_dCi1(3)
5154       common /sccalc/ time11,time12,time112,theti,it,nlobit
5155       delta=0.02d0*pi
5156       escloc=0.0D0
5157       do i=loc_start,loc_end
5158         costtab(i+1) =dcos(theta(i+1))
5159         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5160         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5161         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5162         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5163         cosfac=dsqrt(cosfac2)
5164         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5165         sinfac=dsqrt(sinfac2)
5166         it=itype(i)
5167         if (it.eq.10) goto 1
5168 c
5169 C  Compute the axes of tghe local cartesian coordinates system; store in
5170 c   x_prime, y_prime and z_prime
5171 c
5172         do j=1,3
5173           x_prime(j) = 0.00
5174           y_prime(j) = 0.00
5175           z_prime(j) = 0.00
5176         enddo
5177 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5178 C     &   dc_norm(3,i+nres)
5179         do j = 1,3
5180           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5181           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5182         enddo
5183         do j = 1,3
5184           z_prime(j) = -uz(j,i-1)
5185         enddo
5186 c       write (2,*) "i",i
5187 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5188 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5189 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5190 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5191 c      & " xy",scalar(x_prime(1),y_prime(1)),
5192 c      & " xz",scalar(x_prime(1),z_prime(1)),
5193 c      & " yy",scalar(y_prime(1),y_prime(1)),
5194 c      & " yz",scalar(y_prime(1),z_prime(1)),
5195 c      & " zz",scalar(z_prime(1),z_prime(1))
5196 c
5197 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5198 C to local coordinate system. Store in xx, yy, zz.
5199 c
5200         xx=0.0d0
5201         yy=0.0d0
5202         zz=0.0d0
5203         do j = 1,3
5204           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5205           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5206           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5207         enddo
5208
5209         xxtab(i)=xx
5210         yytab(i)=yy
5211         zztab(i)=zz
5212 C
5213 C Compute the energy of the ith side cbain
5214 C
5215 c        write (2,*) "xx",xx," yy",yy," zz",zz
5216         it=itype(i)
5217         do j = 1,65
5218           x(j) = sc_parmin(j,it)
5219         enddo
5220 #ifdef CHECK_COORD
5221 Cc diagnostics - remove later
5222         xx1 = dcos(alph(2))
5223         yy1 = dsin(alph(2))*dcos(omeg(2))
5224         zz1 = -dsin(alph(2))*dsin(omeg(2))
5225         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5226      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5227      &    xx1,yy1,zz1
5228 C,"  --- ", xx_w,yy_w,zz_w
5229 c end diagnostics
5230 #endif
5231         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5232      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5233      &   + x(10)*yy*zz
5234         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5235      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5236      & + x(20)*yy*zz
5237         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5238      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5239      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5240      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5241      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5242      &  +x(40)*xx*yy*zz
5243         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5244      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5245      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5246      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5247      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5248      &  +x(60)*xx*yy*zz
5249         dsc_i   = 0.743d0+x(61)
5250         dp2_i   = 1.9d0+x(62)
5251         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5252      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5253         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5254      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5255         s1=(1+x(63))/(0.1d0 + dscp1)
5256         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5257         s2=(1+x(65))/(0.1d0 + dscp2)
5258         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5259         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5260      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5261 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5262 c     &   sumene4,
5263 c     &   dscp1,dscp2,sumene
5264 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5265         escloc = escloc + sumene
5266 c        write (2,*) "i",i," escloc",sumene,escloc
5267 #ifdef DEBUG
5268 C
5269 C This section to check the numerical derivatives of the energy of ith side
5270 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5271 C #define DEBUG in the code to turn it on.
5272 C
5273         write (2,*) "sumene               =",sumene
5274         aincr=1.0d-7
5275         xxsave=xx
5276         xx=xx+aincr
5277         write (2,*) xx,yy,zz
5278         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5279         de_dxx_num=(sumenep-sumene)/aincr
5280         xx=xxsave
5281         write (2,*) "xx+ sumene from enesc=",sumenep
5282         yysave=yy
5283         yy=yy+aincr
5284         write (2,*) xx,yy,zz
5285         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5286         de_dyy_num=(sumenep-sumene)/aincr
5287         yy=yysave
5288         write (2,*) "yy+ sumene from enesc=",sumenep
5289         zzsave=zz
5290         zz=zz+aincr
5291         write (2,*) xx,yy,zz
5292         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5293         de_dzz_num=(sumenep-sumene)/aincr
5294         zz=zzsave
5295         write (2,*) "zz+ sumene from enesc=",sumenep
5296         costsave=cost2tab(i+1)
5297         sintsave=sint2tab(i+1)
5298         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5299         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5300         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5301         de_dt_num=(sumenep-sumene)/aincr
5302         write (2,*) " t+ sumene from enesc=",sumenep
5303         cost2tab(i+1)=costsave
5304         sint2tab(i+1)=sintsave
5305 C End of diagnostics section.
5306 #endif
5307 C
5308 C Compute the gradient of esc
5309 C
5310         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5311         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5312         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5313         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5314         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5315         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5316         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5317         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5318         pom1=(sumene3*sint2tab(i+1)+sumene1)
5319      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5320         pom2=(sumene4*cost2tab(i+1)+sumene2)
5321      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5322         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5323         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5324      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5325      &  +x(40)*yy*zz
5326         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5327         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5328      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5329      &  +x(60)*yy*zz
5330         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5331      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5332      &        +(pom1+pom2)*pom_dx
5333 #ifdef DEBUG
5334         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5335 #endif
5336 C
5337         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5338         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5339      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5340      &  +x(40)*xx*zz
5341         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5342         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5343      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5344      &  +x(59)*zz**2 +x(60)*xx*zz
5345         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5346      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5347      &        +(pom1-pom2)*pom_dy
5348 #ifdef DEBUG
5349         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5350 #endif
5351 C
5352         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5353      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5354      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5355      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5356      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5357      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5358      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5359      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5360 #ifdef DEBUG
5361         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5362 #endif
5363 C
5364         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5365      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5366      &  +pom1*pom_dt1+pom2*pom_dt2
5367 #ifdef DEBUG
5368         write(2,*), "de_dt = ", de_dt,de_dt_num
5369 #endif
5370 c
5371 C
5372        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5373        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5374        cosfac2xx=cosfac2*xx
5375        sinfac2yy=sinfac2*yy
5376        do k = 1,3
5377          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5378      &      vbld_inv(i+1)
5379          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5380      &      vbld_inv(i)
5381          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5382          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5383 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5384 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5385 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5386 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5387          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5388          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5389          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5390          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5391          dZZ_Ci1(k)=0.0d0
5392          dZZ_Ci(k)=0.0d0
5393          do j=1,3
5394            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5395            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5396          enddo
5397
5398          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5399          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5400          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5401 c
5402          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5403          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5404        enddo
5405
5406        do k=1,3
5407          dXX_Ctab(k,i)=dXX_Ci(k)
5408          dXX_C1tab(k,i)=dXX_Ci1(k)
5409          dYY_Ctab(k,i)=dYY_Ci(k)
5410          dYY_C1tab(k,i)=dYY_Ci1(k)
5411          dZZ_Ctab(k,i)=dZZ_Ci(k)
5412          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5413          dXX_XYZtab(k,i)=dXX_XYZ(k)
5414          dYY_XYZtab(k,i)=dYY_XYZ(k)
5415          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5416        enddo
5417
5418        do k = 1,3
5419 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5420 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5421 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5422 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5423 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5424 c     &    dt_dci(k)
5425 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5426 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5427          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5428      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5429          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5430      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5431          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5432      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5433        enddo
5434 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5435 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5436
5437 C to check gradient call subroutine check_grad
5438
5439     1 continue
5440       enddo
5441       return
5442       end
5443 c------------------------------------------------------------------------------
5444       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5445       implicit none
5446       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5447      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5448       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5449      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5450      &   + x(10)*yy*zz
5451       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5452      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5453      & + x(20)*yy*zz
5454       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5455      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5456      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5457      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5458      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5459      &  +x(40)*xx*yy*zz
5460       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5461      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5462      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5463      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5464      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5465      &  +x(60)*xx*yy*zz
5466       dsc_i   = 0.743d0+x(61)
5467       dp2_i   = 1.9d0+x(62)
5468       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5469      &          *(xx*cost2+yy*sint2))
5470       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5471      &          *(xx*cost2-yy*sint2))
5472       s1=(1+x(63))/(0.1d0 + dscp1)
5473       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5474       s2=(1+x(65))/(0.1d0 + dscp2)
5475       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5476       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5477      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5478       enesc=sumene
5479       return
5480       end
5481 #endif
5482 c------------------------------------------------------------------------------
5483       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5484 C
5485 C This procedure calculates two-body contact function g(rij) and its derivative:
5486 C
5487 C           eps0ij                                     !       x < -1
5488 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5489 C            0                                         !       x > 1
5490 C
5491 C where x=(rij-r0ij)/delta
5492 C
5493 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5494 C
5495       implicit none
5496       double precision rij,r0ij,eps0ij,fcont,fprimcont
5497       double precision x,x2,x4,delta
5498 c     delta=0.02D0*r0ij
5499 c      delta=0.2D0*r0ij
5500       x=(rij-r0ij)/delta
5501       if (x.lt.-1.0D0) then
5502         fcont=eps0ij
5503         fprimcont=0.0D0
5504       else if (x.le.1.0D0) then
5505         x2=x*x
5506         x4=x2*x2
5507         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5508         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5509       else
5510         fcont=0.0D0
5511         fprimcont=0.0D0
5512       endif
5513       return
5514       end
5515 c------------------------------------------------------------------------------
5516       subroutine splinthet(theti,delta,ss,ssder)
5517       implicit real*8 (a-h,o-z)
5518       include 'DIMENSIONS'
5519       include 'COMMON.VAR'
5520       include 'COMMON.GEO'
5521       thetup=pi-delta
5522       thetlow=delta
5523       if (theti.gt.pipol) then
5524         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5525       else
5526         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5527         ssder=-ssder
5528       endif
5529       return
5530       end
5531 c------------------------------------------------------------------------------
5532       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5533       implicit none
5534       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5535       double precision ksi,ksi2,ksi3,a1,a2,a3
5536       a1=fprim0*delta/(f1-f0)
5537       a2=3.0d0-2.0d0*a1
5538       a3=a1-2.0d0
5539       ksi=(x-x0)/delta
5540       ksi2=ksi*ksi
5541       ksi3=ksi2*ksi
5542       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5543       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5544       return
5545       end
5546 c------------------------------------------------------------------------------
5547       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5548       implicit none
5549       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5550       double precision ksi,ksi2,ksi3,a1,a2,a3
5551       ksi=(x-x0)/delta
5552       ksi2=ksi*ksi
5553       ksi3=ksi2*ksi
5554       a1=fprim0x*delta
5555       a2=3*(f1x-f0x)-2*fprim0x*delta
5556       a3=fprim0x*delta-2*(f1x-f0x)
5557       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5558       return
5559       end
5560 C-----------------------------------------------------------------------------
5561 #ifdef CRYST_TOR
5562 C-----------------------------------------------------------------------------
5563       subroutine etor(etors,edihcnstr)
5564       implicit real*8 (a-h,o-z)
5565       include 'DIMENSIONS'
5566       include 'COMMON.VAR'
5567       include 'COMMON.GEO'
5568       include 'COMMON.LOCAL'
5569       include 'COMMON.TORSION'
5570       include 'COMMON.INTERACT'
5571       include 'COMMON.DERIV'
5572       include 'COMMON.CHAIN'
5573       include 'COMMON.NAMES'
5574       include 'COMMON.IOUNITS'
5575       include 'COMMON.FFIELD'
5576       include 'COMMON.TORCNSTR'
5577       include 'COMMON.CONTROL'
5578       logical lprn
5579 C Set lprn=.true. for debugging
5580       lprn=.false.
5581 c      lprn=.true.
5582       etors=0.0D0
5583       do i=iphi_start,iphi_end
5584       etors_ii=0.0D0
5585         itori=itortyp(itype(i-2))
5586         itori1=itortyp(itype(i-1))
5587         phii=phi(i)
5588         gloci=0.0D0
5589 C Proline-Proline pair is a special case...
5590         if (itori.eq.3 .and. itori1.eq.3) then
5591           if (phii.gt.-dwapi3) then
5592             cosphi=dcos(3*phii)
5593             fac=1.0D0/(1.0D0-cosphi)
5594             etorsi=v1(1,3,3)*fac
5595             etorsi=etorsi+etorsi
5596             etors=etors+etorsi-v1(1,3,3)
5597             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5598             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5599           endif
5600           do j=1,3
5601             v1ij=v1(j+1,itori,itori1)
5602             v2ij=v2(j+1,itori,itori1)
5603             cosphi=dcos(j*phii)
5604             sinphi=dsin(j*phii)
5605             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5606             if (energy_dec) etors_ii=etors_ii+
5607      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5608             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5609           enddo
5610         else
5611           do j=1,nterm_old
5612             v1ij=v1(j,itori,itori1)
5613             v2ij=v2(j,itori,itori1)
5614             cosphi=dcos(j*phii)
5615             sinphi=dsin(j*phii)
5616             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5617             if (energy_dec) etors_ii=etors_ii+
5618      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5619             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5620           enddo
5621         endif
5622         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5623      &        'etor',i,etors_ii
5624         if (lprn)
5625      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5626      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5627      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5628         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5629 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5630       enddo
5631 ! 6/20/98 - dihedral angle constraints
5632       edihcnstr=0.0d0
5633       do i=1,ndih_constr
5634         itori=idih_constr(i)
5635         phii=phi(itori)
5636         difi=phii-phi0(i)
5637         if (difi.gt.drange(i)) then
5638           difi=difi-drange(i)
5639           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5640           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5641         else if (difi.lt.-drange(i)) then
5642           difi=difi+drange(i)
5643           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5644           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5645         endif
5646 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5647 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5648       enddo
5649 !      write (iout,*) 'edihcnstr',edihcnstr
5650       return
5651       end
5652 c------------------------------------------------------------------------------
5653       subroutine etor_d(etors_d)
5654       etors_d=0.0d0
5655       return
5656       end
5657 c----------------------------------------------------------------------------
5658 #else
5659       subroutine etor(etors,edihcnstr)
5660       implicit real*8 (a-h,o-z)
5661       include 'DIMENSIONS'
5662       include 'COMMON.VAR'
5663       include 'COMMON.GEO'
5664       include 'COMMON.LOCAL'
5665       include 'COMMON.TORSION'
5666       include 'COMMON.INTERACT'
5667       include 'COMMON.DERIV'
5668       include 'COMMON.CHAIN'
5669       include 'COMMON.NAMES'
5670       include 'COMMON.IOUNITS'
5671       include 'COMMON.FFIELD'
5672       include 'COMMON.TORCNSTR'
5673       include 'COMMON.CONTROL'
5674       logical lprn
5675 C Set lprn=.true. for debugging
5676       lprn=.false.
5677 c     lprn=.true.
5678       etors=0.0D0
5679       do i=iphi_start,iphi_end
5680       etors_ii=0.0D0
5681         itori=itortyp(itype(i-2))
5682         itori1=itortyp(itype(i-1))
5683         phii=phi(i)
5684         gloci=0.0D0
5685 C Regular cosine and sine terms
5686         do j=1,nterm(itori,itori1)
5687           v1ij=v1(j,itori,itori1)
5688           v2ij=v2(j,itori,itori1)
5689           cosphi=dcos(j*phii)
5690           sinphi=dsin(j*phii)
5691           etors=etors+v1ij*cosphi+v2ij*sinphi
5692           if (energy_dec) etors_ii=etors_ii+
5693      &                v1ij*cosphi+v2ij*sinphi
5694           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5695         enddo
5696 C Lorentz terms
5697 C                         v1
5698 C  E = SUM ----------------------------------- - v1
5699 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5700 C
5701         cosphi=dcos(0.5d0*phii)
5702         sinphi=dsin(0.5d0*phii)
5703         do j=1,nlor(itori,itori1)
5704           vl1ij=vlor1(j,itori,itori1)
5705           vl2ij=vlor2(j,itori,itori1)
5706           vl3ij=vlor3(j,itori,itori1)
5707           pom=vl2ij*cosphi+vl3ij*sinphi
5708           pom1=1.0d0/(pom*pom+1.0d0)
5709           etors=etors+vl1ij*pom1
5710           if (energy_dec) etors_ii=etors_ii+
5711      &                vl1ij*pom1
5712           pom=-pom*pom1*pom1
5713           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5714         enddo
5715 C Subtract the constant term
5716         etors=etors-v0(itori,itori1)
5717           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5718      &         'etor',i,etors_ii-v0(itori,itori1)
5719         if (lprn)
5720      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5721      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5722      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5723         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5724 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5725       enddo
5726 ! 6/20/98 - dihedral angle constraints
5727       edihcnstr=0.0d0
5728 c      do i=1,ndih_constr
5729       do i=idihconstr_start,idihconstr_end
5730         itori=idih_constr(i)
5731         phii=phi(itori)
5732         difi=pinorm(phii-phi0(i))
5733         if (difi.gt.drange(i)) then
5734           difi=difi-drange(i)
5735           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5736           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5737         else if (difi.lt.-drange(i)) then
5738           difi=difi+drange(i)
5739           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5740           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5741         else
5742           difi=0.0
5743         endif
5744 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5745 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5746 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5747       enddo
5748 cd       write (iout,*) 'edihcnstr',edihcnstr
5749       return
5750       end
5751 c----------------------------------------------------------------------------
5752       subroutine etor_d(etors_d)
5753 C 6/23/01 Compute double torsional energy
5754       implicit real*8 (a-h,o-z)
5755       include 'DIMENSIONS'
5756       include 'COMMON.VAR'
5757       include 'COMMON.GEO'
5758       include 'COMMON.LOCAL'
5759       include 'COMMON.TORSION'
5760       include 'COMMON.INTERACT'
5761       include 'COMMON.DERIV'
5762       include 'COMMON.CHAIN'
5763       include 'COMMON.NAMES'
5764       include 'COMMON.IOUNITS'
5765       include 'COMMON.FFIELD'
5766       include 'COMMON.TORCNSTR'
5767       logical lprn
5768 C Set lprn=.true. for debugging
5769       lprn=.false.
5770 c     lprn=.true.
5771       etors_d=0.0D0
5772       do i=iphid_start,iphid_end
5773         itori=itortyp(itype(i-2))
5774         itori1=itortyp(itype(i-1))
5775         itori2=itortyp(itype(i))
5776         phii=phi(i)
5777         phii1=phi(i+1)
5778         gloci1=0.0D0
5779         gloci2=0.0D0
5780 C Regular cosine and sine terms
5781         do j=1,ntermd_1(itori,itori1,itori2)
5782           v1cij=v1c(1,j,itori,itori1,itori2)
5783           v1sij=v1s(1,j,itori,itori1,itori2)
5784           v2cij=v1c(2,j,itori,itori1,itori2)
5785           v2sij=v1s(2,j,itori,itori1,itori2)
5786           cosphi1=dcos(j*phii)
5787           sinphi1=dsin(j*phii)
5788           cosphi2=dcos(j*phii1)
5789           sinphi2=dsin(j*phii1)
5790           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5791      &     v2cij*cosphi2+v2sij*sinphi2
5792           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5793           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5794         enddo
5795         do k=2,ntermd_2(itori,itori1,itori2)
5796           do l=1,k-1
5797             v1cdij = v2c(k,l,itori,itori1,itori2)
5798             v2cdij = v2c(l,k,itori,itori1,itori2)
5799             v1sdij = v2s(k,l,itori,itori1,itori2)
5800             v2sdij = v2s(l,k,itori,itori1,itori2)
5801             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5802             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5803             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5804             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5805             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5806      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5807             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5808      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5809             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5810      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5811           enddo
5812         enddo
5813         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5814         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5815       enddo
5816       return
5817       end
5818 #endif
5819 c------------------------------------------------------------------------------
5820       subroutine eback_sc_corr(esccor)
5821 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5822 c        conformational states; temporarily implemented as differences
5823 c        between UNRES torsional potentials (dependent on three types of
5824 c        residues) and the torsional potentials dependent on all 20 types
5825 c        of residues computed from AM1  energy surfaces of terminally-blocked
5826 c        amino-acid residues.
5827       implicit real*8 (a-h,o-z)
5828       include 'DIMENSIONS'
5829       include 'COMMON.VAR'
5830       include 'COMMON.GEO'
5831       include 'COMMON.LOCAL'
5832       include 'COMMON.TORSION'
5833       include 'COMMON.SCCOR'
5834       include 'COMMON.INTERACT'
5835       include 'COMMON.DERIV'
5836       include 'COMMON.CHAIN'
5837       include 'COMMON.NAMES'
5838       include 'COMMON.IOUNITS'
5839       include 'COMMON.FFIELD'
5840       include 'COMMON.CONTROL'
5841       logical lprn
5842 C Set lprn=.true. for debugging
5843       lprn=.false.
5844 c      lprn=.true.
5845 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5846       esccor=0.0D0
5847       do i=iphi_start,iphi_end
5848         esccor_ii=0.0D0
5849         itori=itype(i-2)
5850         itori1=itype(i-1)
5851         phii=phi(i)
5852         gloci=0.0D0
5853         do j=1,nterm_sccor
5854           v1ij=v1sccor(j,itori,itori1)
5855           v2ij=v2sccor(j,itori,itori1)
5856           cosphi=dcos(j*phii)
5857           sinphi=dsin(j*phii)
5858           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5859           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5860         enddo
5861         if (lprn)
5862      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5863      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5864      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5865         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5866       enddo
5867       return
5868       end
5869 c----------------------------------------------------------------------------
5870       subroutine multibody(ecorr)
5871 C This subroutine calculates multi-body contributions to energy following
5872 C the idea of Skolnick et al. If side chains I and J make a contact and
5873 C at the same time side chains I+1 and J+1 make a contact, an extra
5874 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5875       implicit real*8 (a-h,o-z)
5876       include 'DIMENSIONS'
5877       include 'COMMON.IOUNITS'
5878       include 'COMMON.DERIV'
5879       include 'COMMON.INTERACT'
5880       include 'COMMON.CONTACTS'
5881       double precision gx(3),gx1(3)
5882       logical lprn
5883
5884 C Set lprn=.true. for debugging
5885       lprn=.false.
5886
5887       if (lprn) then
5888         write (iout,'(a)') 'Contact function values:'
5889         do i=nnt,nct-2
5890           write (iout,'(i2,20(1x,i2,f10.5))')
5891      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5892         enddo
5893       endif
5894       ecorr=0.0D0
5895       do i=nnt,nct
5896         do j=1,3
5897           gradcorr(j,i)=0.0D0
5898           gradxorr(j,i)=0.0D0
5899         enddo
5900       enddo
5901       do i=nnt,nct-2
5902
5903         DO ISHIFT = 3,4
5904
5905         i1=i+ishift
5906         num_conti=num_cont(i)
5907         num_conti1=num_cont(i1)
5908         do jj=1,num_conti
5909           j=jcont(jj,i)
5910           do kk=1,num_conti1
5911             j1=jcont(kk,i1)
5912             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5913 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5914 cd   &                   ' ishift=',ishift
5915 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5916 C The system gains extra energy.
5917               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5918             endif   ! j1==j+-ishift
5919           enddo     ! kk
5920         enddo       ! jj
5921
5922         ENDDO ! ISHIFT
5923
5924       enddo         ! i
5925       return
5926       end
5927 c------------------------------------------------------------------------------
5928       double precision function esccorr(i,j,k,l,jj,kk)
5929       implicit real*8 (a-h,o-z)
5930       include 'DIMENSIONS'
5931       include 'COMMON.IOUNITS'
5932       include 'COMMON.DERIV'
5933       include 'COMMON.INTERACT'
5934       include 'COMMON.CONTACTS'
5935       double precision gx(3),gx1(3)
5936       logical lprn
5937       lprn=.false.
5938       eij=facont(jj,i)
5939       ekl=facont(kk,k)
5940 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5941 C Calculate the multi-body contribution to energy.
5942 C Calculate multi-body contributions to the gradient.
5943 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5944 cd   & k,l,(gacont(m,kk,k),m=1,3)
5945       do m=1,3
5946         gx(m) =ekl*gacont(m,jj,i)
5947         gx1(m)=eij*gacont(m,kk,k)
5948         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5949         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5950         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5951         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5952       enddo
5953       do m=i,j-1
5954         do ll=1,3
5955           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5956         enddo
5957       enddo
5958       do m=k,l-1
5959         do ll=1,3
5960           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5961         enddo
5962       enddo
5963       esccorr=-eij*ekl
5964       return
5965       end
5966 c------------------------------------------------------------------------------
5967       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5968 C This subroutine calculates multi-body contributions to hydrogen-bonding
5969       implicit real*8 (a-h,o-z)
5970       include 'DIMENSIONS'
5971       include 'COMMON.IOUNITS'
5972 #ifdef MPI
5973       include "mpif.h"
5974       parameter (max_cont=maxconts)
5975       parameter (max_dim=26)
5976       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5977       double precision zapas(max_dim,maxconts,max_fg_procs),
5978      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5979       common /przechowalnia/ zapas
5980       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5981      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5982 #endif
5983       include 'COMMON.SETUP'
5984       include 'COMMON.FFIELD'
5985       include 'COMMON.DERIV'
5986       include 'COMMON.INTERACT'
5987       include 'COMMON.CONTACTS'
5988       include 'COMMON.CONTROL'
5989       include 'COMMON.LOCAL'
5990       double precision gx(3),gx1(3),time00
5991       logical lprn,ldone
5992
5993 C Set lprn=.true. for debugging
5994       lprn=.false.
5995 #ifdef MPI
5996       n_corr=0
5997       n_corr1=0
5998       if (nfgtasks.le.1) goto 30
5999       if (lprn) then
6000         write (iout,'(a)') 'Contact function values before RECEIVE:'
6001         do i=nnt,nct-2
6002           write (iout,'(2i3,50(1x,i2,f5.2))')
6003      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6004      &    j=1,num_cont_hb(i))
6005         enddo
6006       endif
6007       call flush(iout)
6008       do i=1,ntask_cont_from
6009         ncont_recv(i)=0
6010       enddo
6011       do i=1,ntask_cont_to
6012         ncont_sent(i)=0
6013       enddo
6014 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6015 c     & ntask_cont_to
6016 C Make the list of contacts to send to send to other procesors
6017 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6018 c      call flush(iout)
6019       do i=iturn3_start,iturn3_end
6020 c        write (iout,*) "make contact list turn3",i," num_cont",
6021 c     &    num_cont_hb(i)
6022         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6023       enddo
6024       do i=iturn4_start,iturn4_end
6025 c        write (iout,*) "make contact list turn4",i," num_cont",
6026 c     &   num_cont_hb(i)
6027         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6028       enddo
6029       do ii=1,nat_sent
6030         i=iat_sent(ii)
6031 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6032 c     &    num_cont_hb(i)
6033         do j=1,num_cont_hb(i)
6034         do k=1,4
6035           jjc=jcont_hb(j,i)
6036           iproc=iint_sent_local(k,jjc,ii)
6037 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6038           if (iproc.gt.0) then
6039             ncont_sent(iproc)=ncont_sent(iproc)+1
6040             nn=ncont_sent(iproc)
6041             zapas(1,nn,iproc)=i
6042             zapas(2,nn,iproc)=jjc
6043             zapas(3,nn,iproc)=facont_hb(j,i)
6044             zapas(4,nn,iproc)=ees0p(j,i)
6045             zapas(5,nn,iproc)=ees0m(j,i)
6046             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6047             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6048             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6049             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6050             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6051             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6052             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6053             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6054             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6055             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6056             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6057             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6058             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6059             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6060             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6061             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6062             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6063             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6064             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6065             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6066             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6067           endif
6068         enddo
6069         enddo
6070       enddo
6071       if (lprn) then
6072       write (iout,*)
6073      &  "Numbers of contacts to be sent to other processors",
6074      &  (ncont_sent(i),i=1,ntask_cont_to)
6075       write (iout,*) "Contacts sent"
6076       do ii=1,ntask_cont_to
6077         nn=ncont_sent(ii)
6078         iproc=itask_cont_to(ii)
6079         write (iout,*) nn," contacts to processor",iproc,
6080      &   " of CONT_TO_COMM group"
6081         do i=1,nn
6082           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6083         enddo
6084       enddo
6085       call flush(iout)
6086       endif
6087       CorrelType=477
6088       CorrelID=fg_rank+1
6089       CorrelType1=478
6090       CorrelID1=nfgtasks+fg_rank+1
6091       ireq=0
6092 C Receive the numbers of needed contacts from other processors
6093       do ii=1,ntask_cont_from
6094         iproc=itask_cont_from(ii)
6095         ireq=ireq+1
6096         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6097      &    FG_COMM,req(ireq),IERR)
6098       enddo
6099 c      write (iout,*) "IRECV ended"
6100 c      call flush(iout)
6101 C Send the number of contacts needed by other processors
6102       do ii=1,ntask_cont_to
6103         iproc=itask_cont_to(ii)
6104         ireq=ireq+1
6105         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6106      &    FG_COMM,req(ireq),IERR)
6107       enddo
6108 c      write (iout,*) "ISEND ended"
6109 c      write (iout,*) "number of requests (nn)",ireq
6110       call flush(iout)
6111       if (ireq.gt.0)
6112      &  call MPI_Waitall(ireq,req,status_array,ierr)
6113 c      write (iout,*)
6114 c     &  "Numbers of contacts to be received from other processors",
6115 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6116 c      call flush(iout)
6117 C Receive contacts
6118       ireq=0
6119       do ii=1,ntask_cont_from
6120         iproc=itask_cont_from(ii)
6121         nn=ncont_recv(ii)
6122 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6123 c     &   " of CONT_TO_COMM group"
6124         call flush(iout)
6125         if (nn.gt.0) then
6126           ireq=ireq+1
6127           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6128      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6129 c          write (iout,*) "ireq,req",ireq,req(ireq)
6130         endif
6131       enddo
6132 C Send the contacts to processors that need them
6133       do ii=1,ntask_cont_to
6134         iproc=itask_cont_to(ii)
6135         nn=ncont_sent(ii)
6136 c        write (iout,*) nn," contacts to processor",iproc,
6137 c     &   " of CONT_TO_COMM group"
6138         if (nn.gt.0) then
6139           ireq=ireq+1
6140           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6141      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6142 c          write (iout,*) "ireq,req",ireq,req(ireq)
6143 c          do i=1,nn
6144 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6145 c          enddo
6146         endif
6147       enddo
6148 c      write (iout,*) "number of requests (contacts)",ireq
6149 c      write (iout,*) "req",(req(i),i=1,4)
6150 c      call flush(iout)
6151       if (ireq.gt.0)
6152      & call MPI_Waitall(ireq,req,status_array,ierr)
6153       do iii=1,ntask_cont_from
6154         iproc=itask_cont_from(iii)
6155         nn=ncont_recv(iii)
6156         if (lprn) then
6157         write (iout,*) "Received",nn," contacts from processor",iproc,
6158      &   " of CONT_FROM_COMM group"
6159         call flush(iout)
6160         do i=1,nn
6161           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6162         enddo
6163         call flush(iout)
6164         endif
6165         do i=1,nn
6166           ii=zapas_recv(1,i,iii)
6167 c Flag the received contacts to prevent double-counting
6168           jj=-zapas_recv(2,i,iii)
6169 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6170 c          call flush(iout)
6171           nnn=num_cont_hb(ii)+1
6172           num_cont_hb(ii)=nnn
6173           jcont_hb(nnn,ii)=jj
6174           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6175           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6176           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6177           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6178           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6179           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6180           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6181           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6182           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6183           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6184           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6185           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6186           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6187           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6188           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6189           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6190           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6191           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6192           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6193           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6194           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6195           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6196           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6197           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6198         enddo
6199       enddo
6200       call flush(iout)
6201       if (lprn) then
6202         write (iout,'(a)') 'Contact function values after receive:'
6203         do i=nnt,nct-2
6204           write (iout,'(2i3,50(1x,i3,f5.2))')
6205      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6206      &    j=1,num_cont_hb(i))
6207         enddo
6208         call flush(iout)
6209       endif
6210    30 continue
6211 #endif
6212       if (lprn) then
6213         write (iout,'(a)') 'Contact function values:'
6214         do i=nnt,nct-2
6215           write (iout,'(2i3,50(1x,i3,f5.2))')
6216      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6217      &    j=1,num_cont_hb(i))
6218         enddo
6219       endif
6220       ecorr=0.0D0
6221 C Remove the loop below after debugging !!!
6222       do i=nnt,nct
6223         do j=1,3
6224           gradcorr(j,i)=0.0D0
6225           gradxorr(j,i)=0.0D0
6226         enddo
6227       enddo
6228 C Calculate the local-electrostatic correlation terms
6229       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6230         i1=i+1
6231         num_conti=num_cont_hb(i)
6232         num_conti1=num_cont_hb(i+1)
6233         do jj=1,num_conti
6234           j=jcont_hb(jj,i)
6235           jp=iabs(j)
6236           do kk=1,num_conti1
6237             j1=jcont_hb(kk,i1)
6238             jp1=iabs(j1)
6239 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6240 c     &         ' jj=',jj,' kk=',kk
6241             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6242      &          .or. j.lt.0 .and. j1.gt.0) .and.
6243      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6244 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6245 C The system gains extra energy.
6246               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6247               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6248      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6249               n_corr=n_corr+1
6250             else if (j1.eq.j) then
6251 C Contacts I-J and I-(J+1) occur simultaneously.
6252 C The system loses extra energy.
6253 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6254             endif
6255           enddo ! kk
6256           do kk=1,num_conti
6257             j1=jcont_hb(kk,i)
6258 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6259 c    &         ' jj=',jj,' kk=',kk
6260             if (j1.eq.j+1) then
6261 C Contacts I-J and (I+1)-J occur simultaneously.
6262 C The system loses extra energy.
6263 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6264             endif ! j1==j+1
6265           enddo ! kk
6266         enddo ! jj
6267       enddo ! i
6268       return
6269       end
6270 c------------------------------------------------------------------------------
6271       subroutine add_hb_contact(ii,jj,itask)
6272       implicit real*8 (a-h,o-z)
6273       include "DIMENSIONS"
6274       include "COMMON.IOUNITS"
6275       integer max_cont
6276       integer max_dim
6277       parameter (max_cont=maxconts)
6278       parameter (max_dim=26)
6279       include "COMMON.CONTACTS"
6280       double precision zapas(max_dim,maxconts,max_fg_procs),
6281      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6282       common /przechowalnia/ zapas
6283       integer i,j,ii,jj,iproc,itask(4),nn
6284 c      write (iout,*) "itask",itask
6285       do i=1,2
6286         iproc=itask(i)
6287         if (iproc.gt.0) then
6288           do j=1,num_cont_hb(ii)
6289             jjc=jcont_hb(j,ii)
6290 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6291             if (jjc.eq.jj) then
6292               ncont_sent(iproc)=ncont_sent(iproc)+1
6293               nn=ncont_sent(iproc)
6294               zapas(1,nn,iproc)=ii
6295               zapas(2,nn,iproc)=jjc
6296               zapas(3,nn,iproc)=facont_hb(j,ii)
6297               zapas(4,nn,iproc)=ees0p(j,ii)
6298               zapas(5,nn,iproc)=ees0m(j,ii)
6299               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6300               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6301               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6302               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6303               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6304               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6305               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6306               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6307               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6308               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6309               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6310               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6311               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6312               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6313               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6314               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6315               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6316               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6317               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6318               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6319               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6320               exit
6321             endif
6322           enddo
6323         endif
6324       enddo
6325       return
6326       end
6327 c------------------------------------------------------------------------------
6328       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6329      &  n_corr1)
6330 C This subroutine calculates multi-body contributions to hydrogen-bonding
6331       implicit real*8 (a-h,o-z)
6332       include 'DIMENSIONS'
6333       include 'COMMON.IOUNITS'
6334 #ifdef MPI
6335       include "mpif.h"
6336       parameter (max_cont=maxconts)
6337       parameter (max_dim=70)
6338       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6339       double precision zapas(max_dim,maxconts,max_fg_procs),
6340      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6341       common /przechowalnia/ zapas
6342       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6343      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6344 #endif
6345       include 'COMMON.SETUP'
6346       include 'COMMON.FFIELD'
6347       include 'COMMON.DERIV'
6348       include 'COMMON.LOCAL'
6349       include 'COMMON.INTERACT'
6350       include 'COMMON.CONTACTS'
6351       include 'COMMON.CHAIN'
6352       include 'COMMON.CONTROL'
6353       double precision gx(3),gx1(3)
6354       integer num_cont_hb_old(maxres)
6355       logical lprn,ldone
6356       double precision eello4,eello5,eelo6,eello_turn6
6357       external eello4,eello5,eello6,eello_turn6
6358 C Set lprn=.true. for debugging
6359       lprn=.false.
6360       eturn6=0.0d0
6361 #ifdef MPI
6362       do i=1,nres
6363         num_cont_hb_old(i)=num_cont_hb(i)
6364       enddo
6365       n_corr=0
6366       n_corr1=0
6367       if (nfgtasks.le.1) goto 30
6368       if (lprn) then
6369         write (iout,'(a)') 'Contact function values before RECEIVE:'
6370         do i=nnt,nct-2
6371           write (iout,'(2i3,50(1x,i2,f5.2))')
6372      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6373      &    j=1,num_cont_hb(i))
6374         enddo
6375       endif
6376       call flush(iout)
6377       do i=1,ntask_cont_from
6378         ncont_recv(i)=0
6379       enddo
6380       do i=1,ntask_cont_to
6381         ncont_sent(i)=0
6382       enddo
6383 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6384 c     & ntask_cont_to
6385 C Make the list of contacts to send to send to other procesors
6386       do i=iturn3_start,iturn3_end
6387 c        write (iout,*) "make contact list turn3",i," num_cont",
6388 c     &    num_cont_hb(i)
6389         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6390       enddo
6391       do i=iturn4_start,iturn4_end
6392 c        write (iout,*) "make contact list turn4",i," num_cont",
6393 c     &   num_cont_hb(i)
6394         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6395       enddo
6396       do ii=1,nat_sent
6397         i=iat_sent(ii)
6398 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6399 c     &    num_cont_hb(i)
6400         do j=1,num_cont_hb(i)
6401         do k=1,4
6402           jjc=jcont_hb(j,i)
6403           iproc=iint_sent_local(k,jjc,ii)
6404 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6405           if (iproc.ne.0) then
6406             ncont_sent(iproc)=ncont_sent(iproc)+1
6407             nn=ncont_sent(iproc)
6408             zapas(1,nn,iproc)=i
6409             zapas(2,nn,iproc)=jjc
6410             zapas(3,nn,iproc)=d_cont(j,i)
6411             ind=3
6412             do kk=1,3
6413               ind=ind+1
6414               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6415             enddo
6416             do kk=1,2
6417               do ll=1,2
6418                 ind=ind+1
6419                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6420               enddo
6421             enddo
6422             do jj=1,5
6423               do kk=1,3
6424                 do ll=1,2
6425                   do mm=1,2
6426                     ind=ind+1
6427                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6428                   enddo
6429                 enddo
6430               enddo
6431             enddo
6432           endif
6433         enddo
6434         enddo
6435       enddo
6436       if (lprn) then
6437       write (iout,*)
6438      &  "Numbers of contacts to be sent to other processors",
6439      &  (ncont_sent(i),i=1,ntask_cont_to)
6440       write (iout,*) "Contacts sent"
6441       do ii=1,ntask_cont_to
6442         nn=ncont_sent(ii)
6443         iproc=itask_cont_to(ii)
6444         write (iout,*) nn," contacts to processor",iproc,
6445      &   " of CONT_TO_COMM group"
6446         do i=1,nn
6447           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6448         enddo
6449       enddo
6450       call flush(iout)
6451       endif
6452       CorrelType=477
6453       CorrelID=fg_rank+1
6454       CorrelType1=478
6455       CorrelID1=nfgtasks+fg_rank+1
6456       ireq=0
6457 C Receive the numbers of needed contacts from other processors
6458       do ii=1,ntask_cont_from
6459         iproc=itask_cont_from(ii)
6460         ireq=ireq+1
6461         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6462      &    FG_COMM,req(ireq),IERR)
6463       enddo
6464 c      write (iout,*) "IRECV ended"
6465 c      call flush(iout)
6466 C Send the number of contacts needed by other processors
6467       do ii=1,ntask_cont_to
6468         iproc=itask_cont_to(ii)
6469         ireq=ireq+1
6470         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6471      &    FG_COMM,req(ireq),IERR)
6472       enddo
6473 c      write (iout,*) "ISEND ended"
6474 c      write (iout,*) "number of requests (nn)",ireq
6475       call flush(iout)
6476       if (ireq.gt.0)
6477      &  call MPI_Waitall(ireq,req,status_array,ierr)
6478 c      write (iout,*)
6479 c     &  "Numbers of contacts to be received from other processors",
6480 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6481 c      call flush(iout)
6482 C Receive contacts
6483       ireq=0
6484       do ii=1,ntask_cont_from
6485         iproc=itask_cont_from(ii)
6486         nn=ncont_recv(ii)
6487 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6488 c     &   " of CONT_TO_COMM group"
6489         call flush(iout)
6490         if (nn.gt.0) then
6491           ireq=ireq+1
6492           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6493      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6494 c          write (iout,*) "ireq,req",ireq,req(ireq)
6495         endif
6496       enddo
6497 C Send the contacts to processors that need them
6498       do ii=1,ntask_cont_to
6499         iproc=itask_cont_to(ii)
6500         nn=ncont_sent(ii)
6501 c        write (iout,*) nn," contacts to processor",iproc,
6502 c     &   " of CONT_TO_COMM group"
6503         if (nn.gt.0) then
6504           ireq=ireq+1
6505           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6506      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6507 c          write (iout,*) "ireq,req",ireq,req(ireq)
6508 c          do i=1,nn
6509 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6510 c          enddo
6511         endif
6512       enddo
6513 c      write (iout,*) "number of requests (contacts)",ireq
6514 c      write (iout,*) "req",(req(i),i=1,4)
6515 c      call flush(iout)
6516       if (ireq.gt.0)
6517      & call MPI_Waitall(ireq,req,status_array,ierr)
6518       do iii=1,ntask_cont_from
6519         iproc=itask_cont_from(iii)
6520         nn=ncont_recv(iii)
6521         if (lprn) then
6522         write (iout,*) "Received",nn," contacts from processor",iproc,
6523      &   " of CONT_FROM_COMM group"
6524         call flush(iout)
6525         do i=1,nn
6526           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6527         enddo
6528         call flush(iout)
6529         endif
6530         do i=1,nn
6531           ii=zapas_recv(1,i,iii)
6532 c Flag the received contacts to prevent double-counting
6533           jj=-zapas_recv(2,i,iii)
6534 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6535 c          call flush(iout)
6536           nnn=num_cont_hb(ii)+1
6537           num_cont_hb(ii)=nnn
6538           jcont_hb(nnn,ii)=jj
6539           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6540           ind=3
6541           do kk=1,3
6542             ind=ind+1
6543             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6544           enddo
6545           do kk=1,2
6546             do ll=1,2
6547               ind=ind+1
6548               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6549             enddo
6550           enddo
6551           do jj=1,5
6552             do kk=1,3
6553               do ll=1,2
6554                 do mm=1,2
6555                   ind=ind+1
6556                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6557                 enddo
6558               enddo
6559             enddo
6560           enddo
6561         enddo
6562       enddo
6563       call flush(iout)
6564       if (lprn) then
6565         write (iout,'(a)') 'Contact function values after receive:'
6566         do i=nnt,nct-2
6567           write (iout,'(2i3,50(1x,i3,5f6.3))')
6568      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6569      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6570         enddo
6571         call flush(iout)
6572       endif
6573    30 continue
6574 #endif
6575       if (lprn) then
6576         write (iout,'(a)') 'Contact function values:'
6577         do i=nnt,nct-2
6578           write (iout,'(2i3,50(1x,i2,5f6.3))')
6579      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6580      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6581         enddo
6582       endif
6583       ecorr=0.0D0
6584       ecorr5=0.0d0
6585       ecorr6=0.0d0
6586 C Remove the loop below after debugging !!!
6587       do i=nnt,nct
6588         do j=1,3
6589           gradcorr(j,i)=0.0D0
6590           gradxorr(j,i)=0.0D0
6591         enddo
6592       enddo
6593 C Calculate the dipole-dipole interaction energies
6594       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6595       do i=iatel_s,iatel_e+1
6596         num_conti=num_cont_hb(i)
6597         do jj=1,num_conti
6598           j=jcont_hb(jj,i)
6599 #ifdef MOMENT
6600           call dipole(i,j,jj)
6601 #endif
6602         enddo
6603       enddo
6604       endif
6605 C Calculate the local-electrostatic correlation terms
6606 c                write (iout,*) "gradcorr5 in eello5 before loop"
6607 c                do iii=1,nres
6608 c                  write (iout,'(i5,3f10.5)')
6609 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6610 c                enddo
6611       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6612 c        write (iout,*) "corr loop i",i
6613         i1=i+1
6614         num_conti=num_cont_hb(i)
6615         num_conti1=num_cont_hb(i+1)
6616         do jj=1,num_conti
6617           j=jcont_hb(jj,i)
6618           jp=iabs(j)
6619           do kk=1,num_conti1
6620             j1=jcont_hb(kk,i1)
6621             jp1=iabs(j1)
6622 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6623 c     &         ' jj=',jj,' kk=',kk
6624 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6625             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6626      &          .or. j.lt.0 .and. j1.gt.0) .and.
6627      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6628 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6629 C The system gains extra energy.
6630               n_corr=n_corr+1
6631               sqd1=dsqrt(d_cont(jj,i))
6632               sqd2=dsqrt(d_cont(kk,i1))
6633               sred_geom = sqd1*sqd2
6634               IF (sred_geom.lt.cutoff_corr) THEN
6635                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6636      &            ekont,fprimcont)
6637 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6638 cd     &         ' jj=',jj,' kk=',kk
6639                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6640                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6641                 do l=1,3
6642                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6643                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6644                 enddo
6645                 n_corr1=n_corr1+1
6646 cd               write (iout,*) 'sred_geom=',sred_geom,
6647 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6648 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6649 cd               write (iout,*) "g_contij",g_contij
6650 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6651 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6652                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6653                 if (wcorr4.gt.0.0d0)
6654      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6655                   if (energy_dec.and.wcorr4.gt.0.0d0)
6656      1                 write (iout,'(a6,4i5,0pf7.3)')
6657      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6658 c                write (iout,*) "gradcorr5 before eello5"
6659 c                do iii=1,nres
6660 c                  write (iout,'(i5,3f10.5)')
6661 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6662 c                enddo
6663                 if (wcorr5.gt.0.0d0)
6664      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6665 c                write (iout,*) "gradcorr5 after eello5"
6666 c                do iii=1,nres
6667 c                  write (iout,'(i5,3f10.5)')
6668 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6669 c                enddo
6670                   if (energy_dec.and.wcorr5.gt.0.0d0)
6671      1                 write (iout,'(a6,4i5,0pf7.3)')
6672      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6673 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6674 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6675                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6676      &               .or. wturn6.eq.0.0d0))then
6677 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6678                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6679                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6680      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6681 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6682 cd     &            'ecorr6=',ecorr6
6683 cd                write (iout,'(4e15.5)') sred_geom,
6684 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6685 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6686 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6687                 else if (wturn6.gt.0.0d0
6688      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6689 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6690                   eturn6=eturn6+eello_turn6(i,jj,kk)
6691                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6692      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6693 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6694                 endif
6695               ENDIF
6696 1111          continue
6697             endif
6698           enddo ! kk
6699         enddo ! jj
6700       enddo ! i
6701       do i=1,nres
6702         num_cont_hb(i)=num_cont_hb_old(i)
6703       enddo
6704 c                write (iout,*) "gradcorr5 in eello5"
6705 c                do iii=1,nres
6706 c                  write (iout,'(i5,3f10.5)')
6707 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6708 c                enddo
6709       return
6710       end
6711 c------------------------------------------------------------------------------
6712       subroutine add_hb_contact_eello(ii,jj,itask)
6713       implicit real*8 (a-h,o-z)
6714       include "DIMENSIONS"
6715       include "COMMON.IOUNITS"
6716       integer max_cont
6717       integer max_dim
6718       parameter (max_cont=maxconts)
6719       parameter (max_dim=70)
6720       include "COMMON.CONTACTS"
6721       double precision zapas(max_dim,maxconts,max_fg_procs),
6722      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6723       common /przechowalnia/ zapas
6724       integer i,j,ii,jj,iproc,itask(4),nn
6725 c      write (iout,*) "itask",itask
6726       do i=1,2
6727         iproc=itask(i)
6728         if (iproc.gt.0) then
6729           do j=1,num_cont_hb(ii)
6730             jjc=jcont_hb(j,ii)
6731 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6732             if (jjc.eq.jj) then
6733               ncont_sent(iproc)=ncont_sent(iproc)+1
6734               nn=ncont_sent(iproc)
6735               zapas(1,nn,iproc)=ii
6736               zapas(2,nn,iproc)=jjc
6737               zapas(3,nn,iproc)=d_cont(j,ii)
6738               ind=3
6739               do kk=1,3
6740                 ind=ind+1
6741                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6742               enddo
6743               do kk=1,2
6744                 do ll=1,2
6745                   ind=ind+1
6746                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6747                 enddo
6748               enddo
6749               do jj=1,5
6750                 do kk=1,3
6751                   do ll=1,2
6752                     do mm=1,2
6753                       ind=ind+1
6754                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6755                     enddo
6756                   enddo
6757                 enddo
6758               enddo
6759               exit
6760             endif
6761           enddo
6762         endif
6763       enddo
6764       return
6765       end
6766 c------------------------------------------------------------------------------
6767       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6768       implicit real*8 (a-h,o-z)
6769       include 'DIMENSIONS'
6770       include 'COMMON.IOUNITS'
6771       include 'COMMON.DERIV'
6772       include 'COMMON.INTERACT'
6773       include 'COMMON.CONTACTS'
6774       double precision gx(3),gx1(3)
6775       logical lprn
6776       lprn=.false.
6777       eij=facont_hb(jj,i)
6778       ekl=facont_hb(kk,k)
6779       ees0pij=ees0p(jj,i)
6780       ees0pkl=ees0p(kk,k)
6781       ees0mij=ees0m(jj,i)
6782       ees0mkl=ees0m(kk,k)
6783       ekont=eij*ekl
6784       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6785 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6786 C Following 4 lines for diagnostics.
6787 cd    ees0pkl=0.0D0
6788 cd    ees0pij=1.0D0
6789 cd    ees0mkl=0.0D0
6790 cd    ees0mij=1.0D0
6791 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6792 c     & 'Contacts ',i,j,
6793 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6794 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6795 c     & 'gradcorr_long'
6796 C Calculate the multi-body contribution to energy.
6797 c      ecorr=ecorr+ekont*ees
6798 C Calculate multi-body contributions to the gradient.
6799       coeffpees0pij=coeffp*ees0pij
6800       coeffmees0mij=coeffm*ees0mij
6801       coeffpees0pkl=coeffp*ees0pkl
6802       coeffmees0mkl=coeffm*ees0mkl
6803       do ll=1,3
6804 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6805         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6806      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6807      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6808         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6809      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6810      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6811 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6812         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6813      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6814      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6815         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6816      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6817      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6818         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6819      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6820      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6821         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6822         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6823         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6824      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6825      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6826         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6827         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6828 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6829       enddo
6830 c      write (iout,*)
6831 cgrad      do m=i+1,j-1
6832 cgrad        do ll=1,3
6833 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6834 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6835 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6836 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6837 cgrad        enddo
6838 cgrad      enddo
6839 cgrad      do m=k+1,l-1
6840 cgrad        do ll=1,3
6841 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6842 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6843 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6844 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6845 cgrad        enddo
6846 cgrad      enddo
6847 c      write (iout,*) "ehbcorr",ekont*ees
6848       ehbcorr=ekont*ees
6849       return
6850       end
6851 #ifdef MOMENT
6852 C---------------------------------------------------------------------------
6853       subroutine dipole(i,j,jj)
6854       implicit real*8 (a-h,o-z)
6855       include 'DIMENSIONS'
6856       include 'COMMON.IOUNITS'
6857       include 'COMMON.CHAIN'
6858       include 'COMMON.FFIELD'
6859       include 'COMMON.DERIV'
6860       include 'COMMON.INTERACT'
6861       include 'COMMON.CONTACTS'
6862       include 'COMMON.TORSION'
6863       include 'COMMON.VAR'
6864       include 'COMMON.GEO'
6865       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6866      &  auxmat(2,2)
6867       iti1 = itortyp(itype(i+1))
6868       if (j.lt.nres-1) then
6869         itj1 = itortyp(itype(j+1))
6870       else
6871         itj1=ntortyp+1
6872       endif
6873       do iii=1,2
6874         dipi(iii,1)=Ub2(iii,i)
6875         dipderi(iii)=Ub2der(iii,i)
6876         dipi(iii,2)=b1(iii,iti1)
6877         dipj(iii,1)=Ub2(iii,j)
6878         dipderj(iii)=Ub2der(iii,j)
6879         dipj(iii,2)=b1(iii,itj1)
6880       enddo
6881       kkk=0
6882       do iii=1,2
6883         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6884         do jjj=1,2
6885           kkk=kkk+1
6886           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6887         enddo
6888       enddo
6889       do kkk=1,5
6890         do lll=1,3
6891           mmm=0
6892           do iii=1,2
6893             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6894      &        auxvec(1))
6895             do jjj=1,2
6896               mmm=mmm+1
6897               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6898             enddo
6899           enddo
6900         enddo
6901       enddo
6902       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6903       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6904       do iii=1,2
6905         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6906       enddo
6907       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6908       do iii=1,2
6909         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6910       enddo
6911       return
6912       end
6913 #endif
6914 C---------------------------------------------------------------------------
6915       subroutine calc_eello(i,j,k,l,jj,kk)
6916 C
6917 C This subroutine computes matrices and vectors needed to calculate
6918 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6919 C
6920       implicit real*8 (a-h,o-z)
6921       include 'DIMENSIONS'
6922       include 'COMMON.IOUNITS'
6923       include 'COMMON.CHAIN'
6924       include 'COMMON.DERIV'
6925       include 'COMMON.INTERACT'
6926       include 'COMMON.CONTACTS'
6927       include 'COMMON.TORSION'
6928       include 'COMMON.VAR'
6929       include 'COMMON.GEO'
6930       include 'COMMON.FFIELD'
6931       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6932      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6933       logical lprn
6934       common /kutas/ lprn
6935 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6936 cd     & ' jj=',jj,' kk=',kk
6937 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6938 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6939 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6940       do iii=1,2
6941         do jjj=1,2
6942           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6943           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6944         enddo
6945       enddo
6946       call transpose2(aa1(1,1),aa1t(1,1))
6947       call transpose2(aa2(1,1),aa2t(1,1))
6948       do kkk=1,5
6949         do lll=1,3
6950           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6951      &      aa1tder(1,1,lll,kkk))
6952           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6953      &      aa2tder(1,1,lll,kkk))
6954         enddo
6955       enddo
6956       if (l.eq.j+1) then
6957 C parallel orientation of the two CA-CA-CA frames.
6958         if (i.gt.1) then
6959           iti=itortyp(itype(i))
6960         else
6961           iti=ntortyp+1
6962         endif
6963         itk1=itortyp(itype(k+1))
6964         itj=itortyp(itype(j))
6965         if (l.lt.nres-1) then
6966           itl1=itortyp(itype(l+1))
6967         else
6968           itl1=ntortyp+1
6969         endif
6970 C A1 kernel(j+1) A2T
6971 cd        do iii=1,2
6972 cd          write (iout,'(3f10.5,5x,3f10.5)')
6973 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6974 cd        enddo
6975         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6976      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6977      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6978 C Following matrices are needed only for 6-th order cumulants
6979         IF (wcorr6.gt.0.0d0) THEN
6980         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6981      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6982      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6983         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6984      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6985      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6986      &   ADtEAderx(1,1,1,1,1,1))
6987         lprn=.false.
6988         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6989      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6990      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6991      &   ADtEA1derx(1,1,1,1,1,1))
6992         ENDIF
6993 C End 6-th order cumulants
6994 cd        lprn=.false.
6995 cd        if (lprn) then
6996 cd        write (2,*) 'In calc_eello6'
6997 cd        do iii=1,2
6998 cd          write (2,*) 'iii=',iii
6999 cd          do kkk=1,5
7000 cd            write (2,*) 'kkk=',kkk
7001 cd            do jjj=1,2
7002 cd              write (2,'(3(2f10.5),5x)')
7003 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7004 cd            enddo
7005 cd          enddo
7006 cd        enddo
7007 cd        endif
7008         call transpose2(EUgder(1,1,k),auxmat(1,1))
7009         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7010         call transpose2(EUg(1,1,k),auxmat(1,1))
7011         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7012         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7013         do iii=1,2
7014           do kkk=1,5
7015             do lll=1,3
7016               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7017      &          EAEAderx(1,1,lll,kkk,iii,1))
7018             enddo
7019           enddo
7020         enddo
7021 C A1T kernel(i+1) A2
7022         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7023      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7024      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7025 C Following matrices are needed only for 6-th order cumulants
7026         IF (wcorr6.gt.0.0d0) THEN
7027         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7028      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7029      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7030         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7031      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7032      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7033      &   ADtEAderx(1,1,1,1,1,2))
7034         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7035      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7036      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7037      &   ADtEA1derx(1,1,1,1,1,2))
7038         ENDIF
7039 C End 6-th order cumulants
7040         call transpose2(EUgder(1,1,l),auxmat(1,1))
7041         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7042         call transpose2(EUg(1,1,l),auxmat(1,1))
7043         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7044         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7045         do iii=1,2
7046           do kkk=1,5
7047             do lll=1,3
7048               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7049      &          EAEAderx(1,1,lll,kkk,iii,2))
7050             enddo
7051           enddo
7052         enddo
7053 C AEAb1 and AEAb2
7054 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7055 C They are needed only when the fifth- or the sixth-order cumulants are
7056 C indluded.
7057         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7058         call transpose2(AEA(1,1,1),auxmat(1,1))
7059         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7060         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7061         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7062         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7063         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7064         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7065         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7066         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7067         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7068         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7069         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7070         call transpose2(AEA(1,1,2),auxmat(1,1))
7071         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7072         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7073         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7074         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7075         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7076         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7077         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7078         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7079         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7080         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7081         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7082 C Calculate the Cartesian derivatives of the vectors.
7083         do iii=1,2
7084           do kkk=1,5
7085             do lll=1,3
7086               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7087               call matvec2(auxmat(1,1),b1(1,iti),
7088      &          AEAb1derx(1,lll,kkk,iii,1,1))
7089               call matvec2(auxmat(1,1),Ub2(1,i),
7090      &          AEAb2derx(1,lll,kkk,iii,1,1))
7091               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7092      &          AEAb1derx(1,lll,kkk,iii,2,1))
7093               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7094      &          AEAb2derx(1,lll,kkk,iii,2,1))
7095               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7096               call matvec2(auxmat(1,1),b1(1,itj),
7097      &          AEAb1derx(1,lll,kkk,iii,1,2))
7098               call matvec2(auxmat(1,1),Ub2(1,j),
7099      &          AEAb2derx(1,lll,kkk,iii,1,2))
7100               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7101      &          AEAb1derx(1,lll,kkk,iii,2,2))
7102               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7103      &          AEAb2derx(1,lll,kkk,iii,2,2))
7104             enddo
7105           enddo
7106         enddo
7107         ENDIF
7108 C End vectors
7109       else
7110 C Antiparallel orientation of the two CA-CA-CA frames.
7111         if (i.gt.1) then
7112           iti=itortyp(itype(i))
7113         else
7114           iti=ntortyp+1
7115         endif
7116         itk1=itortyp(itype(k+1))
7117         itl=itortyp(itype(l))
7118         itj=itortyp(itype(j))
7119         if (j.lt.nres-1) then
7120           itj1=itortyp(itype(j+1))
7121         else
7122           itj1=ntortyp+1
7123         endif
7124 C A2 kernel(j-1)T A1T
7125         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7126      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7127      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7128 C Following matrices are needed only for 6-th order cumulants
7129         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7130      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7131         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7132      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7133      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7134         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7135      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7136      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7137      &   ADtEAderx(1,1,1,1,1,1))
7138         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7139      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7140      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7141      &   ADtEA1derx(1,1,1,1,1,1))
7142         ENDIF
7143 C End 6-th order cumulants
7144         call transpose2(EUgder(1,1,k),auxmat(1,1))
7145         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7146         call transpose2(EUg(1,1,k),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7148         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7149         do iii=1,2
7150           do kkk=1,5
7151             do lll=1,3
7152               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7153      &          EAEAderx(1,1,lll,kkk,iii,1))
7154             enddo
7155           enddo
7156         enddo
7157 C A2T kernel(i+1)T A1
7158         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7159      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7160      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7161 C Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7163      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7164         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7165      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7166      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7167         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7168      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7169      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7170      &   ADtEAderx(1,1,1,1,1,2))
7171         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7172      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7173      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7174      &   ADtEA1derx(1,1,1,1,1,2))
7175         ENDIF
7176 C End 6-th order cumulants
7177         call transpose2(EUgder(1,1,j),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7179         call transpose2(EUg(1,1,j),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7181         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7182         do iii=1,2
7183           do kkk=1,5
7184             do lll=1,3
7185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7186      &          EAEAderx(1,1,lll,kkk,iii,2))
7187             enddo
7188           enddo
7189         enddo
7190 C AEAb1 and AEAb2
7191 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7192 C They are needed only when the fifth- or the sixth-order cumulants are
7193 C indluded.
7194         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7195      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7196         call transpose2(AEA(1,1,1),auxmat(1,1))
7197         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7198         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7200         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7202         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7203         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7204         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7205         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7206         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7207         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7208         call transpose2(AEA(1,1,2),auxmat(1,1))
7209         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7210         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7212         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7214         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7215         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7216         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7217         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7218         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7219         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7220 C Calculate the Cartesian derivatives of the vectors.
7221         do iii=1,2
7222           do kkk=1,5
7223             do lll=1,3
7224               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7225               call matvec2(auxmat(1,1),b1(1,iti),
7226      &          AEAb1derx(1,lll,kkk,iii,1,1))
7227               call matvec2(auxmat(1,1),Ub2(1,i),
7228      &          AEAb2derx(1,lll,kkk,iii,1,1))
7229               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7230      &          AEAb1derx(1,lll,kkk,iii,2,1))
7231               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7232      &          AEAb2derx(1,lll,kkk,iii,2,1))
7233               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7234               call matvec2(auxmat(1,1),b1(1,itl),
7235      &          AEAb1derx(1,lll,kkk,iii,1,2))
7236               call matvec2(auxmat(1,1),Ub2(1,l),
7237      &          AEAb2derx(1,lll,kkk,iii,1,2))
7238               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7239      &          AEAb1derx(1,lll,kkk,iii,2,2))
7240               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7241      &          AEAb2derx(1,lll,kkk,iii,2,2))
7242             enddo
7243           enddo
7244         enddo
7245         ENDIF
7246 C End vectors
7247       endif
7248       return
7249       end
7250 C---------------------------------------------------------------------------
7251       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7252      &  KK,KKderg,AKA,AKAderg,AKAderx)
7253       implicit none
7254       integer nderg
7255       logical transp
7256       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7257      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7258      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7259       integer iii,kkk,lll
7260       integer jjj,mmm
7261       logical lprn
7262       common /kutas/ lprn
7263       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7264       do iii=1,nderg
7265         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7266      &    AKAderg(1,1,iii))
7267       enddo
7268 cd      if (lprn) write (2,*) 'In kernel'
7269       do kkk=1,5
7270 cd        if (lprn) write (2,*) 'kkk=',kkk
7271         do lll=1,3
7272           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7273      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7274 cd          if (lprn) then
7275 cd            write (2,*) 'lll=',lll
7276 cd            write (2,*) 'iii=1'
7277 cd            do jjj=1,2
7278 cd              write (2,'(3(2f10.5),5x)')
7279 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7280 cd            enddo
7281 cd          endif
7282           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7283      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7284 cd          if (lprn) then
7285 cd            write (2,*) 'lll=',lll
7286 cd            write (2,*) 'iii=2'
7287 cd            do jjj=1,2
7288 cd              write (2,'(3(2f10.5),5x)')
7289 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7290 cd            enddo
7291 cd          endif
7292         enddo
7293       enddo
7294       return
7295       end
7296 C---------------------------------------------------------------------------
7297       double precision function eello4(i,j,k,l,jj,kk)
7298       implicit real*8 (a-h,o-z)
7299       include 'DIMENSIONS'
7300       include 'COMMON.IOUNITS'
7301       include 'COMMON.CHAIN'
7302       include 'COMMON.DERIV'
7303       include 'COMMON.INTERACT'
7304       include 'COMMON.CONTACTS'
7305       include 'COMMON.TORSION'
7306       include 'COMMON.VAR'
7307       include 'COMMON.GEO'
7308       double precision pizda(2,2),ggg1(3),ggg2(3)
7309 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7310 cd        eello4=0.0d0
7311 cd        return
7312 cd      endif
7313 cd      print *,'eello4:',i,j,k,l,jj,kk
7314 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7315 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7316 cold      eij=facont_hb(jj,i)
7317 cold      ekl=facont_hb(kk,k)
7318 cold      ekont=eij*ekl
7319       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7320 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7321       gcorr_loc(k-1)=gcorr_loc(k-1)
7322      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7323       if (l.eq.j+1) then
7324         gcorr_loc(l-1)=gcorr_loc(l-1)
7325      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7326       else
7327         gcorr_loc(j-1)=gcorr_loc(j-1)
7328      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7329       endif
7330       do iii=1,2
7331         do kkk=1,5
7332           do lll=1,3
7333             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7334      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7335 cd            derx(lll,kkk,iii)=0.0d0
7336           enddo
7337         enddo
7338       enddo
7339 cd      gcorr_loc(l-1)=0.0d0
7340 cd      gcorr_loc(j-1)=0.0d0
7341 cd      gcorr_loc(k-1)=0.0d0
7342 cd      eel4=1.0d0
7343 cd      write (iout,*)'Contacts have occurred for peptide groups',
7344 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7345 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7346       if (j.lt.nres-1) then
7347         j1=j+1
7348         j2=j-1
7349       else
7350         j1=j-1
7351         j2=j-2
7352       endif
7353       if (l.lt.nres-1) then
7354         l1=l+1
7355         l2=l-1
7356       else
7357         l1=l-1
7358         l2=l-2
7359       endif
7360       do ll=1,3
7361 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7362 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7363         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7364         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7365 cgrad        ghalf=0.5d0*ggg1(ll)
7366         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7367         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7368         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7369         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7370         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7371         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7372 cgrad        ghalf=0.5d0*ggg2(ll)
7373         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7374         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7375         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7376         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7377         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7378         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7379       enddo
7380 cgrad      do m=i+1,j-1
7381 cgrad        do ll=1,3
7382 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7383 cgrad        enddo
7384 cgrad      enddo
7385 cgrad      do m=k+1,l-1
7386 cgrad        do ll=1,3
7387 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7388 cgrad        enddo
7389 cgrad      enddo
7390 cgrad      do m=i+2,j2
7391 cgrad        do ll=1,3
7392 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7393 cgrad        enddo
7394 cgrad      enddo
7395 cgrad      do m=k+2,l2
7396 cgrad        do ll=1,3
7397 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7398 cgrad        enddo
7399 cgrad      enddo
7400 cd      do iii=1,nres-3
7401 cd        write (2,*) iii,gcorr_loc(iii)
7402 cd      enddo
7403       eello4=ekont*eel4
7404 cd      write (2,*) 'ekont',ekont
7405 cd      write (iout,*) 'eello4',ekont*eel4
7406       return
7407       end
7408 C---------------------------------------------------------------------------
7409       double precision function eello5(i,j,k,l,jj,kk)
7410       implicit real*8 (a-h,o-z)
7411       include 'DIMENSIONS'
7412       include 'COMMON.IOUNITS'
7413       include 'COMMON.CHAIN'
7414       include 'COMMON.DERIV'
7415       include 'COMMON.INTERACT'
7416       include 'COMMON.CONTACTS'
7417       include 'COMMON.TORSION'
7418       include 'COMMON.VAR'
7419       include 'COMMON.GEO'
7420       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7421       double precision ggg1(3),ggg2(3)
7422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7423 C                                                                              C
7424 C                            Parallel chains                                   C
7425 C                                                                              C
7426 C          o             o                   o             o                   C
7427 C         /l\           / \             \   / \           / \   /              C
7428 C        /   \         /   \             \ /   \         /   \ /               C
7429 C       j| o |l1       | o |              o| o |         | o |o                C
7430 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7431 C      \i/   \         /   \ /             /   \         /   \                 C
7432 C       o    k1             o                                                  C
7433 C         (I)          (II)                (III)          (IV)                 C
7434 C                                                                              C
7435 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7436 C                                                                              C
7437 C                            Antiparallel chains                               C
7438 C                                                                              C
7439 C          o             o                   o             o                   C
7440 C         /j\           / \             \   / \           / \   /              C
7441 C        /   \         /   \             \ /   \         /   \ /               C
7442 C      j1| o |l        | o |              o| o |         | o |o                C
7443 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7444 C      \i/   \         /   \ /             /   \         /   \                 C
7445 C       o     k1            o                                                  C
7446 C         (I)          (II)                (III)          (IV)                 C
7447 C                                                                              C
7448 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7449 C                                                                              C
7450 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7451 C                                                                              C
7452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7453 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7454 cd        eello5=0.0d0
7455 cd        return
7456 cd      endif
7457 cd      write (iout,*)
7458 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7459 cd     &   ' and',k,l
7460       itk=itortyp(itype(k))
7461       itl=itortyp(itype(l))
7462       itj=itortyp(itype(j))
7463       eello5_1=0.0d0
7464       eello5_2=0.0d0
7465       eello5_3=0.0d0
7466       eello5_4=0.0d0
7467 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7468 cd     &   eel5_3_num,eel5_4_num)
7469       do iii=1,2
7470         do kkk=1,5
7471           do lll=1,3
7472             derx(lll,kkk,iii)=0.0d0
7473           enddo
7474         enddo
7475       enddo
7476 cd      eij=facont_hb(jj,i)
7477 cd      ekl=facont_hb(kk,k)
7478 cd      ekont=eij*ekl
7479 cd      write (iout,*)'Contacts have occurred for peptide groups',
7480 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7481 cd      goto 1111
7482 C Contribution from the graph I.
7483 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7484 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7485       call transpose2(EUg(1,1,k),auxmat(1,1))
7486       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7487       vv(1)=pizda(1,1)-pizda(2,2)
7488       vv(2)=pizda(1,2)+pizda(2,1)
7489       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7490      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7491 C Explicit gradient in virtual-dihedral angles.
7492       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7493      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7494      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7495       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7496       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7497       vv(1)=pizda(1,1)-pizda(2,2)
7498       vv(2)=pizda(1,2)+pizda(2,1)
7499       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7500      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7501      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7502       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7503       vv(1)=pizda(1,1)-pizda(2,2)
7504       vv(2)=pizda(1,2)+pizda(2,1)
7505       if (l.eq.j+1) then
7506         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7507      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7509       else
7510         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7511      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7512      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7513       endif
7514 C Cartesian gradient
7515       do iii=1,2
7516         do kkk=1,5
7517           do lll=1,3
7518             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7519      &        pizda(1,1))
7520             vv(1)=pizda(1,1)-pizda(2,2)
7521             vv(2)=pizda(1,2)+pizda(2,1)
7522             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7523      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7524      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7525           enddo
7526         enddo
7527       enddo
7528 c      goto 1112
7529 c1111  continue
7530 C Contribution from graph II
7531       call transpose2(EE(1,1,itk),auxmat(1,1))
7532       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7533       vv(1)=pizda(1,1)+pizda(2,2)
7534       vv(2)=pizda(2,1)-pizda(1,2)
7535       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7536      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7537 C Explicit gradient in virtual-dihedral angles.
7538       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7539      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7540       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7541       vv(1)=pizda(1,1)+pizda(2,2)
7542       vv(2)=pizda(2,1)-pizda(1,2)
7543       if (l.eq.j+1) then
7544         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7545      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7546      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7547       else
7548         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7549      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7550      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7551       endif
7552 C Cartesian gradient
7553       do iii=1,2
7554         do kkk=1,5
7555           do lll=1,3
7556             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7557      &        pizda(1,1))
7558             vv(1)=pizda(1,1)+pizda(2,2)
7559             vv(2)=pizda(2,1)-pizda(1,2)
7560             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7561      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7562      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7563           enddo
7564         enddo
7565       enddo
7566 cd      goto 1112
7567 cd1111  continue
7568       if (l.eq.j+1) then
7569 cd        goto 1110
7570 C Parallel orientation
7571 C Contribution from graph III
7572         call transpose2(EUg(1,1,l),auxmat(1,1))
7573         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7574         vv(1)=pizda(1,1)-pizda(2,2)
7575         vv(2)=pizda(1,2)+pizda(2,1)
7576         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7577      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7578 C Explicit gradient in virtual-dihedral angles.
7579         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7580      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7581      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7582         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7583         vv(1)=pizda(1,1)-pizda(2,2)
7584         vv(2)=pizda(1,2)+pizda(2,1)
7585         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7586      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7587      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7588         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7589         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7590         vv(1)=pizda(1,1)-pizda(2,2)
7591         vv(2)=pizda(1,2)+pizda(2,1)
7592         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7593      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7595 C Cartesian gradient
7596         do iii=1,2
7597           do kkk=1,5
7598             do lll=1,3
7599               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7600      &          pizda(1,1))
7601               vv(1)=pizda(1,1)-pizda(2,2)
7602               vv(2)=pizda(1,2)+pizda(2,1)
7603               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7604      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7605      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7606             enddo
7607           enddo
7608         enddo
7609 cd        goto 1112
7610 C Contribution from graph IV
7611 cd1110    continue
7612         call transpose2(EE(1,1,itl),auxmat(1,1))
7613         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7614         vv(1)=pizda(1,1)+pizda(2,2)
7615         vv(2)=pizda(2,1)-pizda(1,2)
7616         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7617      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7618 C Explicit gradient in virtual-dihedral angles.
7619         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7620      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7621         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7622         vv(1)=pizda(1,1)+pizda(2,2)
7623         vv(2)=pizda(2,1)-pizda(1,2)
7624         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7625      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7626      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7627 C Cartesian gradient
7628         do iii=1,2
7629           do kkk=1,5
7630             do lll=1,3
7631               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7632      &          pizda(1,1))
7633               vv(1)=pizda(1,1)+pizda(2,2)
7634               vv(2)=pizda(2,1)-pizda(1,2)
7635               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7636      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7637      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7638             enddo
7639           enddo
7640         enddo
7641       else
7642 C Antiparallel orientation
7643 C Contribution from graph III
7644 c        goto 1110
7645         call transpose2(EUg(1,1,j),auxmat(1,1))
7646         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7647         vv(1)=pizda(1,1)-pizda(2,2)
7648         vv(2)=pizda(1,2)+pizda(2,1)
7649         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7651 C Explicit gradient in virtual-dihedral angles.
7652         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7653      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7654      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7655         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7656         vv(1)=pizda(1,1)-pizda(2,2)
7657         vv(2)=pizda(1,2)+pizda(2,1)
7658         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7659      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7661         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7662         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7663         vv(1)=pizda(1,1)-pizda(2,2)
7664         vv(2)=pizda(1,2)+pizda(2,1)
7665         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7666      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7667      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7668 C Cartesian gradient
7669         do iii=1,2
7670           do kkk=1,5
7671             do lll=1,3
7672               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7673      &          pizda(1,1))
7674               vv(1)=pizda(1,1)-pizda(2,2)
7675               vv(2)=pizda(1,2)+pizda(2,1)
7676               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7677      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7678      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7679             enddo
7680           enddo
7681         enddo
7682 cd        goto 1112
7683 C Contribution from graph IV
7684 1110    continue
7685         call transpose2(EE(1,1,itj),auxmat(1,1))
7686         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7687         vv(1)=pizda(1,1)+pizda(2,2)
7688         vv(2)=pizda(2,1)-pizda(1,2)
7689         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7690      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7691 C Explicit gradient in virtual-dihedral angles.
7692         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7693      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7694         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7695         vv(1)=pizda(1,1)+pizda(2,2)
7696         vv(2)=pizda(2,1)-pizda(1,2)
7697         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7698      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7699      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7700 C Cartesian gradient
7701         do iii=1,2
7702           do kkk=1,5
7703             do lll=1,3
7704               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7705      &          pizda(1,1))
7706               vv(1)=pizda(1,1)+pizda(2,2)
7707               vv(2)=pizda(2,1)-pizda(1,2)
7708               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7709      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7710      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7711             enddo
7712           enddo
7713         enddo
7714       endif
7715 1112  continue
7716       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7717 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7718 cd        write (2,*) 'ijkl',i,j,k,l
7719 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7720 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7721 cd      endif
7722 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7723 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7724 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7725 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7726       if (j.lt.nres-1) then
7727         j1=j+1
7728         j2=j-1
7729       else
7730         j1=j-1
7731         j2=j-2
7732       endif
7733       if (l.lt.nres-1) then
7734         l1=l+1
7735         l2=l-1
7736       else
7737         l1=l-1
7738         l2=l-2
7739       endif
7740 cd      eij=1.0d0
7741 cd      ekl=1.0d0
7742 cd      ekont=1.0d0
7743 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7744 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7745 C        summed up outside the subrouine as for the other subroutines
7746 C        handling long-range interactions. The old code is commented out
7747 C        with "cgrad" to keep track of changes.
7748       do ll=1,3
7749 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7750 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7751         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7752         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7753 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7754 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7755 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7756 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7757 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7758 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7759 c     &   gradcorr5ij,
7760 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7761 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7762 cgrad        ghalf=0.5d0*ggg1(ll)
7763 cd        ghalf=0.0d0
7764         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7765         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7766         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7767         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7768         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7769         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7770 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7771 cgrad        ghalf=0.5d0*ggg2(ll)
7772 cd        ghalf=0.0d0
7773         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7774         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7775         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7776         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7777         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7778         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7779       enddo
7780 cd      goto 1112
7781 cgrad      do m=i+1,j-1
7782 cgrad        do ll=1,3
7783 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7784 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7785 cgrad        enddo
7786 cgrad      enddo
7787 cgrad      do m=k+1,l-1
7788 cgrad        do ll=1,3
7789 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7790 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7791 cgrad        enddo
7792 cgrad      enddo
7793 c1112  continue
7794 cgrad      do m=i+2,j2
7795 cgrad        do ll=1,3
7796 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7797 cgrad        enddo
7798 cgrad      enddo
7799 cgrad      do m=k+2,l2
7800 cgrad        do ll=1,3
7801 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7802 cgrad        enddo
7803 cgrad      enddo
7804 cd      do iii=1,nres-3
7805 cd        write (2,*) iii,g_corr5_loc(iii)
7806 cd      enddo
7807       eello5=ekont*eel5
7808 cd      write (2,*) 'ekont',ekont
7809 cd      write (iout,*) 'eello5',ekont*eel5
7810       return
7811       end
7812 c--------------------------------------------------------------------------
7813       double precision function eello6(i,j,k,l,jj,kk)
7814       implicit real*8 (a-h,o-z)
7815       include 'DIMENSIONS'
7816       include 'COMMON.IOUNITS'
7817       include 'COMMON.CHAIN'
7818       include 'COMMON.DERIV'
7819       include 'COMMON.INTERACT'
7820       include 'COMMON.CONTACTS'
7821       include 'COMMON.TORSION'
7822       include 'COMMON.VAR'
7823       include 'COMMON.GEO'
7824       include 'COMMON.FFIELD'
7825       double precision ggg1(3),ggg2(3)
7826 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7827 cd        eello6=0.0d0
7828 cd        return
7829 cd      endif
7830 cd      write (iout,*)
7831 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7832 cd     &   ' and',k,l
7833       eello6_1=0.0d0
7834       eello6_2=0.0d0
7835       eello6_3=0.0d0
7836       eello6_4=0.0d0
7837       eello6_5=0.0d0
7838       eello6_6=0.0d0
7839 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7840 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7841       do iii=1,2
7842         do kkk=1,5
7843           do lll=1,3
7844             derx(lll,kkk,iii)=0.0d0
7845           enddo
7846         enddo
7847       enddo
7848 cd      eij=facont_hb(jj,i)
7849 cd      ekl=facont_hb(kk,k)
7850 cd      ekont=eij*ekl
7851 cd      eij=1.0d0
7852 cd      ekl=1.0d0
7853 cd      ekont=1.0d0
7854       if (l.eq.j+1) then
7855         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7856         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7857         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7858         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7859         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7860         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7861       else
7862         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7863         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7864         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7865         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7866         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7867           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7868         else
7869           eello6_5=0.0d0
7870         endif
7871         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7872       endif
7873 C If turn contributions are considered, they will be handled separately.
7874       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7875 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7876 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7877 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7878 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7879 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7880 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7881 cd      goto 1112
7882       if (j.lt.nres-1) then
7883         j1=j+1
7884         j2=j-1
7885       else
7886         j1=j-1
7887         j2=j-2
7888       endif
7889       if (l.lt.nres-1) then
7890         l1=l+1
7891         l2=l-1
7892       else
7893         l1=l-1
7894         l2=l-2
7895       endif
7896       do ll=1,3
7897 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7898 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7899 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7900 cgrad        ghalf=0.5d0*ggg1(ll)
7901 cd        ghalf=0.0d0
7902         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7903         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7904         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7905         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7906         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7907         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7908         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7909         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7910 cgrad        ghalf=0.5d0*ggg2(ll)
7911 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7912 cd        ghalf=0.0d0
7913         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7914         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7915         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7916         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7917         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7918         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7919       enddo
7920 cd      goto 1112
7921 cgrad      do m=i+1,j-1
7922 cgrad        do ll=1,3
7923 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7924 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7925 cgrad        enddo
7926 cgrad      enddo
7927 cgrad      do m=k+1,l-1
7928 cgrad        do ll=1,3
7929 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7930 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7931 cgrad        enddo
7932 cgrad      enddo
7933 cgrad1112  continue
7934 cgrad      do m=i+2,j2
7935 cgrad        do ll=1,3
7936 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7937 cgrad        enddo
7938 cgrad      enddo
7939 cgrad      do m=k+2,l2
7940 cgrad        do ll=1,3
7941 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7942 cgrad        enddo
7943 cgrad      enddo
7944 cd      do iii=1,nres-3
7945 cd        write (2,*) iii,g_corr6_loc(iii)
7946 cd      enddo
7947       eello6=ekont*eel6
7948 cd      write (2,*) 'ekont',ekont
7949 cd      write (iout,*) 'eello6',ekont*eel6
7950       return
7951       end
7952 c--------------------------------------------------------------------------
7953       double precision function eello6_graph1(i,j,k,l,imat,swap)
7954       implicit real*8 (a-h,o-z)
7955       include 'DIMENSIONS'
7956       include 'COMMON.IOUNITS'
7957       include 'COMMON.CHAIN'
7958       include 'COMMON.DERIV'
7959       include 'COMMON.INTERACT'
7960       include 'COMMON.CONTACTS'
7961       include 'COMMON.TORSION'
7962       include 'COMMON.VAR'
7963       include 'COMMON.GEO'
7964       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7965       logical swap
7966       logical lprn
7967       common /kutas/ lprn
7968 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7969 C
7970 C      Parallel       Antiparallel
7971 C
7972 C          o             o
7973 C         /l\           /j\
7974 C        /   \         /   \
7975 C       /| o |         | o |\
7976 C     \ j|/k\|  /   \  |/k\|l /
7977 C      \ /   \ /     \ /   \ /
7978 C       o     o       o     o
7979 C       i             i
7980 C
7981 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7982       itk=itortyp(itype(k))
7983       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7984       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7985       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7986       call transpose2(EUgC(1,1,k),auxmat(1,1))
7987       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7988       vv1(1)=pizda1(1,1)-pizda1(2,2)
7989       vv1(2)=pizda1(1,2)+pizda1(2,1)
7990       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7991       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7992       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7993       s5=scalar2(vv(1),Dtobr2(1,i))
7994 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7995       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7996       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7997      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7998      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7999      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8000      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8001      & +scalar2(vv(1),Dtobr2der(1,i)))
8002       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8003       vv1(1)=pizda1(1,1)-pizda1(2,2)
8004       vv1(2)=pizda1(1,2)+pizda1(2,1)
8005       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8006       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8007       if (l.eq.j+1) then
8008         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8009      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8010      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8011      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8012      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8013       else
8014         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8015      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8016      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8017      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8018      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8019       endif
8020       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8021       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8022       vv1(1)=pizda1(1,1)-pizda1(2,2)
8023       vv1(2)=pizda1(1,2)+pizda1(2,1)
8024       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8025      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8026      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8027      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8028       do iii=1,2
8029         if (swap) then
8030           ind=3-iii
8031         else
8032           ind=iii
8033         endif
8034         do kkk=1,5
8035           do lll=1,3
8036             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8037             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8038             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8039             call transpose2(EUgC(1,1,k),auxmat(1,1))
8040             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8041      &        pizda1(1,1))
8042             vv1(1)=pizda1(1,1)-pizda1(2,2)
8043             vv1(2)=pizda1(1,2)+pizda1(2,1)
8044             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8045             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8046      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8047             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8048      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8049             s5=scalar2(vv(1),Dtobr2(1,i))
8050             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8051           enddo
8052         enddo
8053       enddo
8054       return
8055       end
8056 c----------------------------------------------------------------------------
8057       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8058       implicit real*8 (a-h,o-z)
8059       include 'DIMENSIONS'
8060       include 'COMMON.IOUNITS'
8061       include 'COMMON.CHAIN'
8062       include 'COMMON.DERIV'
8063       include 'COMMON.INTERACT'
8064       include 'COMMON.CONTACTS'
8065       include 'COMMON.TORSION'
8066       include 'COMMON.VAR'
8067       include 'COMMON.GEO'
8068       logical swap
8069       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8070      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8071       logical lprn
8072       common /kutas/ lprn
8073 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8074 C
8075 C      Parallel       Antiparallel
8076 C
8077 C          o             o
8078 C     \   /l\           /j\   /
8079 C      \ /   \         /   \ /
8080 C       o| o |         | o |o
8081 C     \ j|/k\|      \  |/k\|l
8082 C      \ /   \       \ /   \
8083 C       o             o
8084 C       i             i
8085 C
8086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8087 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8088 C AL 7/4/01 s1 would occur in the sixth-order moment,
8089 C           but not in a cluster cumulant
8090 #ifdef MOMENT
8091       s1=dip(1,jj,i)*dip(1,kk,k)
8092 #endif
8093       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8094       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8095       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8096       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8097       call transpose2(EUg(1,1,k),auxmat(1,1))
8098       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8099       vv(1)=pizda(1,1)-pizda(2,2)
8100       vv(2)=pizda(1,2)+pizda(2,1)
8101       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8102 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8103 #ifdef MOMENT
8104       eello6_graph2=-(s1+s2+s3+s4)
8105 #else
8106       eello6_graph2=-(s2+s3+s4)
8107 #endif
8108 c      eello6_graph2=-s3
8109 C Derivatives in gamma(i-1)
8110       if (i.gt.1) then
8111 #ifdef MOMENT
8112         s1=dipderg(1,jj,i)*dip(1,kk,k)
8113 #endif
8114         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8115         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8116         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8117         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8118 #ifdef MOMENT
8119         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8120 #else
8121         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8122 #endif
8123 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8124       endif
8125 C Derivatives in gamma(k-1)
8126 #ifdef MOMENT
8127       s1=dip(1,jj,i)*dipderg(1,kk,k)
8128 #endif
8129       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8130       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8131       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8132       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8133       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8134       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8135       vv(1)=pizda(1,1)-pizda(2,2)
8136       vv(2)=pizda(1,2)+pizda(2,1)
8137       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8138 #ifdef MOMENT
8139       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8140 #else
8141       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8142 #endif
8143 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8144 C Derivatives in gamma(j-1) or gamma(l-1)
8145       if (j.gt.1) then
8146 #ifdef MOMENT
8147         s1=dipderg(3,jj,i)*dip(1,kk,k)
8148 #endif
8149         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8150         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8151         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8152         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8153         vv(1)=pizda(1,1)-pizda(2,2)
8154         vv(2)=pizda(1,2)+pizda(2,1)
8155         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8156 #ifdef MOMENT
8157         if (swap) then
8158           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8159         else
8160           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8161         endif
8162 #endif
8163         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8164 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8165       endif
8166 C Derivatives in gamma(l-1) or gamma(j-1)
8167       if (l.gt.1) then
8168 #ifdef MOMENT
8169         s1=dip(1,jj,i)*dipderg(3,kk,k)
8170 #endif
8171         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8172         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8173         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8174         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8175         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8176         vv(1)=pizda(1,1)-pizda(2,2)
8177         vv(2)=pizda(1,2)+pizda(2,1)
8178         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8179 #ifdef MOMENT
8180         if (swap) then
8181           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8182         else
8183           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8184         endif
8185 #endif
8186         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8187 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8188       endif
8189 C Cartesian derivatives.
8190       if (lprn) then
8191         write (2,*) 'In eello6_graph2'
8192         do iii=1,2
8193           write (2,*) 'iii=',iii
8194           do kkk=1,5
8195             write (2,*) 'kkk=',kkk
8196             do jjj=1,2
8197               write (2,'(3(2f10.5),5x)')
8198      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8199             enddo
8200           enddo
8201         enddo
8202       endif
8203       do iii=1,2
8204         do kkk=1,5
8205           do lll=1,3
8206 #ifdef MOMENT
8207             if (iii.eq.1) then
8208               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8209             else
8210               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8211             endif
8212 #endif
8213             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8214      &        auxvec(1))
8215             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8216             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8217      &        auxvec(1))
8218             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8219             call transpose2(EUg(1,1,k),auxmat(1,1))
8220             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8221      &        pizda(1,1))
8222             vv(1)=pizda(1,1)-pizda(2,2)
8223             vv(2)=pizda(1,2)+pizda(2,1)
8224             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8225 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8226 #ifdef MOMENT
8227             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8228 #else
8229             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8230 #endif
8231             if (swap) then
8232               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8233             else
8234               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8235             endif
8236           enddo
8237         enddo
8238       enddo
8239       return
8240       end
8241 c----------------------------------------------------------------------------
8242       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8243       implicit real*8 (a-h,o-z)
8244       include 'DIMENSIONS'
8245       include 'COMMON.IOUNITS'
8246       include 'COMMON.CHAIN'
8247       include 'COMMON.DERIV'
8248       include 'COMMON.INTERACT'
8249       include 'COMMON.CONTACTS'
8250       include 'COMMON.TORSION'
8251       include 'COMMON.VAR'
8252       include 'COMMON.GEO'
8253       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8254       logical swap
8255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8256 C
8257 C      Parallel       Antiparallel
8258 C
8259 C          o             o
8260 C         /l\   /   \   /j\
8261 C        /   \ /     \ /   \
8262 C       /| o |o       o| o |\
8263 C       j|/k\|  /      |/k\|l /
8264 C        /   \ /       /   \ /
8265 C       /     o       /     o
8266 C       i             i
8267 C
8268 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8269 C
8270 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8271 C           energy moment and not to the cluster cumulant.
8272       iti=itortyp(itype(i))
8273       if (j.lt.nres-1) then
8274         itj1=itortyp(itype(j+1))
8275       else
8276         itj1=ntortyp+1
8277       endif
8278       itk=itortyp(itype(k))
8279       itk1=itortyp(itype(k+1))
8280       if (l.lt.nres-1) then
8281         itl1=itortyp(itype(l+1))
8282       else
8283         itl1=ntortyp+1
8284       endif
8285 #ifdef MOMENT
8286       s1=dip(4,jj,i)*dip(4,kk,k)
8287 #endif
8288       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8289       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8290       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8291       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8292       call transpose2(EE(1,1,itk),auxmat(1,1))
8293       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8294       vv(1)=pizda(1,1)+pizda(2,2)
8295       vv(2)=pizda(2,1)-pizda(1,2)
8296       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8297 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8298 cd     & "sum",-(s2+s3+s4)
8299 #ifdef MOMENT
8300       eello6_graph3=-(s1+s2+s3+s4)
8301 #else
8302       eello6_graph3=-(s2+s3+s4)
8303 #endif
8304 c      eello6_graph3=-s4
8305 C Derivatives in gamma(k-1)
8306       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8307       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8308       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8309       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8310 C Derivatives in gamma(l-1)
8311       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8312       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8313       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8314       vv(1)=pizda(1,1)+pizda(2,2)
8315       vv(2)=pizda(2,1)-pizda(1,2)
8316       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8317       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8318 C Cartesian derivatives.
8319       do iii=1,2
8320         do kkk=1,5
8321           do lll=1,3
8322 #ifdef MOMENT
8323             if (iii.eq.1) then
8324               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8325             else
8326               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8327             endif
8328 #endif
8329             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8330      &        auxvec(1))
8331             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8332             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8333      &        auxvec(1))
8334             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8335             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8336      &        pizda(1,1))
8337             vv(1)=pizda(1,1)+pizda(2,2)
8338             vv(2)=pizda(2,1)-pizda(1,2)
8339             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8340 #ifdef MOMENT
8341             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8342 #else
8343             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8344 #endif
8345             if (swap) then
8346               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8347             else
8348               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8349             endif
8350 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8351           enddo
8352         enddo
8353       enddo
8354       return
8355       end
8356 c----------------------------------------------------------------------------
8357       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8358       implicit real*8 (a-h,o-z)
8359       include 'DIMENSIONS'
8360       include 'COMMON.IOUNITS'
8361       include 'COMMON.CHAIN'
8362       include 'COMMON.DERIV'
8363       include 'COMMON.INTERACT'
8364       include 'COMMON.CONTACTS'
8365       include 'COMMON.TORSION'
8366       include 'COMMON.VAR'
8367       include 'COMMON.GEO'
8368       include 'COMMON.FFIELD'
8369       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8370      & auxvec1(2),auxmat1(2,2)
8371       logical swap
8372 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8373 C
8374 C      Parallel       Antiparallel
8375 C
8376 C          o             o
8377 C         /l\   /   \   /j\
8378 C        /   \ /     \ /   \
8379 C       /| o |o       o| o |\
8380 C     \ j|/k\|      \  |/k\|l
8381 C      \ /   \       \ /   \
8382 C       o     \       o     \
8383 C       i             i
8384 C
8385 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8386 C
8387 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8388 C           energy moment and not to the cluster cumulant.
8389 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8390       iti=itortyp(itype(i))
8391       itj=itortyp(itype(j))
8392       if (j.lt.nres-1) then
8393         itj1=itortyp(itype(j+1))
8394       else
8395         itj1=ntortyp+1
8396       endif
8397       itk=itortyp(itype(k))
8398       if (k.lt.nres-1) then
8399         itk1=itortyp(itype(k+1))
8400       else
8401         itk1=ntortyp+1
8402       endif
8403       itl=itortyp(itype(l))
8404       if (l.lt.nres-1) then
8405         itl1=itortyp(itype(l+1))
8406       else
8407         itl1=ntortyp+1
8408       endif
8409 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8410 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8411 cd     & ' itl',itl,' itl1',itl1
8412 #ifdef MOMENT
8413       if (imat.eq.1) then
8414         s1=dip(3,jj,i)*dip(3,kk,k)
8415       else
8416         s1=dip(2,jj,j)*dip(2,kk,l)
8417       endif
8418 #endif
8419       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8420       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8421       if (j.eq.l+1) then
8422         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8423         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8424       else
8425         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8426         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8427       endif
8428       call transpose2(EUg(1,1,k),auxmat(1,1))
8429       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8430       vv(1)=pizda(1,1)-pizda(2,2)
8431       vv(2)=pizda(2,1)+pizda(1,2)
8432       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8433 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8434 #ifdef MOMENT
8435       eello6_graph4=-(s1+s2+s3+s4)
8436 #else
8437       eello6_graph4=-(s2+s3+s4)
8438 #endif
8439 C Derivatives in gamma(i-1)
8440       if (i.gt.1) then
8441 #ifdef MOMENT
8442         if (imat.eq.1) then
8443           s1=dipderg(2,jj,i)*dip(3,kk,k)
8444         else
8445           s1=dipderg(4,jj,j)*dip(2,kk,l)
8446         endif
8447 #endif
8448         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8449         if (j.eq.l+1) then
8450           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8451           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8452         else
8453           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8454           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8455         endif
8456         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8457         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8458 cd          write (2,*) 'turn6 derivatives'
8459 #ifdef MOMENT
8460           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8461 #else
8462           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8463 #endif
8464         else
8465 #ifdef MOMENT
8466           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8467 #else
8468           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8469 #endif
8470         endif
8471       endif
8472 C Derivatives in gamma(k-1)
8473 #ifdef MOMENT
8474       if (imat.eq.1) then
8475         s1=dip(3,jj,i)*dipderg(2,kk,k)
8476       else
8477         s1=dip(2,jj,j)*dipderg(4,kk,l)
8478       endif
8479 #endif
8480       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8481       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8482       if (j.eq.l+1) then
8483         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8484         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8485       else
8486         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8487         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8488       endif
8489       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8490       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8491       vv(1)=pizda(1,1)-pizda(2,2)
8492       vv(2)=pizda(2,1)+pizda(1,2)
8493       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8494       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8495 #ifdef MOMENT
8496         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8497 #else
8498         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8499 #endif
8500       else
8501 #ifdef MOMENT
8502         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8503 #else
8504         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8505 #endif
8506       endif
8507 C Derivatives in gamma(j-1) or gamma(l-1)
8508       if (l.eq.j+1 .and. l.gt.1) then
8509         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8510         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8511         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8512         vv(1)=pizda(1,1)-pizda(2,2)
8513         vv(2)=pizda(2,1)+pizda(1,2)
8514         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8515         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8516       else if (j.gt.1) then
8517         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8518         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8519         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8520         vv(1)=pizda(1,1)-pizda(2,2)
8521         vv(2)=pizda(2,1)+pizda(1,2)
8522         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8523         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8524           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8525         else
8526           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8527         endif
8528       endif
8529 C Cartesian derivatives.
8530       do iii=1,2
8531         do kkk=1,5
8532           do lll=1,3
8533 #ifdef MOMENT
8534             if (iii.eq.1) then
8535               if (imat.eq.1) then
8536                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8537               else
8538                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8539               endif
8540             else
8541               if (imat.eq.1) then
8542                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8543               else
8544                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8545               endif
8546             endif
8547 #endif
8548             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8549      &        auxvec(1))
8550             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8551             if (j.eq.l+1) then
8552               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8553      &          b1(1,itj1),auxvec(1))
8554               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8555             else
8556               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8557      &          b1(1,itl1),auxvec(1))
8558               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8559             endif
8560             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8561      &        pizda(1,1))
8562             vv(1)=pizda(1,1)-pizda(2,2)
8563             vv(2)=pizda(2,1)+pizda(1,2)
8564             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8565             if (swap) then
8566               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8567 #ifdef MOMENT
8568                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8569      &             -(s1+s2+s4)
8570 #else
8571                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8572      &             -(s2+s4)
8573 #endif
8574                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8575               else
8576 #ifdef MOMENT
8577                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8578 #else
8579                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8580 #endif
8581                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8582               endif
8583             else
8584 #ifdef MOMENT
8585               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8586 #else
8587               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8588 #endif
8589               if (l.eq.j+1) then
8590                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8591               else
8592                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8593               endif
8594             endif
8595           enddo
8596         enddo
8597       enddo
8598       return
8599       end
8600 c----------------------------------------------------------------------------
8601       double precision function eello_turn6(i,jj,kk)
8602       implicit real*8 (a-h,o-z)
8603       include 'DIMENSIONS'
8604       include 'COMMON.IOUNITS'
8605       include 'COMMON.CHAIN'
8606       include 'COMMON.DERIV'
8607       include 'COMMON.INTERACT'
8608       include 'COMMON.CONTACTS'
8609       include 'COMMON.TORSION'
8610       include 'COMMON.VAR'
8611       include 'COMMON.GEO'
8612       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8613      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8614      &  ggg1(3),ggg2(3)
8615       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8616      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8617 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8618 C           the respective energy moment and not to the cluster cumulant.
8619       s1=0.0d0
8620       s8=0.0d0
8621       s13=0.0d0
8622 c
8623       eello_turn6=0.0d0
8624       j=i+4
8625       k=i+1
8626       l=i+3
8627       iti=itortyp(itype(i))
8628       itk=itortyp(itype(k))
8629       itk1=itortyp(itype(k+1))
8630       itl=itortyp(itype(l))
8631       itj=itortyp(itype(j))
8632 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8633 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8634 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8635 cd        eello6=0.0d0
8636 cd        return
8637 cd      endif
8638 cd      write (iout,*)
8639 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8640 cd     &   ' and',k,l
8641 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8642       do iii=1,2
8643         do kkk=1,5
8644           do lll=1,3
8645             derx_turn(lll,kkk,iii)=0.0d0
8646           enddo
8647         enddo
8648       enddo
8649 cd      eij=1.0d0
8650 cd      ekl=1.0d0
8651 cd      ekont=1.0d0
8652       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8653 cd      eello6_5=0.0d0
8654 cd      write (2,*) 'eello6_5',eello6_5
8655 #ifdef MOMENT
8656       call transpose2(AEA(1,1,1),auxmat(1,1))
8657       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8658       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8659       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8660 #endif
8661       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8662       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8663       s2 = scalar2(b1(1,itk),vtemp1(1))
8664 #ifdef MOMENT
8665       call transpose2(AEA(1,1,2),atemp(1,1))
8666       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8667       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8668       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8669 #endif
8670       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8671       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8672       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8673 #ifdef MOMENT
8674       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8675       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8676       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8677       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8678       ss13 = scalar2(b1(1,itk),vtemp4(1))
8679       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8680 #endif
8681 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8682 c      s1=0.0d0
8683 c      s2=0.0d0
8684 c      s8=0.0d0
8685 c      s12=0.0d0
8686 c      s13=0.0d0
8687       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8688 C Derivatives in gamma(i+2)
8689       s1d =0.0d0
8690       s8d =0.0d0
8691 #ifdef MOMENT
8692       call transpose2(AEA(1,1,1),auxmatd(1,1))
8693       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8694       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8695       call transpose2(AEAderg(1,1,2),atempd(1,1))
8696       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8697       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8698 #endif
8699       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8700       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8701       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8702 c      s1d=0.0d0
8703 c      s2d=0.0d0
8704 c      s8d=0.0d0
8705 c      s12d=0.0d0
8706 c      s13d=0.0d0
8707       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8708 C Derivatives in gamma(i+3)
8709 #ifdef MOMENT
8710       call transpose2(AEA(1,1,1),auxmatd(1,1))
8711       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8712       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8713       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8714 #endif
8715       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8716       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8717       s2d = scalar2(b1(1,itk),vtemp1d(1))
8718 #ifdef MOMENT
8719       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8720       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8721 #endif
8722       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8723 #ifdef MOMENT
8724       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8725       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8726       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8727 #endif
8728 c      s1d=0.0d0
8729 c      s2d=0.0d0
8730 c      s8d=0.0d0
8731 c      s12d=0.0d0
8732 c      s13d=0.0d0
8733 #ifdef MOMENT
8734       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8735      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8736 #else
8737       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8738      &               -0.5d0*ekont*(s2d+s12d)
8739 #endif
8740 C Derivatives in gamma(i+4)
8741       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8742       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8743       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8744 #ifdef MOMENT
8745       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8746       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8747       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8748 #endif
8749 c      s1d=0.0d0
8750 c      s2d=0.0d0
8751 c      s8d=0.0d0
8752 C      s12d=0.0d0
8753 c      s13d=0.0d0
8754 #ifdef MOMENT
8755       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8756 #else
8757       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8758 #endif
8759 C Derivatives in gamma(i+5)
8760 #ifdef MOMENT
8761       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8762       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8763       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8764 #endif
8765       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8766       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8767       s2d = scalar2(b1(1,itk),vtemp1d(1))
8768 #ifdef MOMENT
8769       call transpose2(AEA(1,1,2),atempd(1,1))
8770       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8771       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8772 #endif
8773       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8774       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8775 #ifdef MOMENT
8776       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8777       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8778       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8779 #endif
8780 c      s1d=0.0d0
8781 c      s2d=0.0d0
8782 c      s8d=0.0d0
8783 c      s12d=0.0d0
8784 c      s13d=0.0d0
8785 #ifdef MOMENT
8786       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8787      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8788 #else
8789       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8790      &               -0.5d0*ekont*(s2d+s12d)
8791 #endif
8792 C Cartesian derivatives
8793       do iii=1,2
8794         do kkk=1,5
8795           do lll=1,3
8796 #ifdef MOMENT
8797             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8798             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8799             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8800 #endif
8801             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8802             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8803      &          vtemp1d(1))
8804             s2d = scalar2(b1(1,itk),vtemp1d(1))
8805 #ifdef MOMENT
8806             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8807             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8808             s8d = -(atempd(1,1)+atempd(2,2))*
8809      &           scalar2(cc(1,1,itl),vtemp2(1))
8810 #endif
8811             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8812      &           auxmatd(1,1))
8813             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8814             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8815 c      s1d=0.0d0
8816 c      s2d=0.0d0
8817 c      s8d=0.0d0
8818 c      s12d=0.0d0
8819 c      s13d=0.0d0
8820 #ifdef MOMENT
8821             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8822      &        - 0.5d0*(s1d+s2d)
8823 #else
8824             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8825      &        - 0.5d0*s2d
8826 #endif
8827 #ifdef MOMENT
8828             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8829      &        - 0.5d0*(s8d+s12d)
8830 #else
8831             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8832      &        - 0.5d0*s12d
8833 #endif
8834           enddo
8835         enddo
8836       enddo
8837 #ifdef MOMENT
8838       do kkk=1,5
8839         do lll=1,3
8840           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8841      &      achuj_tempd(1,1))
8842           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8843           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8844           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8845           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8846           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8847      &      vtemp4d(1))
8848           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8849           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8850           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8851         enddo
8852       enddo
8853 #endif
8854 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8855 cd     &  16*eel_turn6_num
8856 cd      goto 1112
8857       if (j.lt.nres-1) then
8858         j1=j+1
8859         j2=j-1
8860       else
8861         j1=j-1
8862         j2=j-2
8863       endif
8864       if (l.lt.nres-1) then
8865         l1=l+1
8866         l2=l-1
8867       else
8868         l1=l-1
8869         l2=l-2
8870       endif
8871       do ll=1,3
8872 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8873 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8874 cgrad        ghalf=0.5d0*ggg1(ll)
8875 cd        ghalf=0.0d0
8876         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8877         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8878         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8879      &    +ekont*derx_turn(ll,2,1)
8880         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8881         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8882      &    +ekont*derx_turn(ll,4,1)
8883         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8884         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8885         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8886 cgrad        ghalf=0.5d0*ggg2(ll)
8887 cd        ghalf=0.0d0
8888         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8889      &    +ekont*derx_turn(ll,2,2)
8890         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8891         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8892      &    +ekont*derx_turn(ll,4,2)
8893         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8894         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8895         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8896       enddo
8897 cd      goto 1112
8898 cgrad      do m=i+1,j-1
8899 cgrad        do ll=1,3
8900 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8901 cgrad        enddo
8902 cgrad      enddo
8903 cgrad      do m=k+1,l-1
8904 cgrad        do ll=1,3
8905 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8906 cgrad        enddo
8907 cgrad      enddo
8908 cgrad1112  continue
8909 cgrad      do m=i+2,j2
8910 cgrad        do ll=1,3
8911 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8912 cgrad        enddo
8913 cgrad      enddo
8914 cgrad      do m=k+2,l2
8915 cgrad        do ll=1,3
8916 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8917 cgrad        enddo
8918 cgrad      enddo
8919 cd      do iii=1,nres-3
8920 cd        write (2,*) iii,g_corr6_loc(iii)
8921 cd      enddo
8922       eello_turn6=ekont*eel_turn6
8923 cd      write (2,*) 'ekont',ekont
8924 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8925       return
8926       end
8927
8928 C-----------------------------------------------------------------------------
8929       double precision function scalar(u,v)
8930 !DIR$ INLINEALWAYS scalar
8931 #ifndef OSF
8932 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8933 #endif
8934       implicit none
8935       double precision u(3),v(3)
8936 cd      double precision sc
8937 cd      integer i
8938 cd      sc=0.0d0
8939 cd      do i=1,3
8940 cd        sc=sc+u(i)*v(i)
8941 cd      enddo
8942 cd      scalar=sc
8943
8944       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8945       return
8946       end
8947 crc-------------------------------------------------
8948       SUBROUTINE MATVEC2(A1,V1,V2)
8949 !DIR$ INLINEALWAYS MATVEC2
8950 #ifndef OSF
8951 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8952 #endif
8953       implicit real*8 (a-h,o-z)
8954       include 'DIMENSIONS'
8955       DIMENSION A1(2,2),V1(2),V2(2)
8956 c      DO 1 I=1,2
8957 c        VI=0.0
8958 c        DO 3 K=1,2
8959 c    3     VI=VI+A1(I,K)*V1(K)
8960 c        Vaux(I)=VI
8961 c    1 CONTINUE
8962
8963       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8964       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8965
8966       v2(1)=vaux1
8967       v2(2)=vaux2
8968       END
8969 C---------------------------------------
8970       SUBROUTINE MATMAT2(A1,A2,A3)
8971 #ifndef OSF
8972 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8973 #endif
8974       implicit real*8 (a-h,o-z)
8975       include 'DIMENSIONS'
8976       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8977 c      DIMENSION AI3(2,2)
8978 c        DO  J=1,2
8979 c          A3IJ=0.0
8980 c          DO K=1,2
8981 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8982 c          enddo
8983 c          A3(I,J)=A3IJ
8984 c       enddo
8985 c      enddo
8986
8987       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8988       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8989       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8990       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8991
8992       A3(1,1)=AI3_11
8993       A3(2,1)=AI3_21
8994       A3(1,2)=AI3_12
8995       A3(2,2)=AI3_22
8996       END
8997
8998 c-------------------------------------------------------------------------
8999       double precision function scalar2(u,v)
9000 !DIR$ INLINEALWAYS scalar2
9001       implicit none
9002       double precision u(2),v(2)
9003       double precision sc
9004       integer i
9005       scalar2=u(1)*v(1)+u(2)*v(2)
9006       return
9007       end
9008
9009 C-----------------------------------------------------------------------------
9010
9011       subroutine transpose2(a,at)
9012 !DIR$ INLINEALWAYS transpose2
9013 #ifndef OSF
9014 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9015 #endif
9016       implicit none
9017       double precision a(2,2),at(2,2)
9018       at(1,1)=a(1,1)
9019       at(1,2)=a(2,1)
9020       at(2,1)=a(1,2)
9021       at(2,2)=a(2,2)
9022       return
9023       end
9024 c--------------------------------------------------------------------------
9025       subroutine transpose(n,a,at)
9026       implicit none
9027       integer n,i,j
9028       double precision a(n,n),at(n,n)
9029       do i=1,n
9030         do j=1,n
9031           at(j,i)=a(i,j)
9032         enddo
9033       enddo
9034       return
9035       end
9036 C---------------------------------------------------------------------------
9037       subroutine prodmat3(a1,a2,kk,transp,prod)
9038 !DIR$ INLINEALWAYS prodmat3
9039 #ifndef OSF
9040 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9041 #endif
9042       implicit none
9043       integer i,j
9044       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9045       logical transp
9046 crc      double precision auxmat(2,2),prod_(2,2)
9047
9048       if (transp) then
9049 crc        call transpose2(kk(1,1),auxmat(1,1))
9050 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9051 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9052
9053            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9054      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9055            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9056      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9057            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9058      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9059            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9060      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9061
9062       else
9063 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9064 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9065
9066            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9067      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9068            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9069      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9070            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9071      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9072            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9073      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9074
9075       endif
9076 c      call transpose2(a2(1,1),a2t(1,1))
9077
9078 crc      print *,transp
9079 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9080 crc      print *,((prod(i,j),i=1,2),j=1,2)
9081
9082       return
9083       end
9084