source/cluster/wham/src-restraint-DFA/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6       external proc_proc
   7 #ifdef WINPGI
   8 cMS$ATTRIBUTES C ::  proc_proc
   9 #endif
  10
  11       include 'COMMON.IOUNITS'
  12       double precision energia(0:max_ene),energia1(0:max_ene+1)
  13 #ifdef MPL
  14       include 'COMMON.INFO'
  15       external d_vadd
  16       integer ready
  17 #endif
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.CONTROL'
  24
  25       double precision fact(5)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor,fact(1))
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105
 106 c      write(iout,*) "TEST_ENE",constr_homology
 107       if (constr_homology.ge.1) then
 108         call e_modeller(ehomology_constr)
 109       else
 110         ehomology_constr=0.0d0
 111       endif
 112 c      write(iout,*) "TEST_ENE",ehomology_constr
 113
 114 C     BARTEK for dfa test!
 115       if (wdfa_dist.gt.0) call edfad(edfadis)
 116 c      print*, 'edfad is finished!', edfadis
 117       if (wdfa_tor.gt.0) call edfat(edfator)
 118 c      print*, 'edfat is finished!', edfator
 119       if (wdfa_nei.gt.0) call edfan(edfanei)
 120 c      print*, 'edfan is finished!', edfanei
 121       if (wdfa_beta.gt.0) call edfab(edfabet)
 122 c      print*, 'edfab is finished!', edfabet
 123
 124
 125 C     call multibody(ecorr)
 126 C
 127 C Sum the energies
 128 C
 129 #ifdef SPLITELE
 130       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*ees+wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*(ees+evdw1)
 141      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 142      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 143      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 144      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 145      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 146      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 147      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 148      & +wdfa_beta*edfabet
 149 #endif
 150       energia(0)=etot
 151       energia(1)=evdw
 152 #ifdef SCP14
 153       energia(2)=evdw2-evdw2_14
 154       energia(17)=evdw2_14
 155 #else
 156       energia(2)=evdw2
 157       energia(17)=0.0d0
 158 #endif
 159 #ifdef SPLITELE
 160       energia(3)=ees
 161       energia(16)=evdw1
 162 #else
 163       energia(3)=ees+evdw1
 164       energia(16)=0.0d0
 165 #endif
 166       energia(4)=ecorr
 167       energia(5)=ecorr5
 168       energia(6)=ecorr6
 169       energia(7)=eel_loc
 170       energia(8)=eello_turn3
 171       energia(9)=eello_turn4
 172       energia(10)=eturn6
 173       energia(11)=ebe
 174       energia(12)=escloc
 175       energia(13)=etors
 176       energia(14)=etors_d
 177       energia(15)=ehpb
 178       energia(18)=estr
 179       energia(19)=esccor
 180       energia(20)=edihcnstr
 181       energia(21)=ehomology_constr
 182       energia(22)=edfadis
 183       energia(23)=edfator
 184       energia(24)=edfanei
 185       energia(25)=edfabet
 186 cc      if (dyn_ss) call dyn_set_nss
 187 c detecting NaNQ
 188       i=0
 189 #ifdef WINPGI
 190       idumm=proc_proc(etot,i)
 191 #else
 192       call proc_proc(etot,i)
 193 #endif
 194       if(i.eq.1)energia(0)=1.0d+99
 195 #ifdef MPL
 196 c     endif
 197 #endif
 198       if (calc_grad) then
 199 C
 200 C Sum up the components of the Cartesian gradient.
 201 C
 202 #ifdef SPLITELE
 203       do i=1,nct
 204         do j=1,3
 205           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 206      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 207      &                wbond*gradb(j,i)+
 208      &                wstrain*ghpbc(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)+
 217      &                wdfa_dist*gdfad(j,i)+
 218      &                wdfa_tor*gdfat(j,i)+
 219      &                wdfa_nei*gdfan(j,i)+
 220      &                wdfa_beta*gdfab(j,i)
 221           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 222      &                  wbond*gradbx(j,i)+
 223      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 224         enddo
 225 #else
 226       do i=1,nct
 227         do j=1,3
 228           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 229      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 230      &                wbond*gradb(j,i)+
 231      &                wcorr*fact(3)*gradcorr(j,i)+
 232      &                wel_loc*fact(2)*gel_loc(j,i)+
 233      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 234      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 235      &                wcorr5*fact(4)*gradcorr5(j,i)+
 236      &                wcorr6*fact(5)*gradcorr6(j,i)+
 237      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 238      &                wsccor*fact(2)*gsccorc(j,i)+
 239      &                wdfa_dist*gdfad(j,i)+
 240      &                wdfa_tor*gdfat(j,i)+
 241      &                wdfa_nei*gdfan(j,i)+
 242      &                wdfa_beta*gdfab(j,i)
 243           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 244      &                  wbond*gradbx(j,i)+
 245      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 246         enddo
 247 #endif
 248 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 249 cd   &        (gradc(k,i),k=1,3)
 250       enddo
 251
 252
 253       do i=1,nres-3
 254 cd        write (iout,*) i,g_corr5_loc(i)
 255         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 256      &   +wcorr5*fact(4)*g_corr5_loc(i)
 257      &   +wcorr6*fact(5)*g_corr6_loc(i)
 258      &   +wturn4*fact(3)*gel_loc_turn4(i)
 259      &   +wturn3*fact(2)*gel_loc_turn3(i)
 260      &   +wturn6*fact(5)*gel_loc_turn6(i)
 261      &   +wel_loc*fact(2)*gel_loc_loc(i)
 262      &   +wsccor*fact(1)*gsccor_loc(i)
 263       enddo
 264       endif
 265 cd    call enerprint(energia(0),fact)
 266 cd    call intout
 267 cd    stop
 268       return
 269       end
 270 C------------------------------------------------------------------------
 271       subroutine enerprint(energia,fact)
 272       implicit real*8 (a-h,o-z)
 273       include 'DIMENSIONS'
 274       include 'sizesclu.dat'
 275       include 'COMMON.IOUNITS'
 276       include 'COMMON.FFIELD'
 277       include 'COMMON.SBRIDGE'
 278       double precision energia(0:max_ene),fact(5)
 279       etot=energia(0)
 280       evdw=energia(1)
 281 #ifdef SCP14
 282       evdw2=energia(2)+energia(17)
 283 #else
 284       evdw2=energia(2)
 285 #endif
 286       ees=energia(3)
 287 #ifdef SPLITELE
 288       evdw1=energia(16)
 289 #endif
 290       ecorr=energia(4)
 291       ecorr5=energia(5)
 292       ecorr6=energia(6)
 293       eel_loc=energia(7)
 294       eello_turn3=energia(8)
 295       eello_turn4=energia(9)
 296       eello_turn6=energia(10)
 297       ebe=energia(11)
 298       escloc=energia(12)
 299       etors=energia(13)
 300       etors_d=energia(14)
 301       ehpb=energia(15)
 302       esccor=energia(19)
 303       edihcnstr=energia(20)
 304       estr=energia(18)
 305       ehomology_constr=energia(21)
 306       edfadis=energia(22)
 307       edfator=energia(23)
 308       edfanei=energia(24)
 309       edfabet=energia(25)
 310 #ifdef SPLITELE
 311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 312      &  wvdwpp,
 313      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 314      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 315      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 316      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 317      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 318      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 320      &  wdfa_beta,etot
 321    10 format (/'Virtual-chain energies:'//
 322      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 323      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 324      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 325      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 332      & ' (SS bridges & dist. cnstr.)'/
 333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 341      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 342      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 344      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 345      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 346      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 347      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #else
 350       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 351      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 352      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 353      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 354      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 355      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 356      &  edihcnstr,ehomology_constr,ebr*nss,
 357      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 358      &  wdfa_beta,etot
 359    10 format (/'Virtual-chain energies:'//
 360      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 361      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 362      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 363      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 364      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 365      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 366      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 367      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 368      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 369      & ' (SS bridges & dist. cnstr.)'/
 370      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 372      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 373      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 374      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 375      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 376      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 377      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 378      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 379      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 380      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 381      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 382      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 383      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 384      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 385      & 'ETOT=  ',1pE16.6,' (total)')
 386 #endif
 387       return
 388       end
 389 C-----------------------------------------------------------------------
 390       subroutine elj(evdw)
 391 C
 392 C This subroutine calculates the interaction energy of nonbonded side chains
 393 C assuming the LJ potential of interaction.
 394 C
 395       implicit real*8 (a-h,o-z)
 396       include 'DIMENSIONS'
 397       include 'sizesclu.dat'
 398 c      include "DIMENSIONS.COMPAR"
 399       parameter (accur=1.0d-10)
 400       include 'COMMON.GEO'
 401       include 'COMMON.VAR'
 402       include 'COMMON.LOCAL'
 403       include 'COMMON.CHAIN'
 404       include 'COMMON.DERIV'
 405       include 'COMMON.INTERACT'
 406       include 'COMMON.TORSION'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.NAMES'
 409       include 'COMMON.IOUNITS'
 410       include 'COMMON.CONTACTS'
 411       dimension gg(3)
 412       integer icant
 413       external icant
 414 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 415       evdw=0.0D0
 416       do i=iatsc_s,iatsc_e
 417         itypi=itype(i)
 418         itypi1=itype(i+1)
 419         xi=c(1,nres+i)
 420         yi=c(2,nres+i)
 421         zi=c(3,nres+i)
 422 C Change 12/1/95
 423         num_conti=0
 424 C
 425 C Calculate SC interaction energy.
 426 C
 427         do iint=1,nint_gr(i)
 428 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 429 cd   &                  'iend=',iend(i,iint)
 430           do j=istart(i,iint),iend(i,iint)
 431             itypj=itype(j)
 432             xj=c(1,nres+j)-xi
 433             yj=c(2,nres+j)-yi
 434             zj=c(3,nres+j)-zi
 435 C Change 12/1/95 to calculate four-body interactions
 436             rij=xj*xj+yj*yj+zj*zj
 437             rrij=1.0D0/rij
 438 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 439             eps0ij=eps(itypi,itypj)
 440             fac=rrij**expon2
 441             e1=fac*fac*aa(itypi,itypj)
 442             e2=fac*bb(itypi,itypj)
 443             evdwij=e1+e2
 444             ij=icant(itypi,itypj)
 445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 447 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 449 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 450 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 451             evdw=evdw+evdwij
 452             if (calc_grad) then
 453 C
 454 C Calculate the components of the gradient in DC and X
 455 C
 456             fac=-rrij*(e1+evdwij)
 457             gg(1)=xj*fac
 458             gg(2)=yj*fac
 459             gg(3)=zj*fac
 460             do k=1,3
 461               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 462               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 463             enddo
 464             do k=i,j-1
 465               do l=1,3
 466                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 467               enddo
 468             enddo
 469             endif
 470 C
 471 C 12/1/95, revised on 5/20/97
 472 C
 473 C Calculate the contact function. The ith column of the array JCONT will
 474 C contain the numbers of atoms that make contacts with the atom I (of numbers
 475 C greater than I). The arrays FACONT and GACONT will contain the values of
 476 C the contact function and its derivative.
 477 C
 478 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 479 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 480 C Uncomment next line, if the correlation interactions are contact function only
 481             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 482               rij=dsqrt(rij)
 483               sigij=sigma(itypi,itypj)
 484               r0ij=rs0(itypi,itypj)
 485 C
 486 C Check whether the SC's are not too far to make a contact.
 487 C
 488               rcut=1.5d0*r0ij
 489               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 490 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 491 C
 492               if (fcont.gt.0.0D0) then
 493 C If the SC-SC distance if close to sigma, apply spline.
 494 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 495 cAdam &             fcont1,fprimcont1)
 496 cAdam           fcont1=1.0d0-fcont1
 497 cAdam           if (fcont1.gt.0.0d0) then
 498 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 499 cAdam             fcont=fcont*fcont1
 500 cAdam           endif
 501 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 502 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 503 cga             do k=1,3
 504 cga               gg(k)=gg(k)*eps0ij
 505 cga             enddo
 506 cga             eps0ij=-evdwij*eps0ij
 507 C Uncomment for AL's type of SC correlation interactions.
 508 cadam           eps0ij=-evdwij
 509                 num_conti=num_conti+1
 510                 jcont(num_conti,i)=j
 511                 facont(num_conti,i)=fcont*eps0ij
 512                 fprimcont=eps0ij*fprimcont/rij
 513                 fcont=expon*fcont
 514 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 515 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 516 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 517 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 518                 gacont(1,num_conti,i)=-fprimcont*xj
 519                 gacont(2,num_conti,i)=-fprimcont*yj
 520                 gacont(3,num_conti,i)=-fprimcont*zj
 521 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 522 cd              write (iout,'(2i3,3f10.5)')
 523 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 524               endif
 525             endif
 526           enddo      ! j
 527         enddo        ! iint
 528 C Change 12/1/95
 529         num_cont(i)=num_conti
 530       enddo          ! i
 531       if (calc_grad) then
 532       do i=1,nct
 533         do j=1,3
 534           gvdwc(j,i)=expon*gvdwc(j,i)
 535           gvdwx(j,i)=expon*gvdwx(j,i)
 536         enddo
 537       enddo
 538       endif
 539 C******************************************************************************
 540 C
 541 C                              N O T E !!!
 542 C
 543 C To save time, the factor of EXPON has been extracted from ALL components
 544 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 545 C use!
 546 C
 547 C******************************************************************************
 548       return
 549       end
 550 C-----------------------------------------------------------------------------
 551       subroutine eljk(evdw)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJK potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'sizesclu.dat'
 559 c      include "DIMENSIONS.COMPAR"
 560       include 'COMMON.GEO'
 561       include 'COMMON.VAR'
 562       include 'COMMON.LOCAL'
 563       include 'COMMON.CHAIN'
 564       include 'COMMON.DERIV'
 565       include 'COMMON.INTERACT'
 566       include 'COMMON.IOUNITS'
 567       include 'COMMON.NAMES'
 568       dimension gg(3)
 569       logical scheck
 570       integer icant
 571       external icant
 572 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 573       evdw=0.0D0
 574       do i=iatsc_s,iatsc_e
 575         itypi=itype(i)
 576         itypi1=itype(i+1)
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=itype(j)
 586             xj=c(1,nres+j)-xi
 587             yj=c(2,nres+j)-yi
 588             zj=c(3,nres+j)-zi
 589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 590             fac_augm=rrij**expon
 591             e_augm=augm(itypi,itypj)*fac_augm
 592             r_inv_ij=dsqrt(rrij)
 593             rij=1.0D0/r_inv_ij
 594             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 595             fac=r_shift_inv**expon
 596             e1=fac*fac*aa(itypi,itypj)
 597             e2=fac*bb(itypi,itypj)
 598             evdwij=e_augm+e1+e2
 599             ij=icant(itypi,itypj)
 600 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 601 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 602 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 603 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 604 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 605 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 606 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 607             evdw=evdw+evdwij
 608             if (calc_grad) then
 609 C
 610 C Calculate the components of the gradient in DC and X
 611 C
 612             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 613             gg(1)=xj*fac
 614             gg(2)=yj*fac
 615             gg(3)=zj*fac
 616             do k=1,3
 617               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 618               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 619             enddo
 620             do k=i,j-1
 621               do l=1,3
 622                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 623               enddo
 624             enddo
 625             endif
 626           enddo      ! j
 627         enddo        ! iint
 628       enddo          ! i
 629       if (calc_grad) then
 630       do i=1,nct
 631         do j=1,3
 632           gvdwc(j,i)=expon*gvdwc(j,i)
 633           gvdwx(j,i)=expon*gvdwx(j,i)
 634         enddo
 635       enddo
 636       endif
 637       return
 638       end
 639 C-----------------------------------------------------------------------------
 640       subroutine ebp(evdw)
 641 C
 642 C This subroutine calculates the interaction energy of nonbonded side chains
 643 C assuming the Berne-Pechukas potential of interaction.
 644 C
 645       implicit real*8 (a-h,o-z)
 646       include 'DIMENSIONS'
 647       include 'sizesclu.dat'
 648 c      include "DIMENSIONS.COMPAR"
 649       include 'COMMON.GEO'
 650       include 'COMMON.VAR'
 651       include 'COMMON.LOCAL'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.DERIV'
 654       include 'COMMON.NAMES'
 655       include 'COMMON.INTERACT'
 656       include 'COMMON.IOUNITS'
 657       include 'COMMON.CALC'
 658       common /srutu/ icall
 659 c     double precision rrsave(maxdim)
 660       logical lprn
 661       integer icant
 662       external icant
 663       evdw=0.0D0
 664 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 665       evdw=0.0D0
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=itype(i)
 674         itypi1=itype(i+1)
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678         dxi=dc_norm(1,nres+i)
 679         dyi=dc_norm(2,nres+i)
 680         dzi=dc_norm(3,nres+i)
 681         dsci_inv=vbld_inv(i+nres)
 682 C
 683 C Calculate SC interaction energy.
 684 C
 685         do iint=1,nint_gr(i)
 686           do j=istart(i,iint),iend(i,iint)
 687             ind=ind+1
 688             itypj=itype(j)
 689             dscj_inv=vbld_inv(j+nres)
 690             chi1=chi(itypi,itypj)
 691             chi2=chi(itypj,itypi)
 692             chi12=chi1*chi2
 693             chip1=chip(itypi)
 694             chip2=chip(itypj)
 695             chip12=chip1*chip2
 696             alf1=alp(itypi)
 697             alf2=alp(itypj)
 698             alf12=0.5D0*(alf1+alf2)
 699 C For diagnostics only!!!
 700 c           chi1=0.0D0
 701 c           chi2=0.0D0
 702 c           chi12=0.0D0
 703 c           chip1=0.0D0
 704 c           chip2=0.0D0
 705 c           chip12=0.0D0
 706 c           alf1=0.0D0
 707 c           alf2=0.0D0
 708 c           alf12=0.0D0
 709             xj=c(1,nres+j)-xi
 710             yj=c(2,nres+j)-yi
 711             zj=c(3,nres+j)-zi
 712             dxj=dc_norm(1,nres+j)
 713             dyj=dc_norm(2,nres+j)
 714             dzj=dc_norm(3,nres+j)
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716 cd          if (icall.eq.0) then
 717 cd            rrsave(ind)=rrij
 718 cd          else
 719 cd            rrij=rrsave(ind)
 720 cd          endif
 721             rij=dsqrt(rrij)
 722 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 723             call sc_angular
 724 C Calculate whole angle-dependent part of epsilon and contributions
 725 C to its derivatives
 726             fac=(rrij*sigsq)**expon2
 727             e1=fac*fac*aa(itypi,itypj)
 728             e2=fac*bb(itypi,itypj)
 729             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 730             eps2der=evdwij*eps3rt
 731             eps3der=evdwij*eps2rt
 732             evdwij=evdwij*eps2rt*eps3rt
 733             ij=icant(itypi,itypj)
 734             aux=eps1*eps2rt**2*eps3rt**2
 735             evdw=evdw+evdwij
 736             if (calc_grad) then
 737             if (lprn) then
 738             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 741 cd     &        restyp(itypi),i,restyp(itypj),j,
 742 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 743 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 744 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 745 cd     &        evdwij
 746             endif
 747 C Calculate gradient components.
 748             e1=e1*eps1*eps2rt**2*eps3rt**2
 749             fac=-expon*(e1+evdwij)
 750             sigder=fac/sigsq
 751             fac=rrij*fac
 752 C Calculate radial part of the gradient
 753             gg(1)=xj*fac
 754             gg(2)=yj*fac
 755             gg(3)=zj*fac
 756 C Calculate the angular part of the gradient and sum add the contributions
 757 C to the appropriate components of the Cartesian gradient.
 758             call sc_grad
 759             endif
 760           enddo      ! j
 761         enddo        ! iint
 762       enddo          ! i
 763 c     stop
 764       return
 765       end
 766 C-----------------------------------------------------------------------------
 767       subroutine egb(evdw)
 768 C
 769 C This subroutine calculates the interaction energy of nonbonded side chains
 770 C assuming the Gay-Berne potential of interaction.
 771 C
 772       implicit real*8 (a-h,o-z)
 773       include 'DIMENSIONS'
 774       include 'sizesclu.dat'
 775 c      include "DIMENSIONS.COMPAR"
 776       include 'COMMON.GEO'
 777       include 'COMMON.VAR'
 778       include 'COMMON.LOCAL'
 779       include 'COMMON.CHAIN'
 780       include 'COMMON.DERIV'
 781       include 'COMMON.NAMES'
 782       include 'COMMON.INTERACT'
 783       include 'COMMON.IOUNITS'
 784       include 'COMMON.CALC'
 785       include 'COMMON.SBRIDGE'
 786       logical lprn
 787       common /srutu/icall
 788       integer icant
 789       external icant
 790       evdw=0.0D0
 791 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 792       evdw=0.0D0
 793       lprn=.false.
 794 c      if (icall.gt.0) lprn=.true.
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=itype(i)
 798         itypi1=itype(i+1)
 799         xi=c(1,nres+i)
 800         yi=c(2,nres+i)
 801         zi=c(3,nres+i)
 802         dxi=dc_norm(1,nres+i)
 803         dyi=dc_norm(2,nres+i)
 804         dzi=dc_norm(3,nres+i)
 805         dsci_inv=vbld_inv(i+nres)
 806 C
 807 C Calculate SC interaction energy.
 808 C
 809         do iint=1,nint_gr(i)
 810           do j=istart(i,iint),iend(i,iint)
 811             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 812               call dyn_ssbond_ene(i,j,evdwij)
 813               evdw=evdw+evdwij
 814 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 815 c     &                        'evdw',i,j,evdwij,' ss'
 816             ELSE
 817             ind=ind+1
 818             itypj=itype(j)
 819             dscj_inv=vbld_inv(j+nres)
 820             sig0ij=sigma(itypi,itypj)
 821             chi1=chi(itypi,itypj)
 822             chi2=chi(itypj,itypi)
 823             chi12=chi1*chi2
 824             chip1=chip(itypi)
 825             chip2=chip(itypj)
 826             chip12=chip1*chip2
 827             alf1=alp(itypi)
 828             alf2=alp(itypj)
 829             alf12=0.5D0*(alf1+alf2)
 830 C For diagnostics only!!!
 831 c           chi1=0.0D0
 832 c           chi2=0.0D0
 833 c           chi12=0.0D0
 834 c           chip1=0.0D0
 835 c           chip2=0.0D0
 836 c           chip12=0.0D0
 837 c           alf1=0.0D0
 838 c           alf2=0.0D0
 839 c           alf12=0.0D0
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843             dxj=dc_norm(1,nres+j)
 844             dyj=dc_norm(2,nres+j)
 845             dzj=dc_norm(3,nres+j)
 846 c            write (iout,*) i,j,xj,yj,zj
 847             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 848             rij=dsqrt(rrij)
 849 C Calculate angle-dependent terms of energy and contributions to their
 850 C derivatives.
 851             call sc_angular
 852             sigsq=1.0D0/sigsq
 853             sig=sig0ij*dsqrt(sigsq)
 854             rij_shift=1.0D0/rij-sig+sig0ij
 855 C I hate to put IF's in the loops, but here don't have another choice!!!!
 856             if (rij_shift.le.0.0D0) then
 857               evdw=1.0D20
 858               return
 859             endif
 860             sigder=-sig*sigsq
 861 c---------------------------------------------------------------
 862             rij_shift=1.0D0/rij_shift
 863             fac=rij_shift**expon
 864             e1=fac*fac*aa(itypi,itypj)
 865             e2=fac*bb(itypi,itypj)
 866             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 867             eps2der=evdwij*eps3rt
 868             eps3der=evdwij*eps2rt
 869             evdwij=evdwij*eps2rt*eps3rt
 870             evdw=evdw+evdwij
 871             ij=icant(itypi,itypj)
 872             aux=eps1*eps2rt**2*eps3rt**2
 873 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 874 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 875 c     &         aux*e2/eps(itypi,itypj)
 876             if (lprn) then
 877             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 878             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 879             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 880      &        restyp(itypi),i,restyp(itypj),j,
 881      &        epsi,sigm,chi1,chi2,chip1,chip2,
 882      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 883      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 884      &        evdwij
 885             endif
 886             if (calc_grad) then
 887 C Calculate gradient components.
 888             e1=e1*eps1*eps2rt**2*eps3rt**2
 889             fac=-expon*(e1+evdwij)*rij_shift
 890             sigder=fac*sigder
 891             fac=rij*fac
 892 C Calculate the radial part of the gradient
 893             gg(1)=xj*fac
 894             gg(2)=yj*fac
 895             gg(3)=zj*fac
 896 C Calculate angular part of the gradient.
 897             call sc_grad
 898             endif
 899             ENDIF    ! SSBOND
 900           enddo      ! j
 901         enddo        ! iint
 902       enddo          ! i
 903       return
 904       end
 905 C-----------------------------------------------------------------------------
 906       subroutine egbv(evdw)
 907 C
 908 C This subroutine calculates the interaction energy of nonbonded side chains
 909 C assuming the Gay-Berne-Vorobjev potential of interaction.
 910 C
 911       implicit real*8 (a-h,o-z)
 912       include 'DIMENSIONS'
 913       include 'sizesclu.dat'
 914 c      include "DIMENSIONS.COMPAR"
 915       include 'COMMON.GEO'
 916       include 'COMMON.VAR'
 917       include 'COMMON.LOCAL'
 918       include 'COMMON.CHAIN'
 919       include 'COMMON.DERIV'
 920       include 'COMMON.NAMES'
 921       include 'COMMON.INTERACT'
 922       include 'COMMON.IOUNITS'
 923       include 'COMMON.CALC'
 924       include 'COMMON.SBRIDGE'
 925       common /srutu/ icall
 926       logical lprn
 927       integer icant
 928       external icant
 929       evdw=0.0D0
 930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 931       evdw=0.0D0
 932       lprn=.false.
 933 c      if (icall.gt.0) lprn=.true.
 934       ind=0
 935       do i=iatsc_s,iatsc_e
 936         itypi=itype(i)
 937         itypi1=itype(i+1)
 938         xi=c(1,nres+i)
 939         yi=c(2,nres+i)
 940         zi=c(3,nres+i)
 941         dxi=dc_norm(1,nres+i)
 942         dyi=dc_norm(2,nres+i)
 943         dzi=dc_norm(3,nres+i)
 944         dsci_inv=vbld_inv(i+nres)
 945 C
 946 C Calculate SC interaction energy.
 947 C
 948         do iint=1,nint_gr(i)
 949           do j=istart(i,iint),iend(i,iint)
 950 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 951             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 952               call dyn_ssbond_ene(i,j,evdwij)
 953               evdw=evdw+evdwij
 954 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 955 c     &                        'evdw',i,j,evdwij,' ss'
 956             ELSE
 957             ind=ind+1
 958             itypj=itype(j)
 959             dscj_inv=vbld_inv(j+nres)
 960             sig0ij=sigma(itypi,itypj)
 961             r0ij=r0(itypi,itypj)
 962             chi1=chi(itypi,itypj)
 963             chi2=chi(itypj,itypi)
 964             chi12=chi1*chi2
 965             chip1=chip(itypi)
 966             chip2=chip(itypj)
 967             chip12=chip1*chip2
 968             alf1=alp(itypi)
 969             alf2=alp(itypj)
 970             alf12=0.5D0*(alf1+alf2)
 971 C For diagnostics only!!!
 972 c           chi1=0.0D0
 973 c           chi2=0.0D0
 974 c           chi12=0.0D0
 975 c           chip1=0.0D0
 976 c           chip2=0.0D0
 977 c           chip12=0.0D0
 978 c           alf1=0.0D0
 979 c           alf2=0.0D0
 980 c           alf12=0.0D0
 981             xj=c(1,nres+j)-xi
 982             yj=c(2,nres+j)-yi
 983             zj=c(3,nres+j)-zi
 984             dxj=dc_norm(1,nres+j)
 985             dyj=dc_norm(2,nres+j)
 986             dzj=dc_norm(3,nres+j)
 987             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 988             rij=dsqrt(rrij)
 989 C Calculate angle-dependent terms of energy and contributions to their
 990 C derivatives.
 991             call sc_angular
 992             sigsq=1.0D0/sigsq
 993             sig=sig0ij*dsqrt(sigsq)
 994             rij_shift=1.0D0/rij-sig+r0ij
 995 C I hate to put IF's in the loops, but here don't have another choice!!!!
 996             if (rij_shift.le.0.0D0) then
 997               evdw=1.0D20
 998               return
 999             endif
1000             sigder=-sig*sigsq
1001 c---------------------------------------------------------------
1002             rij_shift=1.0D0/rij_shift
1003             fac=rij_shift**expon
1004             e1=fac*fac*aa(itypi,itypj)
1005             e2=fac*bb(itypi,itypj)
1006             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1007             eps2der=evdwij*eps3rt
1008             eps3der=evdwij*eps2rt
1009             fac_augm=rrij**expon
1010             e_augm=augm(itypi,itypj)*fac_augm
1011             evdwij=evdwij*eps2rt*eps3rt
1012             evdw=evdw+evdwij+e_augm
1013             ij=icant(itypi,itypj)
1014             aux=eps1*eps2rt**2*eps3rt**2
1015 c            if (lprn) then
1016 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1017 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1018 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1019 c     &        restyp(itypi),i,restyp(itypj),j,
1020 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1021 c     &        chi1,chi2,chip1,chip2,
1022 c     &        eps1,eps2rt**2,eps3rt**2,
1023 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1024 c     &        evdwij+e_augm
1025 c            endif
1026             if (calc_grad) then
1027 C Calculate gradient components.
1028             e1=e1*eps1*eps2rt**2*eps3rt**2
1029             fac=-expon*(e1+evdwij)*rij_shift
1030             sigder=fac*sigder
1031             fac=rij*fac-2*expon*rrij*e_augm
1032 C Calculate the radial part of the gradient
1033             gg(1)=xj*fac
1034             gg(2)=yj*fac
1035             gg(3)=zj*fac
1036 C Calculate angular part of the gradient.
1037             call sc_grad
1038             endif
1039             ENDIF    ! dyn_ss
1040           enddo      ! j
1041         enddo        ! iint
1042       enddo          ! i
1043       return
1044       end
1045 C-----------------------------------------------------------------------------
1046       subroutine sc_angular
1047 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1048 C om12. Called by ebp, egb, and egbv.
1049       implicit none
1050       include 'COMMON.CALC'
1051       erij(1)=xj*rij
1052       erij(2)=yj*rij
1053       erij(3)=zj*rij
1054       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1055       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1056       om12=dxi*dxj+dyi*dyj+dzi*dzj
1057       chiom12=chi12*om12
1058 C Calculate eps1(om12) and its derivative in om12
1059       faceps1=1.0D0-om12*chiom12
1060       faceps1_inv=1.0D0/faceps1
1061       eps1=dsqrt(faceps1_inv)
1062 C Following variable is eps1*deps1/dom12
1063       eps1_om12=faceps1_inv*chiom12
1064 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1065 C and om12.
1066       om1om2=om1*om2
1067       chiom1=chi1*om1
1068       chiom2=chi2*om2
1069       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1070       sigsq=1.0D0-facsig*faceps1_inv
1071       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1072       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1073       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1074 C Calculate eps2 and its derivatives in om1, om2, and om12.
1075       chipom1=chip1*om1
1076       chipom2=chip2*om2
1077       chipom12=chip12*om12
1078       facp=1.0D0-om12*chipom12
1079       facp_inv=1.0D0/facp
1080       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1081 C Following variable is the square root of eps2
1082       eps2rt=1.0D0-facp1*facp_inv
1083 C Following three variables are the derivatives of the square root of eps
1084 C in om1, om2, and om12.
1085       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1086       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1087       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1088 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1089       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1090 C Calculate whole angle-dependent part of epsilon and contributions
1091 C to its derivatives
1092       return
1093       end
1094 C----------------------------------------------------------------------------
1095       subroutine sc_grad
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       include 'sizesclu.dat'
1099       include 'COMMON.CHAIN'
1100       include 'COMMON.DERIV'
1101       include 'COMMON.CALC'
1102       double precision dcosom1(3),dcosom2(3)
1103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1104       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1105       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1106      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1107       do k=1,3
1108         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1109         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1110       enddo
1111       do k=1,3
1112         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1113       enddo
1114       do k=1,3
1115         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1117      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1118         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1119      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1120      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1121       enddo
1122 C
1123 C Calculate the components of the gradient in DC and X
1124 C
1125       do k=i,j-1
1126         do l=1,3
1127           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128         enddo
1129       enddo
1130       return
1131       end
1132 c------------------------------------------------------------------------------
1133       subroutine vec_and_deriv
1134       implicit real*8 (a-h,o-z)
1135       include 'DIMENSIONS'
1136       include 'sizesclu.dat'
1137       include 'COMMON.IOUNITS'
1138       include 'COMMON.GEO'
1139       include 'COMMON.VAR'
1140       include 'COMMON.LOCAL'
1141       include 'COMMON.CHAIN'
1142       include 'COMMON.VECTORS'
1143       include 'COMMON.DERIV'
1144       include 'COMMON.INTERACT'
1145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1146 C Compute the local reference systems. For reference system (i), the
1147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1149       do i=1,nres-1
1150 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1151           if (i.eq.nres-1) then
1152 C Case of the last full residue
1153 C Compute the Z-axis
1154             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1155             costh=dcos(pi-theta(nres))
1156             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1157             do k=1,3
1158               uz(k,i)=fac*uz(k,i)
1159             enddo
1160             if (calc_grad) then
1161 C Compute the derivatives of uz
1162             uzder(1,1,1)= 0.0d0
1163             uzder(2,1,1)=-dc_norm(3,i-1)
1164             uzder(3,1,1)= dc_norm(2,i-1)
1165             uzder(1,2,1)= dc_norm(3,i-1)
1166             uzder(2,2,1)= 0.0d0
1167             uzder(3,2,1)=-dc_norm(1,i-1)
1168             uzder(1,3,1)=-dc_norm(2,i-1)
1169             uzder(2,3,1)= dc_norm(1,i-1)
1170             uzder(3,3,1)= 0.0d0
1171             uzder(1,1,2)= 0.0d0
1172             uzder(2,1,2)= dc_norm(3,i)
1173             uzder(3,1,2)=-dc_norm(2,i)
1174             uzder(1,2,2)=-dc_norm(3,i)
1175             uzder(2,2,2)= 0.0d0
1176             uzder(3,2,2)= dc_norm(1,i)
1177             uzder(1,3,2)= dc_norm(2,i)
1178             uzder(2,3,2)=-dc_norm(1,i)
1179             uzder(3,3,2)= 0.0d0
1180             endif
1181 C Compute the Y-axis
1182             facy=fac
1183             do k=1,3
1184               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1185             enddo
1186             if (calc_grad) then
1187 C Compute the derivatives of uy
1188             do j=1,3
1189               do k=1,3
1190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1193               enddo
1194               uyder(j,j,1)=uyder(j,j,1)-costh
1195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1196             enddo
1197             do j=1,2
1198               do k=1,3
1199                 do l=1,3
1200                   uygrad(l,k,j,i)=uyder(l,k,j)
1201                   uzgrad(l,k,j,i)=uzder(l,k,j)
1202                 enddo
1203               enddo
1204             enddo
1205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1209             endif
1210           else
1211 C Other residues
1212 C Compute the Z-axis
1213             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1214             costh=dcos(pi-theta(i+2))
1215             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1216             do k=1,3
1217               uz(k,i)=fac*uz(k,i)
1218             enddo
1219             if (calc_grad) then
1220 C Compute the derivatives of uz
1221             uzder(1,1,1)= 0.0d0
1222             uzder(2,1,1)=-dc_norm(3,i+1)
1223             uzder(3,1,1)= dc_norm(2,i+1)
1224             uzder(1,2,1)= dc_norm(3,i+1)
1225             uzder(2,2,1)= 0.0d0
1226             uzder(3,2,1)=-dc_norm(1,i+1)
1227             uzder(1,3,1)=-dc_norm(2,i+1)
1228             uzder(2,3,1)= dc_norm(1,i+1)
1229             uzder(3,3,1)= 0.0d0
1230             uzder(1,1,2)= 0.0d0
1231             uzder(2,1,2)= dc_norm(3,i)
1232             uzder(3,1,2)=-dc_norm(2,i)
1233             uzder(1,2,2)=-dc_norm(3,i)
1234             uzder(2,2,2)= 0.0d0
1235             uzder(3,2,2)= dc_norm(1,i)
1236             uzder(1,3,2)= dc_norm(2,i)
1237             uzder(2,3,2)=-dc_norm(1,i)
1238             uzder(3,3,2)= 0.0d0
1239             endif
1240 C Compute the Y-axis
1241             facy=fac
1242             do k=1,3
1243               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1244             enddo
1245             if (calc_grad) then
1246 C Compute the derivatives of uy
1247             do j=1,3
1248               do k=1,3
1249                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1250      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1251                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1252               enddo
1253               uyder(j,j,1)=uyder(j,j,1)-costh
1254               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1255             enddo
1256             do j=1,2
1257               do k=1,3
1258                 do l=1,3
1259                   uygrad(l,k,j,i)=uyder(l,k,j)
1260                   uzgrad(l,k,j,i)=uzder(l,k,j)
1261                 enddo
1262               enddo
1263             enddo
1264             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1265             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1266             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1267             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1268           endif
1269           endif
1270       enddo
1271       if (calc_grad) then
1272       do i=1,nres-1
1273         vbld_inv_temp(1)=vbld_inv(i+1)
1274         if (i.lt.nres-1) then
1275           vbld_inv_temp(2)=vbld_inv(i+2)
1276         else
1277           vbld_inv_temp(2)=vbld_inv(i)
1278         endif
1279         do j=1,2
1280           do k=1,3
1281             do l=1,3
1282               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1283               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1284             enddo
1285           enddo
1286         enddo
1287       enddo
1288       endif
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine vec_and_deriv_test
1293       implicit real*8 (a-h,o-z)
1294       include 'DIMENSIONS'
1295       include 'sizesclu.dat'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.VECTORS'
1302       dimension uyder(3,3,2),uzder(3,3,2)
1303 C Compute the local reference systems. For reference system (i), the
1304 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1305 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1306       do i=1,nres-1
1307           if (i.eq.nres-1) then
1308 C Case of the last full residue
1309 C Compute the Z-axis
1310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1311             costh=dcos(pi-theta(nres))
1312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1313 c            write (iout,*) 'fac',fac,
1314 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1315             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1316             do k=1,3
1317               uz(k,i)=fac*uz(k,i)
1318             enddo
1319 C Compute the derivatives of uz
1320             uzder(1,1,1)= 0.0d0
1321             uzder(2,1,1)=-dc_norm(3,i-1)
1322             uzder(3,1,1)= dc_norm(2,i-1)
1323             uzder(1,2,1)= dc_norm(3,i-1)
1324             uzder(2,2,1)= 0.0d0
1325             uzder(3,2,1)=-dc_norm(1,i-1)
1326             uzder(1,3,1)=-dc_norm(2,i-1)
1327             uzder(2,3,1)= dc_norm(1,i-1)
1328             uzder(3,3,1)= 0.0d0
1329             uzder(1,1,2)= 0.0d0
1330             uzder(2,1,2)= dc_norm(3,i)
1331             uzder(3,1,2)=-dc_norm(2,i)
1332             uzder(1,2,2)=-dc_norm(3,i)
1333             uzder(2,2,2)= 0.0d0
1334             uzder(3,2,2)= dc_norm(1,i)
1335             uzder(1,3,2)= dc_norm(2,i)
1336             uzder(2,3,2)=-dc_norm(1,i)
1337             uzder(3,3,2)= 0.0d0
1338 C Compute the Y-axis
1339             do k=1,3
1340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1341             enddo
1342             facy=fac
1343             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1344      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1345      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1346             do k=1,3
1347 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348               uy(k,i)=
1349 c     &        facy*(
1350      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1351      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1352 c     &        )
1353             enddo
1354 c            write (iout,*) 'facy',facy,
1355 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1356             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1357             do k=1,3
1358               uy(k,i)=facy*uy(k,i)
1359             enddo
1360 C Compute the derivatives of uy
1361             do j=1,3
1362               do k=1,3
1363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1366               enddo
1367 c              uyder(j,j,1)=uyder(j,j,1)-costh
1368 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1369               uyder(j,j,1)=uyder(j,j,1)
1370      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1371               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1372      &          +uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386           else
1387 C Other residues
1388 C Compute the Z-axis
1389             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1390             costh=dcos(pi-theta(i+2))
1391             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i+1)
1399             uzder(3,1,1)= dc_norm(2,i+1)
1400             uzder(1,2,1)= dc_norm(3,i+1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i+1)
1403             uzder(1,3,1)=-dc_norm(2,i+1)
1404             uzder(2,3,1)= dc_norm(1,i+1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             facy=fac
1417             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1418      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1419      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1420             do k=1,3
1421 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1422               uy(k,i)=
1423 c     &        facy*(
1424      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1425      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1426 c     &        )
1427             enddo
1428 c            write (iout,*) 'facy',facy,
1429 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1430             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1431             do k=1,3
1432               uy(k,i)=facy*uy(k,i)
1433             enddo
1434 C Compute the derivatives of uy
1435             do j=1,3
1436               do k=1,3
1437                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1438      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1439                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1440               enddo
1441 c              uyder(j,j,1)=uyder(j,j,1)-costh
1442 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1443               uyder(j,j,1)=uyder(j,j,1)
1444      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1445               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1446      &          +uyder(j,j,2)
1447             enddo
1448             do j=1,2
1449               do k=1,3
1450                 do l=1,3
1451                   uygrad(l,k,j,i)=uyder(l,k,j)
1452                   uzgrad(l,k,j,i)=uzder(l,k,j)
1453                 enddo
1454               enddo
1455             enddo
1456             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1457             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1458             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1459             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1460           endif
1461       enddo
1462       do i=1,nres-1
1463         do j=1,2
1464           do k=1,3
1465             do l=1,3
1466               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1467               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1468             enddo
1469           enddo
1470         enddo
1471       enddo
1472       return
1473       end
1474 C-----------------------------------------------------------------------------
1475       subroutine check_vecgrad
1476       implicit real*8 (a-h,o-z)
1477       include 'DIMENSIONS'
1478       include 'sizesclu.dat'
1479       include 'COMMON.IOUNITS'
1480       include 'COMMON.GEO'
1481       include 'COMMON.VAR'
1482       include 'COMMON.LOCAL'
1483       include 'COMMON.CHAIN'
1484       include 'COMMON.VECTORS'
1485       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1486       dimension uyt(3,maxres),uzt(3,maxres)
1487       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1488       double precision delta /1.0d-7/
1489       call vec_and_deriv
1490 cd      do i=1,nres
1491 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1492 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1493 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1494 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1495 cd     &     (dc_norm(if90,i),if90=1,3)
1496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1497 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1498 cd          write(iout,'(a)')
1499 cd      enddo
1500       do i=1,nres
1501         do j=1,2
1502           do k=1,3
1503             do l=1,3
1504               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1505               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1506             enddo
1507           enddo
1508         enddo
1509       enddo
1510       call vec_and_deriv
1511       do i=1,nres
1512         do j=1,3
1513           uyt(j,i)=uy(j,i)
1514           uzt(j,i)=uz(j,i)
1515         enddo
1516       enddo
1517       do i=1,nres
1518 cd        write (iout,*) 'i=',i
1519         do k=1,3
1520           erij(k)=dc_norm(k,i)
1521         enddo
1522         do j=1,3
1523           do k=1,3
1524             dc_norm(k,i)=erij(k)
1525           enddo
1526           dc_norm(j,i)=dc_norm(j,i)+delta
1527 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1528 c          do k=1,3
1529 c            dc_norm(k,i)=dc_norm(k,i)/fac
1530 c          enddo
1531 c          write (iout,*) (dc_norm(k,i),k=1,3)
1532 c          write (iout,*) (erij(k),k=1,3)
1533           call vec_and_deriv
1534           do k=1,3
1535             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1536             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1537             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1538             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1539           enddo
1540 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1541 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1542 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1543         enddo
1544         do k=1,3
1545           dc_norm(k,i)=erij(k)
1546         enddo
1547 cd        do k=1,3
1548 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1549 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1550 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1551 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1552 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1553 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1554 cd          write (iout,'(a)')
1555 cd        enddo
1556       enddo
1557       return
1558       end
1559 C--------------------------------------------------------------------------
1560       subroutine set_matrices
1561       implicit real*8 (a-h,o-z)
1562       include 'DIMENSIONS'
1563       include 'sizesclu.dat'
1564       include 'COMMON.IOUNITS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.CONTACTS'
1572       include 'COMMON.TORSION'
1573       include 'COMMON.VECTORS'
1574       include 'COMMON.FFIELD'
1575       double precision auxvec(2),auxmat(2,2)
1576 C
1577 C Compute the virtual-bond-torsional-angle dependent quantities needed
1578 C to calculate the el-loc multibody terms of various order.
1579 C
1580       do i=3,nres+1
1581         if (i .lt. nres+1) then
1582           sin1=dsin(phi(i))
1583           cos1=dcos(phi(i))
1584           sintab(i-2)=sin1
1585           costab(i-2)=cos1
1586           obrot(1,i-2)=cos1
1587           obrot(2,i-2)=sin1
1588           sin2=dsin(2*phi(i))
1589           cos2=dcos(2*phi(i))
1590           sintab2(i-2)=sin2
1591           costab2(i-2)=cos2
1592           obrot2(1,i-2)=cos2
1593           obrot2(2,i-2)=sin2
1594           Ug(1,1,i-2)=-cos1
1595           Ug(1,2,i-2)=-sin1
1596           Ug(2,1,i-2)=-sin1
1597           Ug(2,2,i-2)= cos1
1598           Ug2(1,1,i-2)=-cos2
1599           Ug2(1,2,i-2)=-sin2
1600           Ug2(2,1,i-2)=-sin2
1601           Ug2(2,2,i-2)= cos2
1602         else
1603           costab(i-2)=1.0d0
1604           sintab(i-2)=0.0d0
1605           obrot(1,i-2)=1.0d0
1606           obrot(2,i-2)=0.0d0
1607           obrot2(1,i-2)=0.0d0
1608           obrot2(2,i-2)=0.0d0
1609           Ug(1,1,i-2)=1.0d0
1610           Ug(1,2,i-2)=0.0d0
1611           Ug(2,1,i-2)=0.0d0
1612           Ug(2,2,i-2)=1.0d0
1613           Ug2(1,1,i-2)=0.0d0
1614           Ug2(1,2,i-2)=0.0d0
1615           Ug2(2,1,i-2)=0.0d0
1616           Ug2(2,2,i-2)=0.0d0
1617         endif
1618         if (i .gt. 3 .and. i .lt. nres+1) then
1619           obrot_der(1,i-2)=-sin1
1620           obrot_der(2,i-2)= cos1
1621           Ugder(1,1,i-2)= sin1
1622           Ugder(1,2,i-2)=-cos1
1623           Ugder(2,1,i-2)=-cos1
1624           Ugder(2,2,i-2)=-sin1
1625           dwacos2=cos2+cos2
1626           dwasin2=sin2+sin2
1627           obrot2_der(1,i-2)=-dwasin2
1628           obrot2_der(2,i-2)= dwacos2
1629           Ug2der(1,1,i-2)= dwasin2
1630           Ug2der(1,2,i-2)=-dwacos2
1631           Ug2der(2,1,i-2)=-dwacos2
1632           Ug2der(2,2,i-2)=-dwasin2
1633         else
1634           obrot_der(1,i-2)=0.0d0
1635           obrot_der(2,i-2)=0.0d0
1636           Ugder(1,1,i-2)=0.0d0
1637           Ugder(1,2,i-2)=0.0d0
1638           Ugder(2,1,i-2)=0.0d0
1639           Ugder(2,2,i-2)=0.0d0
1640           obrot2_der(1,i-2)=0.0d0
1641           obrot2_der(2,i-2)=0.0d0
1642           Ug2der(1,1,i-2)=0.0d0
1643           Ug2der(1,2,i-2)=0.0d0
1644           Ug2der(2,1,i-2)=0.0d0
1645           Ug2der(2,2,i-2)=0.0d0
1646         endif
1647         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1648           iti = itortyp(itype(i-2))
1649         else
1650           iti=ntortyp+1
1651         endif
1652         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1653           iti1 = itortyp(itype(i-1))
1654         else
1655           iti1=ntortyp+1
1656         endif
1657 cd        write (iout,*) '*******i',i,' iti1',iti
1658 cd        write (iout,*) 'b1',b1(:,iti)
1659 cd        write (iout,*) 'b2',b2(:,iti)
1660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1661         if (i .gt. iatel_s+2) then
1662           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1663           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1664           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1665           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1666           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1667           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1668           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1669         else
1670           do k=1,2
1671             Ub2(k,i-2)=0.0d0
1672             Ctobr(k,i-2)=0.0d0
1673             Dtobr2(k,i-2)=0.0d0
1674             do l=1,2
1675               EUg(l,k,i-2)=0.0d0
1676               CUg(l,k,i-2)=0.0d0
1677               DUg(l,k,i-2)=0.0d0
1678               DtUg2(l,k,i-2)=0.0d0
1679             enddo
1680           enddo
1681         endif
1682         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1683         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1684         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1685         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1686         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1687         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1688         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1689         do k=1,2
1690           muder(k,i-2)=Ub2der(k,i-2)
1691         enddo
1692         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1693           iti1 = itortyp(itype(i-1))
1694         else
1695           iti1=ntortyp+1
1696         endif
1697         do k=1,2
1698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1699         enddo
1700 C Vectors and matrices dependent on a single virtual-bond dihedral.
1701         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1702         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1703         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1704         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1705         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1706         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1707         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1708         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1709         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1710 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1711 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1712       enddo
1713 C Matrices dependent on two consecutive virtual-bond dihedrals.
1714 C The order of matrices is from left to right.
1715       do i=2,nres-1
1716         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1717         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1718         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1719         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1720         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1721         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1722         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1723         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1724       enddo
1725 cd      do i=1,nres
1726 cd        iti = itortyp(itype(i))
1727 cd        write (iout,*) i
1728 cd        do j=1,2
1729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1731 cd        enddo
1732 cd      enddo
1733       return
1734       end
1735 C--------------------------------------------------------------------------
1736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1737 C
1738 C This subroutine calculates the average interaction energy and its gradient
1739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1741 C The potential depends both on the distance of peptide-group centers and on
1742 C the orientation of the CA-CA virtual bonds.
1743 C
1744       implicit real*8 (a-h,o-z)
1745       include 'DIMENSIONS'
1746       include 'sizesclu.dat'
1747       include 'COMMON.CONTROL'
1748       include 'COMMON.IOUNITS'
1749       include 'COMMON.GEO'
1750       include 'COMMON.VAR'
1751       include 'COMMON.LOCAL'
1752       include 'COMMON.CHAIN'
1753       include 'COMMON.DERIV'
1754       include 'COMMON.INTERACT'
1755       include 'COMMON.CONTACTS'
1756       include 'COMMON.TORSION'
1757       include 'COMMON.VECTORS'
1758       include 'COMMON.FFIELD'
1759       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1760      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1761       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1765       double precision scal_el /0.5d0/
1766 C 12/13/98
1767 C 13-go grudnia roku pamietnego...
1768       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1769      &                   0.0d0,1.0d0,0.0d0,
1770      &                   0.0d0,0.0d0,1.0d0/
1771 cd      write(iout,*) 'In EELEC'
1772 cd      do i=1,nloctyp
1773 cd        write(iout,*) 'Type',i
1774 cd        write(iout,*) 'B1',B1(:,i)
1775 cd        write(iout,*) 'B2',B2(:,i)
1776 cd        write(iout,*) 'CC',CC(:,:,i)
1777 cd        write(iout,*) 'DD',DD(:,:,i)
1778 cd        write(iout,*) 'EE',EE(:,:,i)
1779 cd      enddo
1780 cd      call check_vecgrad
1781 cd      stop
1782       if (icheckgrad.eq.1) then
1783         do i=1,nres-1
1784           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1785           do k=1,3
1786             dc_norm(k,i)=dc(k,i)*fac
1787           enddo
1788 c          write (iout,*) 'i',i,' fac',fac
1789         enddo
1790       endif
1791       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1792      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1793      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1794 cd      if (wel_loc.gt.0.0d0) then
1795         if (icheckgrad.eq.1) then
1796         call vec_and_deriv_test
1797         else
1798         call vec_and_deriv
1799         endif
1800         call set_matrices
1801       endif
1802 cd      do i=1,nres-1
1803 cd        write (iout,*) 'i=',i
1804 cd        do k=1,3
1805 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1806 cd        enddo
1807 cd        do k=1,3
1808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1810 cd        enddo
1811 cd      enddo
1812       num_conti_hb=0
1813       ees=0.0D0
1814       evdw1=0.0D0
1815       eel_loc=0.0d0
1816       eello_turn3=0.0d0
1817       eello_turn4=0.0d0
1818       ind=0
1819       do i=1,nres
1820         num_cont_hb(i)=0
1821       enddo
1822 cd      print '(a)','Enter EELEC'
1823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1824       do i=1,nres
1825         gel_loc_loc(i)=0.0d0
1826         gcorr_loc(i)=0.0d0
1827       enddo
1828       do i=iatel_s,iatel_e
1829         if (itel(i).eq.0) goto 1215
1830         dxi=dc(1,i)
1831         dyi=dc(2,i)
1832         dzi=dc(3,i)
1833         dx_normi=dc_norm(1,i)
1834         dy_normi=dc_norm(2,i)
1835         dz_normi=dc_norm(3,i)
1836         xmedi=c(1,i)+0.5d0*dxi
1837         ymedi=c(2,i)+0.5d0*dyi
1838         zmedi=c(3,i)+0.5d0*dzi
1839         num_conti=0
1840 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1841         do j=ielstart(i),ielend(i)
1842           if (itel(j).eq.0) goto 1216
1843           ind=ind+1
1844           iteli=itel(i)
1845           itelj=itel(j)
1846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1847           aaa=app(iteli,itelj)
1848           bbb=bpp(iteli,itelj)
1849 C Diagnostics only!!!
1850 c         aaa=0.0D0
1851 c         bbb=0.0D0
1852 c         ael6i=0.0D0
1853 c         ael3i=0.0D0
1854 C End diagnostics
1855           ael6i=ael6(iteli,itelj)
1856           ael3i=ael3(iteli,itelj)
1857           dxj=dc(1,j)
1858           dyj=dc(2,j)
1859           dzj=dc(3,j)
1860           dx_normj=dc_norm(1,j)
1861           dy_normj=dc_norm(2,j)
1862           dz_normj=dc_norm(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           rrmij=1.0D0/rij
1868           rij=dsqrt(rij)
1869           rmij=1.0D0/rij
1870           r3ij=rrmij*rmij
1871           r6ij=r3ij*r3ij
1872           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1873           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1874           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1875           fac=cosa-3.0D0*cosb*cosg
1876           ev1=aaa*r6ij*r6ij
1877 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1878           if (j.eq.i+2) ev1=scal_el*ev1
1879           ev2=bbb*r6ij
1880           fac3=ael6i*r6ij
1881           fac4=ael3i*r3ij
1882           evdwij=ev1+ev2
1883           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1884           el2=fac4*fac
1885           eesij=el1+el2
1886 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1887 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1888           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1889           ees=ees+eesij
1890           evdw1=evdw1+evdwij
1891 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1892 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1893 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1894 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1895 C
1896 C Calculate contributions to the Cartesian gradient.
1897 C
1898 #ifdef SPLITELE
1899           facvdw=-6*rrmij*(ev1+evdwij)
1900           facel=-3*rrmij*(el1+eesij)
1901           fac1=fac
1902           erij(1)=xj*rmij
1903           erij(2)=yj*rmij
1904           erij(3)=zj*rmij
1905           if (calc_grad) then
1906 *
1907 * Radial derivatives. First process both termini of the fragment (i,j)
1908 *
1909           ggg(1)=facel*xj
1910           ggg(2)=facel*yj
1911           ggg(3)=facel*zj
1912           do k=1,3
1913             ghalf=0.5D0*ggg(k)
1914             gelc(k,i)=gelc(k,i)+ghalf
1915             gelc(k,j)=gelc(k,j)+ghalf
1916           enddo
1917 *
1918 * Loop over residues i+1 thru j-1.
1919 *
1920           do k=i+1,j-1
1921             do l=1,3
1922               gelc(l,k)=gelc(l,k)+ggg(l)
1923             enddo
1924           enddo
1925           ggg(1)=facvdw*xj
1926           ggg(2)=facvdw*yj
1927           ggg(3)=facvdw*zj
1928           do k=1,3
1929             ghalf=0.5D0*ggg(k)
1930             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1931             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1932           enddo
1933 *
1934 * Loop over residues i+1 thru j-1.
1935 *
1936           do k=i+1,j-1
1937             do l=1,3
1938               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1939             enddo
1940           enddo
1941 #else
1942           facvdw=ev1+evdwij
1943           facel=el1+eesij
1944           fac1=fac
1945           fac=-3*rrmij*(facvdw+facvdw+facel)
1946           erij(1)=xj*rmij
1947           erij(2)=yj*rmij
1948           erij(3)=zj*rmij
1949           if (calc_grad) then
1950 *
1951 * Radial derivatives. First process both termini of the fragment (i,j)
1952 *
1953           ggg(1)=fac*xj
1954           ggg(2)=fac*yj
1955           ggg(3)=fac*zj
1956           do k=1,3
1957             ghalf=0.5D0*ggg(k)
1958             gelc(k,i)=gelc(k,i)+ghalf
1959             gelc(k,j)=gelc(k,j)+ghalf
1960           enddo
1961 *
1962 * Loop over residues i+1 thru j-1.
1963 *
1964           do k=i+1,j-1
1965             do l=1,3
1966               gelc(l,k)=gelc(l,k)+ggg(l)
1967             enddo
1968           enddo
1969 #endif
1970 *
1971 * Angular part
1972 *
1973           ecosa=2.0D0*fac3*fac1+fac4
1974           fac4=-3.0D0*fac4
1975           fac3=-6.0D0*fac3
1976           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1977           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1978           do k=1,3
1979             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1980             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1981           enddo
1982 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1983 cd   &          (dcosg(k),k=1,3)
1984           do k=1,3
1985             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1986           enddo
1987           do k=1,3
1988             ghalf=0.5D0*ggg(k)
1989             gelc(k,i)=gelc(k,i)+ghalf
1990      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1991      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1992             gelc(k,j)=gelc(k,j)+ghalf
1993      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1994      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1995           enddo
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           endif
2002
2003           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2004      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2005      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2006 C
2007 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2008 C   energy of a peptide unit is assumed in the form of a second-order
2009 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2010 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2011 C   are computed for EVERY pair of non-contiguous peptide groups.
2012 C
2013           if (j.lt.nres-1) then
2014             j1=j+1
2015             j2=j-1
2016           else
2017             j1=j-1
2018             j2=j-2
2019           endif
2020           kkk=0
2021           do k=1,2
2022             do l=1,2
2023               kkk=kkk+1
2024               muij(kkk)=mu(k,i)*mu(l,j)
2025             enddo
2026           enddo
2027 cd         write (iout,*) 'EELEC: i',i,' j',j
2028 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2029 cd          write(iout,*) 'muij',muij
2030           ury=scalar(uy(1,i),erij)
2031           urz=scalar(uz(1,i),erij)
2032           vry=scalar(uy(1,j),erij)
2033           vrz=scalar(uz(1,j),erij)
2034           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2035           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2036           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2037           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2038 C For diagnostics only
2039 cd          a22=1.0d0
2040 cd          a23=1.0d0
2041 cd          a32=1.0d0
2042 cd          a33=1.0d0
2043           fac=dsqrt(-ael6i)*r3ij
2044 cd          write (2,*) 'fac=',fac
2045 C For diagnostics only
2046 cd          fac=1.0d0
2047           a22=a22*fac
2048           a23=a23*fac
2049           a32=a32*fac
2050           a33=a33*fac
2051 cd          write (iout,'(4i5,4f10.5)')
2052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2055 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2056 cd          write (iout,'(4f10.5)')
2057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2060 cd           write (iout,'(2i3,9f10.5/)') i,j,
2061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2062           if (calc_grad) then
2063 C Derivatives of the elements of A in virtual-bond vectors
2064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2065 cd          do k=1,3
2066 cd            do l=1,3
2067 cd              erder(k,l)=0.0d0
2068 cd            enddo
2069 cd          enddo
2070           do k=1,3
2071             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2072             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2073             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2074             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2075             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2076             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2077             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2078             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2079             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2080             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2081             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2082             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2083           enddo
2084 cd          do k=1,3
2085 cd            do l=1,3
2086 cd              uryg(k,l)=0.0d0
2087 cd              urzg(k,l)=0.0d0
2088 cd              vryg(k,l)=0.0d0
2089 cd              vrzg(k,l)=0.0d0
2090 cd            enddo
2091 cd          enddo
2092 C Compute radial contributions to the gradient
2093           facr=-3.0d0*rrmij
2094           a22der=a22*facr
2095           a23der=a23*facr
2096           a32der=a32*facr
2097           a33der=a33*facr
2098 cd          a22der=0.0d0
2099 cd          a23der=0.0d0
2100 cd          a32der=0.0d0
2101 cd          a33der=0.0d0
2102           agg(1,1)=a22der*xj
2103           agg(2,1)=a22der*yj
2104           agg(3,1)=a22der*zj
2105           agg(1,2)=a23der*xj
2106           agg(2,2)=a23der*yj
2107           agg(3,2)=a23der*zj
2108           agg(1,3)=a32der*xj
2109           agg(2,3)=a32der*yj
2110           agg(3,3)=a32der*zj
2111           agg(1,4)=a33der*xj
2112           agg(2,4)=a33der*yj
2113           agg(3,4)=a33der*zj
2114 C Add the contributions coming from er
2115           fac3=-3.0d0*fac
2116           do k=1,3
2117             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2118             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2119             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2120             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2121           enddo
2122           do k=1,3
2123 C Derivatives in DC(i)
2124             ghalf1=0.5d0*agg(k,1)
2125             ghalf2=0.5d0*agg(k,2)
2126             ghalf3=0.5d0*agg(k,3)
2127             ghalf4=0.5d0*agg(k,4)
2128             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2129      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2130             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2131      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2132             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2133      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2134             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2135      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2136 C Derivatives in DC(i+1)
2137             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2138      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2139             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2140      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2141             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2142      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2143             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2144      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2145 C Derivatives in DC(j)
2146             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2147      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2148             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2149      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2150             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2151      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2152             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2153      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2154 C Derivatives in DC(j+1) or DC(nres-1)
2155             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2156      &      -3.0d0*vryg(k,3)*ury)
2157             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2158      &      -3.0d0*vrzg(k,3)*ury)
2159             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2160      &      -3.0d0*vryg(k,3)*urz)
2161             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2162      &      -3.0d0*vrzg(k,3)*urz)
2163 cd            aggi(k,1)=ghalf1
2164 cd            aggi(k,2)=ghalf2
2165 cd            aggi(k,3)=ghalf3
2166 cd            aggi(k,4)=ghalf4
2167 C Derivatives in DC(i+1)
2168 cd            aggi1(k,1)=agg(k,1)
2169 cd            aggi1(k,2)=agg(k,2)
2170 cd            aggi1(k,3)=agg(k,3)
2171 cd            aggi1(k,4)=agg(k,4)
2172 C Derivatives in DC(j)
2173 cd            aggj(k,1)=ghalf1
2174 cd            aggj(k,2)=ghalf2
2175 cd            aggj(k,3)=ghalf3
2176 cd            aggj(k,4)=ghalf4
2177 C Derivatives in DC(j+1)
2178 cd            aggj1(k,1)=0.0d0
2179 cd            aggj1(k,2)=0.0d0
2180 cd            aggj1(k,3)=0.0d0
2181 cd            aggj1(k,4)=0.0d0
2182             if (j.eq.nres-1 .and. i.lt.j-2) then
2183               do l=1,4
2184                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2185 cd                aggj1(k,l)=agg(k,l)
2186               enddo
2187             endif
2188           enddo
2189           endif
2190 c          goto 11111
2191 C Check the loc-el terms by numerical integration
2192           acipa(1,1)=a22
2193           acipa(1,2)=a23
2194           acipa(2,1)=a32
2195           acipa(2,2)=a33
2196           a22=-a22
2197           a23=-a23
2198           do l=1,2
2199             do k=1,3
2200               agg(k,l)=-agg(k,l)
2201               aggi(k,l)=-aggi(k,l)
2202               aggi1(k,l)=-aggi1(k,l)
2203               aggj(k,l)=-aggj(k,l)
2204               aggj1(k,l)=-aggj1(k,l)
2205             enddo
2206           enddo
2207           if (j.lt.nres-1) then
2208             a22=-a22
2209             a32=-a32
2210             do l=1,3,2
2211               do k=1,3
2212                 agg(k,l)=-agg(k,l)
2213                 aggi(k,l)=-aggi(k,l)
2214                 aggi1(k,l)=-aggi1(k,l)
2215                 aggj(k,l)=-aggj(k,l)
2216                 aggj1(k,l)=-aggj1(k,l)
2217               enddo
2218             enddo
2219           else
2220             a22=-a22
2221             a23=-a23
2222             a32=-a32
2223             a33=-a33
2224             do l=1,4
2225               do k=1,3
2226                 agg(k,l)=-agg(k,l)
2227                 aggi(k,l)=-aggi(k,l)
2228                 aggi1(k,l)=-aggi1(k,l)
2229                 aggj(k,l)=-aggj(k,l)
2230                 aggj1(k,l)=-aggj1(k,l)
2231               enddo
2232             enddo
2233           endif
2234           ENDIF ! WCORR
2235 11111     continue
2236           IF (wel_loc.gt.0.0d0) THEN
2237 C Contribution to the local-electrostatic energy coming from the i-j pair
2238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2239      &     +a33*muij(4)
2240 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2241 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2242           eel_loc=eel_loc+eel_loc_ij
2243 C Partial derivatives in virtual-bond dihedral angles gamma
2244           if (calc_grad) then
2245           if (i.gt.1)
2246      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2247      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2248      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2249           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2250      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2251      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2252 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2253 cd          write(iout,*) 'agg  ',agg
2254 cd          write(iout,*) 'aggi ',aggi
2255 cd          write(iout,*) 'aggi1',aggi1
2256 cd          write(iout,*) 'aggj ',aggj
2257 cd          write(iout,*) 'aggj1',aggj1
2258
2259 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2260           do l=1,3
2261             ggg(l)=agg(l,1)*muij(1)+
2262      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2263           enddo
2264           do k=i+2,j2
2265             do l=1,3
2266               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2267             enddo
2268           enddo
2269 C Remaining derivatives of eello
2270           do l=1,3
2271             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2272      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2273             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2274      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2275             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2276      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2277             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2278      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2279           enddo
2280           endif
2281           ENDIF
2282           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2283 C Contributions from turns
2284             a_temp(1,1)=a22
2285             a_temp(1,2)=a23
2286             a_temp(2,1)=a32
2287             a_temp(2,2)=a33
2288             call eturn34(i,j,eello_turn3,eello_turn4)
2289           endif
2290 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2291           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2292 C
2293 C Calculate the contact function. The ith column of the array JCONT will
2294 C contain the numbers of atoms that make contacts with the atom I (of numbers
2295 C greater than I). The arrays FACONT and GACONT will contain the values of
2296 C the contact function and its derivative.
2297 c           r0ij=1.02D0*rpp(iteli,itelj)
2298 c           r0ij=1.11D0*rpp(iteli,itelj)
2299             r0ij=2.20D0*rpp(iteli,itelj)
2300 c           r0ij=1.55D0*rpp(iteli,itelj)
2301             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2302             if (fcont.gt.0.0D0) then
2303               num_conti=num_conti+1
2304               if (num_conti.gt.maxconts) then
2305                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2306      &                         ' will skip next contacts for this conf.'
2307               else
2308                 jcont_hb(num_conti,i)=j
2309                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2310      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2311 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2312 C  terms.
2313                 d_cont(num_conti,i)=rij
2314 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2315 C     --- Electrostatic-interaction matrix ---
2316                 a_chuj(1,1,num_conti,i)=a22
2317                 a_chuj(1,2,num_conti,i)=a23
2318                 a_chuj(2,1,num_conti,i)=a32
2319                 a_chuj(2,2,num_conti,i)=a33
2320 C     --- Gradient of rij
2321                 do kkk=1,3
2322                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2323                 enddo
2324 c             if (i.eq.1) then
2325 c                a_chuj(1,1,num_conti,i)=-0.61d0
2326 c                a_chuj(1,2,num_conti,i)= 0.4d0
2327 c                a_chuj(2,1,num_conti,i)= 0.65d0
2328 c                a_chuj(2,2,num_conti,i)= 0.50d0
2329 c             else if (i.eq.2) then
2330 c                a_chuj(1,1,num_conti,i)= 0.0d0
2331 c                a_chuj(1,2,num_conti,i)= 0.0d0
2332 c                a_chuj(2,1,num_conti,i)= 0.0d0
2333 c                a_chuj(2,2,num_conti,i)= 0.0d0
2334 c             endif
2335 C     --- and its gradients
2336 cd                write (iout,*) 'i',i,' j',j
2337 cd                do kkk=1,3
2338 cd                write (iout,*) 'iii 1 kkk',kkk
2339 cd                write (iout,*) agg(kkk,:)
2340 cd                enddo
2341 cd                do kkk=1,3
2342 cd                write (iout,*) 'iii 2 kkk',kkk
2343 cd                write (iout,*) aggi(kkk,:)
2344 cd                enddo
2345 cd                do kkk=1,3
2346 cd                write (iout,*) 'iii 3 kkk',kkk
2347 cd                write (iout,*) aggi1(kkk,:)
2348 cd                enddo
2349 cd                do kkk=1,3
2350 cd                write (iout,*) 'iii 4 kkk',kkk
2351 cd                write (iout,*) aggj(kkk,:)
2352 cd                enddo
2353 cd                do kkk=1,3
2354 cd                write (iout,*) 'iii 5 kkk',kkk
2355 cd                write (iout,*) aggj1(kkk,:)
2356 cd                enddo
2357                 kkll=0
2358                 do k=1,2
2359                   do l=1,2
2360                     kkll=kkll+1
2361                     do m=1,3
2362                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2363                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2364                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2365                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2366                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2367 c                      do mm=1,5
2368 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2369 c                      enddo
2370                     enddo
2371                   enddo
2372                 enddo
2373                 ENDIF
2374                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2375 C Calculate contact energies
2376                 cosa4=4.0D0*cosa
2377                 wij=cosa-3.0D0*cosb*cosg
2378                 cosbg1=cosb+cosg
2379                 cosbg2=cosb-cosg
2380 c               fac3=dsqrt(-ael6i)/r0ij**3
2381                 fac3=dsqrt(-ael6i)*r3ij
2382                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2383                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2384 c               ees0mij=0.0D0
2385                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2386                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2387 C Diagnostics. Comment out or remove after debugging!
2388 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2389 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2390 c               ees0m(num_conti,i)=0.0D0
2391 C End diagnostics.
2392 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2393 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2394                 facont_hb(num_conti,i)=fcont
2395                 if (calc_grad) then
2396 C Angular derivatives of the contact function
2397                 ees0pij1=fac3/ees0pij
2398                 ees0mij1=fac3/ees0mij
2399                 fac3p=-3.0D0*fac3*rrmij
2400                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2401                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2402 c               ees0mij1=0.0D0
2403                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2404                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2405                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2406                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2407                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2408                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2409                 ecosap=ecosa1+ecosa2
2410                 ecosbp=ecosb1+ecosb2
2411                 ecosgp=ecosg1+ecosg2
2412                 ecosam=ecosa1-ecosa2
2413                 ecosbm=ecosb1-ecosb2
2414                 ecosgm=ecosg1-ecosg2
2415 C Diagnostics
2416 c               ecosap=ecosa1
2417 c               ecosbp=ecosb1
2418 c               ecosgp=ecosg1
2419 c               ecosam=0.0D0
2420 c               ecosbm=0.0D0
2421 c               ecosgm=0.0D0
2422 C End diagnostics
2423                 fprimcont=fprimcont/rij
2424 cd              facont_hb(num_conti,i)=1.0D0
2425 C Following line is for diagnostics.
2426 cd              fprimcont=0.0D0
2427                 do k=1,3
2428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2430                 enddo
2431                 do k=1,3
2432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2434                 enddo
2435                 gggp(1)=gggp(1)+ees0pijp*xj
2436                 gggp(2)=gggp(2)+ees0pijp*yj
2437                 gggp(3)=gggp(3)+ees0pijp*zj
2438                 gggm(1)=gggm(1)+ees0mijp*xj
2439                 gggm(2)=gggm(2)+ees0mijp*yj
2440                 gggm(3)=gggm(3)+ees0mijp*zj
2441 C Derivatives due to the contact function
2442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2445                 do k=1,3
2446                   ghalfp=0.5D0*gggp(k)
2447                   ghalfm=0.5D0*gggm(k)
2448                   gacontp_hb1(k,num_conti,i)=ghalfp
2449      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2450      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2451                   gacontp_hb2(k,num_conti,i)=ghalfp
2452      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2453      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2454                   gacontp_hb3(k,num_conti,i)=gggp(k)
2455                   gacontm_hb1(k,num_conti,i)=ghalfm
2456      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2457      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2458                   gacontm_hb2(k,num_conti,i)=ghalfm
2459      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2460      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2461                   gacontm_hb3(k,num_conti,i)=gggm(k)
2462                 enddo
2463                 endif
2464 C Diagnostics. Comment out or remove after debugging!
2465 cdiag           do k=1,3
2466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2472 cdiag           enddo
2473               ENDIF ! wcorr
2474               endif  ! num_conti.le.maxconts
2475             endif  ! fcont.gt.0
2476           endif    ! j.gt.i+1
2477  1216     continue
2478         enddo ! j
2479         num_cont_hb(i)=num_conti
2480  1215   continue
2481       enddo   ! i
2482 cd      do i=1,nres
2483 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2484 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2485 cd      enddo
2486 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2487 ccc      eel_loc=eel_loc+eello_turn3
2488       return
2489       end
2490 C-----------------------------------------------------------------------------
2491       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2492 C Third- and fourth-order contributions from turns
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'sizesclu.dat'
2496       include 'COMMON.IOUNITS'
2497       include 'COMMON.GEO'
2498       include 'COMMON.VAR'
2499       include 'COMMON.LOCAL'
2500       include 'COMMON.CHAIN'
2501       include 'COMMON.DERIV'
2502       include 'COMMON.INTERACT'
2503       include 'COMMON.CONTACTS'
2504       include 'COMMON.TORSION'
2505       include 'COMMON.VECTORS'
2506       include 'COMMON.FFIELD'
2507       dimension ggg(3)
2508       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2509      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2510      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2511       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2512      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2514       if (j.eq.i+2) then
2515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2516 C
2517 C               Third-order contributions
2518 C
2519 C                 (i+2)o----(i+3)
2520 C                      | |
2521 C                      | |
2522 C                 (i+1)o----i
2523 C
2524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2525 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2526         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2527         call transpose2(auxmat(1,1),auxmat1(1,1))
2528         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2529         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2530 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2531 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2532 cd     &    ' eello_turn3_num',4*eello_turn3_num
2533         if (calc_grad) then
2534 C Derivatives in gamma(i)
2535         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2536         call transpose2(auxmat2(1,1),pizda(1,1))
2537         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2538         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2539 C Derivatives in gamma(i+1)
2540         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2541         call transpose2(auxmat2(1,1),pizda(1,1))
2542         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2543         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2544      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2545 C Cartesian derivatives
2546         do l=1,3
2547           a_temp(1,1)=aggi(l,1)
2548           a_temp(1,2)=aggi(l,2)
2549           a_temp(2,1)=aggi(l,3)
2550           a_temp(2,2)=aggi(l,4)
2551           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2552           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2553      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2554           a_temp(1,1)=aggi1(l,1)
2555           a_temp(1,2)=aggi1(l,2)
2556           a_temp(2,1)=aggi1(l,3)
2557           a_temp(2,2)=aggi1(l,4)
2558           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2559           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2560      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2561           a_temp(1,1)=aggj(l,1)
2562           a_temp(1,2)=aggj(l,2)
2563           a_temp(2,1)=aggj(l,3)
2564           a_temp(2,2)=aggj(l,4)
2565           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2566           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2567      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2568           a_temp(1,1)=aggj1(l,1)
2569           a_temp(1,2)=aggj1(l,2)
2570           a_temp(2,1)=aggj1(l,3)
2571           a_temp(2,2)=aggj1(l,4)
2572           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2573           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2574      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2575         enddo
2576         endif
2577       else if (j.eq.i+3) then
2578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2579 C
2580 C               Fourth-order contributions
2581 C
2582 C                 (i+3)o----(i+4)
2583 C                     /  |
2584 C               (i+2)o   |
2585 C                     \  |
2586 C                 (i+1)o----i
2587 C
2588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2589 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2590         iti1=itortyp(itype(i+1))
2591         iti2=itortyp(itype(i+2))
2592         iti3=itortyp(itype(i+3))
2593         call transpose2(EUg(1,1,i+1),e1t(1,1))
2594         call transpose2(Eug(1,1,i+2),e2t(1,1))
2595         call transpose2(Eug(1,1,i+3),e3t(1,1))
2596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2597         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2598         s1=scalar2(b1(1,iti2),auxvec(1))
2599         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2601         s2=scalar2(b1(1,iti1),auxvec(1))
2602         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2603         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2604         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2605         eello_turn4=eello_turn4-(s1+s2+s3)
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2607 cd     &    ' eello_turn4_num',8*eello_turn4_num
2608 C Derivatives in gamma(i)
2609         if (calc_grad) then
2610         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2611         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2613         s1=scalar2(b1(1,iti2),auxvec(1))
2614         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2615         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2617 C Derivatives in gamma(i+1)
2618         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2619         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2620         s2=scalar2(b1(1,iti1),auxvec(1))
2621         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2622         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2623         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2624         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2625 C Derivatives in gamma(i+2)
2626         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2627         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2628         s1=scalar2(b1(1,iti2),auxvec(1))
2629         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2631         s2=scalar2(b1(1,iti1),auxvec(1))
2632         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2633         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2634         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2636 C Cartesian derivatives
2637 C Derivatives of this turn contributions in DC(i+2)
2638         if (j.lt.nres-1) then
2639           do l=1,3
2640             a_temp(1,1)=agg(l,1)
2641             a_temp(1,2)=agg(l,2)
2642             a_temp(2,1)=agg(l,3)
2643             a_temp(2,2)=agg(l,4)
2644             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2645             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2646             s1=scalar2(b1(1,iti2),auxvec(1))
2647             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2648             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2649             s2=scalar2(b1(1,iti1),auxvec(1))
2650             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2651             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2652             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653             ggg(l)=-(s1+s2+s3)
2654             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2655           enddo
2656         endif
2657 C Remaining derivatives of this turn contribution
2658         do l=1,3
2659           a_temp(1,1)=aggi(l,1)
2660           a_temp(1,2)=aggi(l,2)
2661           a_temp(2,1)=aggi(l,3)
2662           a_temp(2,2)=aggi(l,4)
2663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2665           s1=scalar2(b1(1,iti2),auxvec(1))
2666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2668           s2=scalar2(b1(1,iti1),auxvec(1))
2669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2672           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2673           a_temp(1,1)=aggi1(l,1)
2674           a_temp(1,2)=aggi1(l,2)
2675           a_temp(2,1)=aggi1(l,3)
2676           a_temp(2,2)=aggi1(l,4)
2677           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2678           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2679           s1=scalar2(b1(1,iti2),auxvec(1))
2680           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2681           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2682           s2=scalar2(b1(1,iti1),auxvec(1))
2683           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2684           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2685           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2686           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2687           a_temp(1,1)=aggj(l,1)
2688           a_temp(1,2)=aggj(l,2)
2689           a_temp(2,1)=aggj(l,3)
2690           a_temp(2,2)=aggj(l,4)
2691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2693           s1=scalar2(b1(1,iti2),auxvec(1))
2694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2696           s2=scalar2(b1(1,iti1),auxvec(1))
2697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2701           a_temp(1,1)=aggj1(l,1)
2702           a_temp(1,2)=aggj1(l,2)
2703           a_temp(2,1)=aggj1(l,3)
2704           a_temp(2,2)=aggj1(l,4)
2705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2707           s1=scalar2(b1(1,iti2),auxvec(1))
2708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2710           s2=scalar2(b1(1,iti1),auxvec(1))
2711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2714           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2715         enddo
2716         endif
2717       endif
2718       return
2719       end
2720 C-----------------------------------------------------------------------------
2721       subroutine vecpr(u,v,w)
2722       implicit real*8(a-h,o-z)
2723       dimension u(3),v(3),w(3)
2724       w(1)=u(2)*v(3)-u(3)*v(2)
2725       w(2)=-u(1)*v(3)+u(3)*v(1)
2726       w(3)=u(1)*v(2)-u(2)*v(1)
2727       return
2728       end
2729 C-----------------------------------------------------------------------------
2730       subroutine unormderiv(u,ugrad,unorm,ungrad)
2731 C This subroutine computes the derivatives of a normalized vector u, given
2732 C the derivatives computed without normalization conditions, ugrad. Returns
2733 C ungrad.
2734       implicit none
2735       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2736       double precision vec(3)
2737       double precision scalar
2738       integer i,j
2739 c      write (2,*) 'ugrad',ugrad
2740 c      write (2,*) 'u',u
2741       do i=1,3
2742         vec(i)=scalar(ugrad(1,i),u(1))
2743       enddo
2744 c      write (2,*) 'vec',vec
2745       do i=1,3
2746         do j=1,3
2747           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2748         enddo
2749       enddo
2750 c      write (2,*) 'ungrad',ungrad
2751       return
2752       end
2753 C-----------------------------------------------------------------------------
2754       subroutine escp(evdw2,evdw2_14)
2755 C
2756 C This subroutine calculates the excluded-volume interaction energy between
2757 C peptide-group centers and side chains and its gradient in virtual-bond and
2758 C side-chain vectors.
2759 C
2760       implicit real*8 (a-h,o-z)
2761       include 'DIMENSIONS'
2762       include 'sizesclu.dat'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.FFIELD'
2770       include 'COMMON.IOUNITS'
2771       dimension ggg(3)
2772       evdw2=0.0D0
2773       evdw2_14=0.0d0
2774 cd    print '(a)','Enter ESCP'
2775 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2776 c     &  ' scal14',scal14
2777       do i=iatscp_s,iatscp_e
2778         iteli=itel(i)
2779 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2780 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2781         if (iteli.eq.0) goto 1225
2782         xi=0.5D0*(c(1,i)+c(1,i+1))
2783         yi=0.5D0*(c(2,i)+c(2,i+1))
2784         zi=0.5D0*(c(3,i)+c(3,i+1))
2785
2786         do iint=1,nscp_gr(i)
2787
2788         do j=iscpstart(i,iint),iscpend(i,iint)
2789           itypj=itype(j)
2790 C Uncomment following three lines for SC-p interactions
2791 c         xj=c(1,nres+j)-xi
2792 c         yj=c(2,nres+j)-yi
2793 c         zj=c(3,nres+j)-zi
2794 C Uncomment following three lines for Ca-p interactions
2795           xj=c(1,j)-xi
2796           yj=c(2,j)-yi
2797           zj=c(3,j)-zi
2798           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2799           fac=rrij**expon2
2800           e1=fac*fac*aad(itypj,iteli)
2801           e2=fac*bad(itypj,iteli)
2802           if (iabs(j-i) .le. 2) then
2803             e1=scal14*e1
2804             e2=scal14*e2
2805             evdw2_14=evdw2_14+e1+e2
2806           endif
2807           evdwij=e1+e2
2808 c          write (iout,*) i,j,evdwij
2809           evdw2=evdw2+evdwij
2810           if (calc_grad) then
2811 C
2812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2813 C
2814           fac=-(evdwij+e1)*rrij
2815           ggg(1)=xj*fac
2816           ggg(2)=yj*fac
2817           ggg(3)=zj*fac
2818           if (j.lt.i) then
2819 cd          write (iout,*) 'j<i'
2820 C Uncomment following three lines for SC-p interactions
2821 c           do k=1,3
2822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2823 c           enddo
2824           else
2825 cd          write (iout,*) 'j>i'
2826             do k=1,3
2827               ggg(k)=-ggg(k)
2828 C Uncomment following line for SC-p interactions
2829 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2830             enddo
2831           endif
2832           do k=1,3
2833             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2834           enddo
2835           kstart=min0(i+1,j)
2836           kend=max0(i-1,j-1)
2837 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2838 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2839           do k=kstart,kend
2840             do l=1,3
2841               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2842             enddo
2843           enddo
2844           endif
2845         enddo
2846         enddo ! iint
2847  1225   continue
2848       enddo ! i
2849       do i=1,nct
2850         do j=1,3
2851           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2852           gradx_scp(j,i)=expon*gradx_scp(j,i)
2853         enddo
2854       enddo
2855 C******************************************************************************
2856 C
2857 C                              N O T E !!!
2858 C
2859 C To save time the factor EXPON has been extracted from ALL components
2860 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2861 C use!
2862 C
2863 C******************************************************************************
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine edis(ehpb)
2868 C
2869 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2870 C
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873       include 'COMMON.SBRIDGE'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.VAR'
2877       include 'COMMON.INTERACT'
2878       include 'COMMON.IOUNITS'
2879       dimension ggg(3)
2880       ehpb=0.0D0
2881 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2882 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2883       if (link_end.eq.0) return
2884       do i=link_start,link_end
2885 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2886 C CA-CA distance used in regularization of structure.
2887         ii=ihpb(i)
2888         jj=jhpb(i)
2889 C iii and jjj point to the residues for which the distance is assigned.
2890         if (ii.gt.nres) then
2891           iii=ii-nres
2892           jjj=jj-nres
2893         else
2894           iii=ii
2895           jjj=jj
2896         endif
2897 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2898 c     &    dhpb(i),dhpb1(i),forcon(i)
2899 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2900 C    distance and angle dependent SS bond potential.
2901         if (.not.dyn_ss .and. i.le.nss) then
2902 C 15/02/13 CC dynamic SSbond - additional check
2903         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2904           call ssbond_ene(iii,jjj,eij)
2905           ehpb=ehpb+2*eij
2906 cd          write (iout,*) "eij",eij
2907         endif
2908         else if (ii.gt.nres .and. jj.gt.nres) then
2909 c Restraints from contact prediction
2910           dd=dist(ii,jj)
2911           if (dhpb1(i).gt.0.0d0) then
2912             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2913             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2914 c            write (iout,*) "beta nmr",
2915 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2916           else
2917             dd=dist(ii,jj)
2918             rdis=dd-dhpb(i)
2919 C Get the force constant corresponding to this distance.
2920             waga=forcon(i)
2921 C Calculate the contribution to energy.
2922             ehpb=ehpb+waga*rdis*rdis
2923 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2924 C
2925 C Evaluate gradient.
2926 C
2927             fac=waga*rdis/dd
2928           endif
2929           do j=1,3
2930             ggg(j)=fac*(c(j,jj)-c(j,ii))
2931           enddo
2932           do j=1,3
2933             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2934             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2935           enddo
2936           do k=1,3
2937             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2938             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2939           enddo
2940         else
2941 C Calculate the distance between the two points and its difference from the
2942 C target distance.
2943           dd=dist(ii,jj)
2944           if (dhpb1(i).gt.0.0d0) then
2945             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2946             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2947 c            write (iout,*) "alph nmr",
2948 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2949           else
2950             rdis=dd-dhpb(i)
2951 C Get the force constant corresponding to this distance.
2952             waga=forcon(i)
2953 C Calculate the contribution to energy.
2954             ehpb=ehpb+waga*rdis*rdis
2955 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2956 C
2957 C Evaluate gradient.
2958 C
2959             fac=waga*rdis/dd
2960           endif
2961 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2962 cd   &   ' waga=',waga,' fac=',fac
2963             do j=1,3
2964               ggg(j)=fac*(c(j,jj)-c(j,ii))
2965             enddo
2966 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2967 C If this is a SC-SC distance, we need to calculate the contributions to the
2968 C Cartesian gradient in the SC vectors (ghpbx).
2969           if (iii.lt.ii) then
2970           do j=1,3
2971             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2972             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2973           enddo
2974           endif
2975           do k=1,3
2976             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2977             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2978           enddo
2979         endif
2980       enddo
2981       ehpb=0.5D0*ehpb
2982       return
2983       end
2984 C--------------------------------------------------------------------------
2985       subroutine ssbond_ene(i,j,eij)
2986 C
2987 C Calculate the distance and angle dependent SS-bond potential energy
2988 C using a free-energy function derived based on RHF/6-31G** ab initio
2989 C calculations of diethyl disulfide.
2990 C
2991 C A. Liwo and U. Kozlowska, 11/24/03
2992 C
2993       implicit real*8 (a-h,o-z)
2994       include 'DIMENSIONS'
2995       include 'sizesclu.dat'
2996       include 'COMMON.SBRIDGE'
2997       include 'COMMON.CHAIN'
2998       include 'COMMON.DERIV'
2999       include 'COMMON.LOCAL'
3000       include 'COMMON.INTERACT'
3001       include 'COMMON.VAR'
3002       include 'COMMON.IOUNITS'
3003       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3004       itypi=itype(i)
3005       xi=c(1,nres+i)
3006       yi=c(2,nres+i)
3007       zi=c(3,nres+i)
3008       dxi=dc_norm(1,nres+i)
3009       dyi=dc_norm(2,nres+i)
3010       dzi=dc_norm(3,nres+i)
3011       dsci_inv=dsc_inv(itypi)
3012       itypj=itype(j)
3013       dscj_inv=dsc_inv(itypj)
3014       xj=c(1,nres+j)-xi
3015       yj=c(2,nres+j)-yi
3016       zj=c(3,nres+j)-zi
3017       dxj=dc_norm(1,nres+j)
3018       dyj=dc_norm(2,nres+j)
3019       dzj=dc_norm(3,nres+j)
3020       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3021       rij=dsqrt(rrij)
3022       erij(1)=xj*rij
3023       erij(2)=yj*rij
3024       erij(3)=zj*rij
3025       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3026       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3027       om12=dxi*dxj+dyi*dyj+dzi*dzj
3028       do k=1,3
3029         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3030         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3031       enddo
3032       rij=1.0d0/rij
3033       deltad=rij-d0cm
3034       deltat1=1.0d0-om1
3035       deltat2=1.0d0+om2
3036       deltat12=om2-om1+2.0d0
3037       cosphi=om12-om1*om2
3038       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3039      &  +akct*deltad*deltat12+ebr
3040      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3041 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3042 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3043 c     &  " deltat12",deltat12," eij",eij
3044       ed=2*akcm*deltad+akct*deltat12
3045       pom1=akct*deltad
3046       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3047       eom1=-2*akth*deltat1-pom1-om2*pom2
3048       eom2= 2*akth*deltat2+pom1-om1*pom2
3049       eom12=pom2
3050       do k=1,3
3051         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3052       enddo
3053       do k=1,3
3054         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3055      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3056         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3057      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3058       enddo
3059 C
3060 C Calculate the components of the gradient in DC and X
3061 C
3062       do k=i,j-1
3063         do l=1,3
3064           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3065         enddo
3066       enddo
3067       return
3068       end
3069
3070 C--------------------------------------------------------------------------
3071
3072
3073 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3074       subroutine e_modeller(ehomology_constr)
3075       implicit real*8 (a-h,o-z)
3076
3077       include 'DIMENSIONS'
3078
3079       integer nnn, i, j, k, ki, irec, l
3080       integer katy, odleglosci, test7
3081       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3082       real*8 distance(max_template),distancek(max_template),
3083      &    min_odl,godl(max_template),dih_diff(max_template)
3084
3085       include 'COMMON.SBRIDGE'
3086       include 'COMMON.CHAIN'
3087       include 'COMMON.GEO'
3088       include 'COMMON.DERIV'
3089       include 'COMMON.LOCAL'
3090       include 'COMMON.INTERACT'
3091       include 'COMMON.VAR'
3092       include 'COMMON.IOUNITS'
3093       include 'COMMON.CONTROL'
3094
3095
3096       do i=1,19
3097         distancek(i)=9999999.9
3098       enddo
3099
3100
3101       odleg=0.0d0
3102       write (iout,*) "waga_dist",waga_dist
3103 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3104 c function)
3105 C AL 5/2/14 - Introduce list of restraints
3106       do ii = link_start_homo,link_end_homo
3107          i = ires_homo(ii)
3108          j = jres_homo(ii)
3109          dij=dist(i,j)
3110          do k=1,constr_homology
3111            distance(k)=odl(k,ii)-dij
3112            distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3113          enddo
3114
3115          min_odl=minval(distancek)
3116 #ifdef DEBUG
3117          write (iout,*) "ij dij",i,j,dij
3118          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3119          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3120          write (iout,* )"min_odl",min_odl
3121 #endif
3122          odleg2=0.0d0
3123          do k=1,constr_homology
3124 c Nie wiem po co to liczycie jeszcze raz!
3125 c            odleg3=-waga_dist*((distance(i,j,k)**2)/
3126 c     &              (2*(sigma_odl(i,j,k))**2))
3127             godl(k)=dexp(-distancek(k)+min_odl)
3128             odleg2=odleg2+godl(k)
3129
3130 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3131 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3132 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3133 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3134
3135          enddo
3136 #ifdef DEBUG
3137          write (iout,*) "godl",(godl(k),k=1,constr_homology)
3138          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
3139 #endif
3140          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3141 c Gradient
3142          sum_godl=odleg2
3143          sum_sgodl=0.0
3144          do k=1,constr_homology
3145 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3146 c     &           *waga_dist)+min_odl
3147            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3148            sum_sgodl=sum_sgodl+sgodl
3149
3150 c            sgodl2=sgodl2+sgodl
3151 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3152 c      write(iout,*) "constr_homology=",constr_homology
3153 c      write(iout,*) i, j, k, "TEST K"
3154          enddo
3155
3156          grad_odl3=sum_sgodl/(sum_godl*dij)
3157
3158
3159 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3160 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3161 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3162
3163 ccc      write(iout,*) godl, sgodl, grad_odl3
3164
3165 c          grad_odl=grad_odl+grad_odl3
3166
3167          do jik=1,3
3168             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3169 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3170 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3171 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3172             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3173             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3174 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3175 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3176
3177          enddo
3178 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3179 ccc     & dLOG(odleg2),"-odleg=", -odleg
3180
3181       enddo ! ii
3182 c Pseudo-energy and gradient from dihedral-angle restraints from
3183 c homology templates
3184 c      write (iout,*) "End of distance loop"
3185 c      call flush(iout)
3186       kat=0.0d0
3187 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3188       do i=idihconstr_start_homo,idihconstr_end_homo
3189         kat2=0.0d0
3190 c        betai=beta(i,i+1,i+2,i+3)
3191         betai = phi(i+3)
3192         do k=1,constr_homology
3193           dih_diff(k)=pinorm(dih(k,i)-betai)
3194 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3195 c     &                                   -(6.28318-dih_diff(i,k))
3196 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3197 c     &                                   6.28318+dih_diff(i,k)
3198
3199           kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3200           gdih(k)=dexp(kat3)
3201           kat2=kat2+gdih(k)
3202 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3203 c          write(*,*)""
3204         enddo
3205 #ifdef DEBUG
3206         write (iout,*) "i",i," betai",betai," kat2",kat2
3207         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3208 #endif
3209         if (kat2.le.1.0d-14) cycle
3210         kat=kat-dLOG(kat2/constr_homology)
3211
3212 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3213 ccc     & dLOG(kat2), "-kat=", -kat
3214
3215 c ----------------------------------------------------------------------
3216 c Gradient
3217 c ----------------------------------------------------------------------
3218
3219         sum_gdih=kat2
3220         sum_sgdih=0.0
3221         do k=1,constr_homology
3222           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3223           sum_sgdih=sum_sgdih+sgdih
3224         enddo
3225         grad_dih3=sum_sgdih/sum_gdih
3226
3227 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3228 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3229 ccc     & gloc(nphi+i-3,icg)
3230         gloc(i,icg)=gloc(i,icg)+grad_dih3
3231 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3232 ccc     & gloc(nphi+i-3,icg)
3233
3234       enddo
3235
3236
3237 c Total energy from homology restraints
3238 #ifdef DEBUG
3239       write (iout,*) "odleg",odleg," kat",kat
3240 #endif
3241       ehomology_constr=odleg+kat
3242       return
3243
3244   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3245   747 format(a12,i4,i4,i4,f8.3,f8.3)
3246   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3247   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3248   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3249      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3250       end
3251
3252
3253
3254
3255 C--------------------------------------------------------------------------
3256       subroutine ebond(estr)
3257 c
3258 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3259 c
3260       implicit real*8 (a-h,o-z)
3261       include 'DIMENSIONS'
3262       include 'COMMON.LOCAL'
3263       include 'COMMON.GEO'
3264       include 'COMMON.INTERACT'
3265       include 'COMMON.DERIV'
3266       include 'COMMON.VAR'
3267       include 'COMMON.CHAIN'
3268       include 'COMMON.IOUNITS'
3269       include 'COMMON.NAMES'
3270       include 'COMMON.FFIELD'
3271       include 'COMMON.CONTROL'
3272       double precision u(3),ud(3)
3273       estr=0.0d0
3274       do i=nnt+1,nct
3275         diff = vbld(i)-vbldp0
3276 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3277         estr=estr+diff*diff
3278         do j=1,3
3279           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3280         enddo
3281       enddo
3282       estr=0.5d0*AKP*estr
3283 c
3284 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3285 c
3286       do i=nnt,nct
3287         iti=itype(i)
3288         if (iti.ne.10) then
3289           nbi=nbondterm(iti)
3290           if (nbi.eq.1) then
3291             diff=vbld(i+nres)-vbldsc0(1,iti)
3292 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3293 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3294             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3295             do j=1,3
3296               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3297             enddo
3298           else
3299             do j=1,nbi
3300               diff=vbld(i+nres)-vbldsc0(j,iti)
3301               ud(j)=aksc(j,iti)*diff
3302               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3303             enddo
3304             uprod=u(1)
3305             do j=2,nbi
3306               uprod=uprod*u(j)
3307             enddo
3308             usum=0.0d0
3309             usumsqder=0.0d0
3310             do j=1,nbi
3311               uprod1=1.0d0
3312               uprod2=1.0d0
3313               do k=1,nbi
3314                 if (k.ne.j) then
3315                   uprod1=uprod1*u(k)
3316                   uprod2=uprod2*u(k)*u(k)
3317                 endif
3318               enddo
3319               usum=usum+uprod1
3320               usumsqder=usumsqder+ud(j)*uprod2
3321             enddo
3322 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3323 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3324             estr=estr+uprod/usum
3325             do j=1,3
3326              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3327             enddo
3328           endif
3329         endif
3330       enddo
3331       return
3332       end
3333 #ifdef CRYST_THETA
3334 C--------------------------------------------------------------------------
3335       subroutine ebend(etheta)
3336 C
3337 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3338 C angles gamma and its derivatives in consecutive thetas and gammas.
3339 C
3340       implicit real*8 (a-h,o-z)
3341       include 'DIMENSIONS'
3342       include 'sizesclu.dat'
3343       include 'COMMON.LOCAL'
3344       include 'COMMON.GEO'
3345       include 'COMMON.INTERACT'
3346       include 'COMMON.DERIV'
3347       include 'COMMON.VAR'
3348       include 'COMMON.CHAIN'
3349       include 'COMMON.IOUNITS'
3350       include 'COMMON.NAMES'
3351       include 'COMMON.FFIELD'
3352       common /calcthet/ term1,term2,termm,diffak,ratak,
3353      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3354      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3355       double precision y(2),z(2)
3356       delta=0.02d0*pi
3357       time11=dexp(-2*time)
3358       time12=1.0d0
3359       etheta=0.0D0
3360 c      write (iout,*) "nres",nres
3361 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3362 c      write (iout,*) ithet_start,ithet_end
3363       do i=ithet_start,ithet_end
3364 C Zero the energy function and its derivative at 0 or pi.
3365         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3366         it=itype(i-1)
3367 c        if (i.gt.ithet_start .and.
3368 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3369 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3370 c          phii=phi(i)
3371 c          y(1)=dcos(phii)
3372 c          y(2)=dsin(phii)
3373 c        else
3374 c          y(1)=0.0D0
3375 c          y(2)=0.0D0
3376 c        endif
3377 c        if (i.lt.nres .and. itel(i).ne.0) then
3378 c          phii1=phi(i+1)
3379 c          z(1)=dcos(phii1)
3380 c          z(2)=dsin(phii1)
3381 c        else
3382 c          z(1)=0.0D0
3383 c          z(2)=0.0D0
3384 c        endif
3385         if (i.gt.3) then
3386 #ifdef OSF
3387           phii=phi(i)
3388           icrc=0
3389           call proc_proc(phii,icrc)
3390           if (icrc.eq.1) phii=150.0
3391 #else
3392           phii=phi(i)
3393 #endif
3394           y(1)=dcos(phii)
3395           y(2)=dsin(phii)
3396         else
3397           y(1)=0.0D0
3398           y(2)=0.0D0
3399         endif
3400         if (i.lt.nres) then
3401 #ifdef OSF
3402           phii1=phi(i+1)
3403           icrc=0
3404           call proc_proc(phii1,icrc)
3405           if (icrc.eq.1) phii1=150.0
3406           phii1=pinorm(phii1)
3407           z(1)=cos(phii1)
3408 #else
3409           phii1=phi(i+1)
3410           z(1)=dcos(phii1)
3411 #endif
3412           z(2)=dsin(phii1)
3413         else
3414           z(1)=0.0D0
3415           z(2)=0.0D0
3416         endif
3417 C Calculate the "mean" value of theta from the part of the distribution
3418 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3419 C In following comments this theta will be referred to as t_c.
3420         thet_pred_mean=0.0d0
3421         do k=1,2
3422           athetk=athet(k,it)
3423           bthetk=bthet(k,it)
3424           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3425         enddo
3426 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3427         dthett=thet_pred_mean*ssd
3428         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3429 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3430 C Derivatives of the "mean" values in gamma1 and gamma2.
3431         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3432         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3433         if (theta(i).gt.pi-delta) then
3434           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3435      &         E_tc0)
3436           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3437           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3438           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3439      &        E_theta)
3440           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3441      &        E_tc)
3442         else if (theta(i).lt.delta) then
3443           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3444           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3445           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3446      &        E_theta)
3447           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3448           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3449      &        E_tc)
3450         else
3451           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3452      &        E_theta,E_tc)
3453         endif
3454         etheta=etheta+ethetai
3455 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3456 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3457         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3458         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3459         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3460  1215   continue
3461       enddo
3462 C Ufff.... We've done all this!!!
3463       return
3464       end
3465 C---------------------------------------------------------------------------
3466       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3467      &     E_tc)
3468       implicit real*8 (a-h,o-z)
3469       include 'DIMENSIONS'
3470       include 'COMMON.LOCAL'
3471       include 'COMMON.IOUNITS'
3472       common /calcthet/ term1,term2,termm,diffak,ratak,
3473      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3474      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3475 C Calculate the contributions to both Gaussian lobes.
3476 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3477 C The "polynomial part" of the "standard deviation" of this part of
3478 C the distribution.
3479         sig=polthet(3,it)
3480         do j=2,0,-1
3481           sig=sig*thet_pred_mean+polthet(j,it)
3482         enddo
3483 C Derivative of the "interior part" of the "standard deviation of the"
3484 C gamma-dependent Gaussian lobe in t_c.
3485         sigtc=3*polthet(3,it)
3486         do j=2,1,-1
3487           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3488         enddo
3489         sigtc=sig*sigtc
3490 C Set the parameters of both Gaussian lobes of the distribution.
3491 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3492         fac=sig*sig+sigc0(it)
3493         sigcsq=fac+fac
3494         sigc=1.0D0/sigcsq
3495 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3496         sigsqtc=-4.0D0*sigcsq*sigtc
3497 c       print *,i,sig,sigtc,sigsqtc
3498 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3499         sigtc=-sigtc/(fac*fac)
3500 C Following variable is sigma(t_c)**(-2)
3501         sigcsq=sigcsq*sigcsq
3502         sig0i=sig0(it)
3503         sig0inv=1.0D0/sig0i**2
3504         delthec=thetai-thet_pred_mean
3505         delthe0=thetai-theta0i
3506         term1=-0.5D0*sigcsq*delthec*delthec
3507         term2=-0.5D0*sig0inv*delthe0*delthe0
3508 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3509 C NaNs in taking the logarithm. We extract the largest exponent which is added
3510 C to the energy (this being the log of the distribution) at the end of energy
3511 C term evaluation for this virtual-bond angle.
3512         if (term1.gt.term2) then
3513           termm=term1
3514           term2=dexp(term2-termm)
3515           term1=1.0d0
3516         else
3517           termm=term2
3518           term1=dexp(term1-termm)
3519           term2=1.0d0
3520         endif
3521 C The ratio between the gamma-independent and gamma-dependent lobes of
3522 C the distribution is a Gaussian function of thet_pred_mean too.
3523         diffak=gthet(2,it)-thet_pred_mean
3524         ratak=diffak/gthet(3,it)**2
3525         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3526 C Let's differentiate it in thet_pred_mean NOW.
3527         aktc=ak*ratak
3528 C Now put together the distribution terms to make complete distribution.
3529         termexp=term1+ak*term2
3530         termpre=sigc+ak*sig0i
3531 C Contribution of the bending energy from this theta is just the -log of
3532 C the sum of the contributions from the two lobes and the pre-exponential
3533 C factor. Simple enough, isn't it?
3534         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3535 C NOW the derivatives!!!
3536 C 6/6/97 Take into account the deformation.
3537         E_theta=(delthec*sigcsq*term1
3538      &       +ak*delthe0*sig0inv*term2)/termexp
3539         E_tc=((sigtc+aktc*sig0i)/termpre
3540      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3541      &       aktc*term2)/termexp)
3542       return
3543       end
3544 c-----------------------------------------------------------------------------
3545       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3546       implicit real*8 (a-h,o-z)
3547       include 'DIMENSIONS'
3548       include 'COMMON.LOCAL'
3549       include 'COMMON.IOUNITS'
3550       common /calcthet/ term1,term2,termm,diffak,ratak,
3551      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3552      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3553       delthec=thetai-thet_pred_mean
3554       delthe0=thetai-theta0i
3555 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3556       t3 = thetai-thet_pred_mean
3557       t6 = t3**2
3558       t9 = term1
3559       t12 = t3*sigcsq
3560       t14 = t12+t6*sigsqtc
3561       t16 = 1.0d0
3562       t21 = thetai-theta0i
3563       t23 = t21**2
3564       t26 = term2
3565       t27 = t21*t26
3566       t32 = termexp
3567       t40 = t32**2
3568       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3569      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3570      & *(-t12*t9-ak*sig0inv*t27)
3571       return
3572       end
3573 #else
3574 C--------------------------------------------------------------------------
3575       subroutine ebend(etheta)
3576 C
3577 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3578 C angles gamma and its derivatives in consecutive thetas and gammas.
3579 C ab initio-derived potentials from
3580 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3581 C
3582       implicit real*8 (a-h,o-z)
3583       include 'DIMENSIONS'
3584       include 'COMMON.LOCAL'
3585       include 'COMMON.GEO'
3586       include 'COMMON.INTERACT'
3587       include 'COMMON.DERIV'
3588       include 'COMMON.VAR'
3589       include 'COMMON.CHAIN'
3590       include 'COMMON.IOUNITS'
3591       include 'COMMON.NAMES'
3592       include 'COMMON.FFIELD'
3593       include 'COMMON.CONTROL'
3594       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3595      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3596      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3597      & sinph1ph2(maxdouble,maxdouble)
3598       logical lprn /.false./, lprn1 /.false./
3599       etheta=0.0D0
3600 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3601       do i=ithet_start,ithet_end
3602         dethetai=0.0d0
3603         dephii=0.0d0
3604         dephii1=0.0d0
3605         theti2=0.5d0*theta(i)
3606         ityp2=ithetyp(itype(i-1))
3607         do k=1,nntheterm
3608           coskt(k)=dcos(k*theti2)
3609           sinkt(k)=dsin(k*theti2)
3610         enddo
3611         if (i.gt.3) then
3612 #ifdef OSF
3613           phii=phi(i)
3614           if (phii.ne.phii) phii=150.0
3615 #else
3616           phii=phi(i)
3617 #endif
3618           ityp1=ithetyp(itype(i-2))
3619           do k=1,nsingle
3620             cosph1(k)=dcos(k*phii)
3621             sinph1(k)=dsin(k*phii)
3622           enddo
3623         else
3624           phii=0.0d0
3625           ityp1=nthetyp+1
3626           do k=1,nsingle
3627             cosph1(k)=0.0d0
3628             sinph1(k)=0.0d0
3629           enddo
3630         endif
3631         if (i.lt.nres) then
3632 #ifdef OSF
3633           phii1=phi(i+1)
3634           if (phii1.ne.phii1) phii1=150.0
3635           phii1=pinorm(phii1)
3636 #else
3637           phii1=phi(i+1)
3638 #endif
3639           ityp3=ithetyp(itype(i))
3640           do k=1,nsingle
3641             cosph2(k)=dcos(k*phii1)
3642             sinph2(k)=dsin(k*phii1)
3643           enddo
3644         else
3645           phii1=0.0d0
3646           ityp3=nthetyp+1
3647           do k=1,nsingle
3648             cosph2(k)=0.0d0
3649             sinph2(k)=0.0d0
3650           enddo
3651         endif
3652 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3653 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3654 c        call flush(iout)
3655         ethetai=aa0thet(ityp1,ityp2,ityp3)
3656         do k=1,ndouble
3657           do l=1,k-1
3658             ccl=cosph1(l)*cosph2(k-l)
3659             ssl=sinph1(l)*sinph2(k-l)
3660             scl=sinph1(l)*cosph2(k-l)
3661             csl=cosph1(l)*sinph2(k-l)
3662             cosph1ph2(l,k)=ccl-ssl
3663             cosph1ph2(k,l)=ccl+ssl
3664             sinph1ph2(l,k)=scl+csl
3665             sinph1ph2(k,l)=scl-csl
3666           enddo
3667         enddo
3668         if (lprn) then
3669         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3670      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3671         write (iout,*) "coskt and sinkt"
3672         do k=1,nntheterm
3673           write (iout,*) k,coskt(k),sinkt(k)
3674         enddo
3675         endif
3676         do k=1,ntheterm
3677           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3678           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3679      &      *coskt(k)
3680           if (lprn)
3681      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3682      &     " ethetai",ethetai
3683         enddo
3684         if (lprn) then
3685         write (iout,*) "cosph and sinph"
3686         do k=1,nsingle
3687           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3688         enddo
3689         write (iout,*) "cosph1ph2 and sinph2ph2"
3690         do k=2,ndouble
3691           do l=1,k-1
3692             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3693      &         sinph1ph2(l,k),sinph1ph2(k,l)
3694           enddo
3695         enddo
3696         write(iout,*) "ethetai",ethetai
3697         endif
3698         do m=1,ntheterm2
3699           do k=1,nsingle
3700             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3701      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3702      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3703      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3704             ethetai=ethetai+sinkt(m)*aux
3705             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3706             dephii=dephii+k*sinkt(m)*(
3707      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3708      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3709             dephii1=dephii1+k*sinkt(m)*(
3710      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3711      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3712             if (lprn)
3713      &      write (iout,*) "m",m," k",k," bbthet",
3714      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3715      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3716      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3717      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3718           enddo
3719         enddo
3720         if (lprn)
3721      &  write(iout,*) "ethetai",ethetai
3722         do m=1,ntheterm3
3723           do k=2,ndouble
3724             do l=1,k-1
3725               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3726      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3727      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3728      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3729               ethetai=ethetai+sinkt(m)*aux
3730               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3731               dephii=dephii+l*sinkt(m)*(
3732      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3733      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3734      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3735      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3736               dephii1=dephii1+(k-l)*sinkt(m)*(
3737      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3738      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3739      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3740      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3741               if (lprn) then
3742               write (iout,*) "m",m," k",k," l",l," ffthet",
3743      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3744      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3745      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3746      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3747               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3748      &            cosph1ph2(k,l)*sinkt(m),
3749      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3750               endif
3751             enddo
3752           enddo
3753         enddo
3754 10      continue
3755         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3756      &   i,theta(i)*rad2deg,phii*rad2deg,
3757      &   phii1*rad2deg,ethetai
3758         etheta=etheta+ethetai
3759         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3760         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3761         gloc(nphi+i-2,icg)=wang*dethetai
3762       enddo
3763       return
3764       end
3765 #endif
3766 #ifdef CRYST_SC
3767 c-----------------------------------------------------------------------------
3768       subroutine esc(escloc)
3769 C Calculate the local energy of a side chain and its derivatives in the
3770 C corresponding virtual-bond valence angles THETA and the spherical angles
3771 C ALPHA and OMEGA.
3772       implicit real*8 (a-h,o-z)
3773       include 'DIMENSIONS'
3774       include 'sizesclu.dat'
3775       include 'COMMON.GEO'
3776       include 'COMMON.LOCAL'
3777       include 'COMMON.VAR'
3778       include 'COMMON.INTERACT'
3779       include 'COMMON.DERIV'
3780       include 'COMMON.CHAIN'
3781       include 'COMMON.IOUNITS'
3782       include 'COMMON.NAMES'
3783       include 'COMMON.FFIELD'
3784       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3785      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3786       common /sccalc/ time11,time12,time112,theti,it,nlobit
3787       delta=0.02d0*pi
3788       escloc=0.0D0
3789 c     write (iout,'(a)') 'ESC'
3790       do i=loc_start,loc_end
3791         it=itype(i)
3792         if (it.eq.10) goto 1
3793         nlobit=nlob(it)
3794 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3795 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3796         theti=theta(i+1)-pipol
3797         x(1)=dtan(theti)
3798         x(2)=alph(i)
3799         x(3)=omeg(i)
3800 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3801
3802         if (x(2).gt.pi-delta) then
3803           xtemp(1)=x(1)
3804           xtemp(2)=pi-delta
3805           xtemp(3)=x(3)
3806           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3807           xtemp(2)=pi
3808           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3809           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3810      &        escloci,dersc(2))
3811           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3812      &        ddersc0(1),dersc(1))
3813           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3814      &        ddersc0(3),dersc(3))
3815           xtemp(2)=pi-delta
3816           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3817           xtemp(2)=pi
3818           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3819           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3820      &            dersc0(2),esclocbi,dersc02)
3821           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3822      &            dersc12,dersc01)
3823           call splinthet(x(2),0.5d0*delta,ss,ssd)
3824           dersc0(1)=dersc01
3825           dersc0(2)=dersc02
3826           dersc0(3)=0.0d0
3827           do k=1,3
3828             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3829           enddo
3830           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3831 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3832 c    &             esclocbi,ss,ssd
3833           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3834 c         escloci=esclocbi
3835 c         write (iout,*) escloci
3836         else if (x(2).lt.delta) then
3837           xtemp(1)=x(1)
3838           xtemp(2)=delta
3839           xtemp(3)=x(3)
3840           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3841           xtemp(2)=0.0d0
3842           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3843           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3844      &        escloci,dersc(2))
3845           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3846      &        ddersc0(1),dersc(1))
3847           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3848      &        ddersc0(3),dersc(3))
3849           xtemp(2)=delta
3850           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3851           xtemp(2)=0.0d0
3852           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3853           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3854      &            dersc0(2),esclocbi,dersc02)
3855           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3856      &            dersc12,dersc01)
3857           dersc0(1)=dersc01
3858           dersc0(2)=dersc02
3859           dersc0(3)=0.0d0
3860           call splinthet(x(2),0.5d0*delta,ss,ssd)
3861           do k=1,3
3862             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3863           enddo
3864           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3865 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3866 c    &             esclocbi,ss,ssd
3867           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3868 c         write (iout,*) escloci
3869         else
3870           call enesc(x,escloci,dersc,ddummy,.false.)
3871         endif
3872
3873         escloc=escloc+escloci
3874 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3875
3876         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3877      &   wscloc*dersc(1)
3878         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3879         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3880     1   continue
3881       enddo
3882       return
3883       end
3884 C---------------------------------------------------------------------------
3885       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3886       implicit real*8 (a-h,o-z)
3887       include 'DIMENSIONS'
3888       include 'COMMON.GEO'
3889       include 'COMMON.LOCAL'
3890       include 'COMMON.IOUNITS'
3891       common /sccalc/ time11,time12,time112,theti,it,nlobit
3892       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3893       double precision contr(maxlob,-1:1)
3894       logical mixed
3895 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3896         escloc_i=0.0D0
3897         do j=1,3
3898           dersc(j)=0.0D0
3899           if (mixed) ddersc(j)=0.0d0
3900         enddo
3901         x3=x(3)
3902
3903 C Because of periodicity of the dependence of the SC energy in omega we have
3904 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3905 C To avoid underflows, first compute & store the exponents.
3906
3907         do iii=-1,1
3908
3909           x(3)=x3+iii*dwapi
3910
3911           do j=1,nlobit
3912             do k=1,3
3913               z(k)=x(k)-censc(k,j,it)
3914             enddo
3915             do k=1,3
3916               Axk=0.0D0
3917               do l=1,3
3918                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3919               enddo
3920               Ax(k,j,iii)=Axk
3921             enddo
3922             expfac=0.0D0
3923             do k=1,3
3924               expfac=expfac+Ax(k,j,iii)*z(k)
3925             enddo
3926             contr(j,iii)=expfac
3927           enddo ! j
3928
3929         enddo ! iii
3930
3931         x(3)=x3
3932 C As in the case of ebend, we want to avoid underflows in exponentiation and
3933 C subsequent NaNs and INFs in energy calculation.
3934 C Find the largest exponent
3935         emin=contr(1,-1)
3936         do iii=-1,1
3937           do j=1,nlobit
3938             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3939           enddo
3940         enddo
3941         emin=0.5D0*emin
3942 cd      print *,'it=',it,' emin=',emin
3943
3944 C Compute the contribution to SC energy and derivatives
3945         do iii=-1,1
3946
3947           do j=1,nlobit
3948             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3949 cd          print *,'j=',j,' expfac=',expfac
3950             escloc_i=escloc_i+expfac
3951             do k=1,3
3952               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3953             enddo
3954             if (mixed) then
3955               do k=1,3,2
3956                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3957      &            +gaussc(k,2,j,it))*expfac
3958               enddo
3959             endif
3960           enddo
3961
3962         enddo ! iii
3963
3964         dersc(1)=dersc(1)/cos(theti)**2
3965         ddersc(1)=ddersc(1)/cos(theti)**2
3966         ddersc(3)=ddersc(3)
3967
3968         escloci=-(dlog(escloc_i)-emin)
3969         do j=1,3
3970           dersc(j)=dersc(j)/escloc_i
3971         enddo
3972         if (mixed) then
3973           do j=1,3,2
3974             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3975           enddo
3976         endif
3977       return
3978       end
3979 C------------------------------------------------------------------------------
3980       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3981       implicit real*8 (a-h,o-z)
3982       include 'DIMENSIONS'
3983       include 'COMMON.GEO'
3984       include 'COMMON.LOCAL'
3985       include 'COMMON.IOUNITS'
3986       common /sccalc/ time11,time12,time112,theti,it,nlobit
3987       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3988       double precision contr(maxlob)
3989       logical mixed
3990
3991       escloc_i=0.0D0
3992
3993       do j=1,3
3994         dersc(j)=0.0D0
3995       enddo
3996
3997       do j=1,nlobit
3998         do k=1,2
3999           z(k)=x(k)-censc(k,j,it)
4000         enddo
4001         z(3)=dwapi
4002         do k=1,3
4003           Axk=0.0D0
4004           do l=1,3
4005             Axk=Axk+gaussc(l,k,j,it)*z(l)
4006           enddo
4007           Ax(k,j)=Axk
4008         enddo
4009         expfac=0.0D0
4010         do k=1,3
4011           expfac=expfac+Ax(k,j)*z(k)
4012         enddo
4013         contr(j)=expfac
4014       enddo ! j
4015
4016 C As in the case of ebend, we want to avoid underflows in exponentiation and
4017 C subsequent NaNs and INFs in energy calculation.
4018 C Find the largest exponent
4019       emin=contr(1)
4020       do j=1,nlobit
4021         if (emin.gt.contr(j)) emin=contr(j)
4022       enddo
4023       emin=0.5D0*emin
4024
4025 C Compute the contribution to SC energy and derivatives
4026
4027       dersc12=0.0d0
4028       do j=1,nlobit
4029         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4030         escloc_i=escloc_i+expfac
4031         do k=1,2
4032           dersc(k)=dersc(k)+Ax(k,j)*expfac
4033         enddo
4034         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4035      &            +gaussc(1,2,j,it))*expfac
4036         dersc(3)=0.0d0
4037       enddo
4038
4039       dersc(1)=dersc(1)/cos(theti)**2
4040       dersc12=dersc12/cos(theti)**2
4041       escloci=-(dlog(escloc_i)-emin)
4042       do j=1,2
4043         dersc(j)=dersc(j)/escloc_i
4044       enddo
4045       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4046       return
4047       end
4048 #else
4049 c----------------------------------------------------------------------------------
4050       subroutine esc(escloc)
4051 C Calculate the local energy of a side chain and its derivatives in the
4052 C corresponding virtual-bond valence angles THETA and the spherical angles
4053 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4054 C added by Urszula Kozlowska. 07/11/2007
4055 C
4056       implicit real*8 (a-h,o-z)
4057       include 'DIMENSIONS'
4058       include 'COMMON.GEO'
4059       include 'COMMON.LOCAL'
4060       include 'COMMON.VAR'
4061       include 'COMMON.SCROT'
4062       include 'COMMON.INTERACT'
4063       include 'COMMON.DERIV'
4064       include 'COMMON.CHAIN'
4065       include 'COMMON.IOUNITS'
4066       include 'COMMON.NAMES'
4067       include 'COMMON.FFIELD'
4068       include 'COMMON.CONTROL'
4069       include 'COMMON.VECTORS'
4070       double precision x_prime(3),y_prime(3),z_prime(3)
4071      &    , sumene,dsc_i,dp2_i,x(65),
4072      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4073      &    de_dxx,de_dyy,de_dzz,de_dt
4074       double precision s1_t,s1_6_t,s2_t,s2_6_t
4075       double precision
4076      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4077      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4078      & dt_dCi(3),dt_dCi1(3)
4079       common /sccalc/ time11,time12,time112,theti,it,nlobit
4080       delta=0.02d0*pi
4081       escloc=0.0D0
4082       do i=loc_start,loc_end
4083         costtab(i+1) =dcos(theta(i+1))
4084         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4085         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4086         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4087         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4088         cosfac=dsqrt(cosfac2)
4089         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4090         sinfac=dsqrt(sinfac2)
4091         it=itype(i)
4092         if (it.eq.10) goto 1
4093 c
4094 C  Compute the axes of tghe local cartesian coordinates system; store in
4095 c   x_prime, y_prime and z_prime
4096 c
4097         do j=1,3
4098           x_prime(j) = 0.00
4099           y_prime(j) = 0.00
4100           z_prime(j) = 0.00
4101         enddo
4102 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4103 C     &   dc_norm(3,i+nres)
4104         do j = 1,3
4105           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4106           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4107         enddo
4108         do j = 1,3
4109           z_prime(j) = -uz(j,i-1)
4110         enddo
4111 c       write (2,*) "i",i
4112 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4113 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4114 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4115 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4116 c      & " xy",scalar(x_prime(1),y_prime(1)),
4117 c      & " xz",scalar(x_prime(1),z_prime(1)),
4118 c      & " yy",scalar(y_prime(1),y_prime(1)),
4119 c      & " yz",scalar(y_prime(1),z_prime(1)),
4120 c      & " zz",scalar(z_prime(1),z_prime(1))
4121 c
4122 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4123 C to local coordinate system. Store in xx, yy, zz.
4124 c
4125         xx=0.0d0
4126         yy=0.0d0
4127         zz=0.0d0
4128         do j = 1,3
4129           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4130           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4131           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4132         enddo
4133
4134         xxtab(i)=xx
4135         yytab(i)=yy
4136         zztab(i)=zz
4137 C
4138 C Compute the energy of the ith side cbain
4139 C
4140 c        write (2,*) "xx",xx," yy",yy," zz",zz
4141         it=itype(i)
4142         do j = 1,65
4143           x(j) = sc_parmin(j,it)
4144         enddo
4145 #ifdef CHECK_COORD
4146 Cc diagnostics - remove later
4147         xx1 = dcos(alph(2))
4148         yy1 = dsin(alph(2))*dcos(omeg(2))
4149         zz1 = -dsin(alph(2))*dsin(omeg(2))
4150         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4151      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4152      &    xx1,yy1,zz1
4153 C,"  --- ", xx_w,yy_w,zz_w
4154 c end diagnostics
4155 #endif
4156         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4157      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4158      &   + x(10)*yy*zz
4159         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4160      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4161      & + x(20)*yy*zz
4162         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4163      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4164      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4165      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4166      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4167      &  +x(40)*xx*yy*zz
4168         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4169      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4170      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4171      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4172      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4173      &  +x(60)*xx*yy*zz
4174         dsc_i   = 0.743d0+x(61)
4175         dp2_i   = 1.9d0+x(62)
4176         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4177      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4178         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4179      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4180         s1=(1+x(63))/(0.1d0 + dscp1)
4181         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4182         s2=(1+x(65))/(0.1d0 + dscp2)
4183         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4184         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4185      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4186 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4187 c     &   sumene4,
4188 c     &   dscp1,dscp2,sumene
4189 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4190         escloc = escloc + sumene
4191 c        write (2,*) "escloc",escloc
4192         if (.not. calc_grad) goto 1
4193 #ifdef DEBUG
4194 C
4195 C This section to check the numerical derivatives of the energy of ith side
4196 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4197 C #define DEBUG in the code to turn it on.
4198 C
4199         write (2,*) "sumene               =",sumene
4200         aincr=1.0d-7
4201         xxsave=xx
4202         xx=xx+aincr
4203         write (2,*) xx,yy,zz
4204         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4205         de_dxx_num=(sumenep-sumene)/aincr
4206         xx=xxsave
4207         write (2,*) "xx+ sumene from enesc=",sumenep
4208         yysave=yy
4209         yy=yy+aincr
4210         write (2,*) xx,yy,zz
4211         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4212         de_dyy_num=(sumenep-sumene)/aincr
4213         yy=yysave
4214         write (2,*) "yy+ sumene from enesc=",sumenep
4215         zzsave=zz
4216         zz=zz+aincr
4217         write (2,*) xx,yy,zz
4218         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4219         de_dzz_num=(sumenep-sumene)/aincr
4220         zz=zzsave
4221         write (2,*) "zz+ sumene from enesc=",sumenep
4222         costsave=cost2tab(i+1)
4223         sintsave=sint2tab(i+1)
4224         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4225         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4226         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4227         de_dt_num=(sumenep-sumene)/aincr
4228         write (2,*) " t+ sumene from enesc=",sumenep
4229         cost2tab(i+1)=costsave
4230         sint2tab(i+1)=sintsave
4231 C End of diagnostics section.
4232 #endif
4233 C
4234 C Compute the gradient of esc
4235 C
4236         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4237         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4238         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4239         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4240         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4241         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4242         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4243         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4244         pom1=(sumene3*sint2tab(i+1)+sumene1)
4245      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4246         pom2=(sumene4*cost2tab(i+1)+sumene2)
4247      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4248         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4249         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4250      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4251      &  +x(40)*yy*zz
4252         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4253         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4254      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4255      &  +x(60)*yy*zz
4256         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4257      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4258      &        +(pom1+pom2)*pom_dx
4259 #ifdef DEBUG
4260         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4261 #endif
4262 C
4263         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4264         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4265      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4266      &  +x(40)*xx*zz
4267         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4268         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4269      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4270      &  +x(59)*zz**2 +x(60)*xx*zz
4271         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4272      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4273      &        +(pom1-pom2)*pom_dy
4274 #ifdef DEBUG
4275         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4276 #endif
4277 C
4278         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4279      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4280      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4281      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4282      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4283      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4284      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4285      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4286 #ifdef DEBUG
4287         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4288 #endif
4289 C
4290         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4291      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4292      &  +pom1*pom_dt1+pom2*pom_dt2
4293 #ifdef DEBUG
4294         write(2,*), "de_dt = ", de_dt,de_dt_num
4295 #endif
4296 c
4297 C
4298        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4299        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4300        cosfac2xx=cosfac2*xx
4301        sinfac2yy=sinfac2*yy
4302        do k = 1,3
4303          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4304      &      vbld_inv(i+1)
4305          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4306      &      vbld_inv(i)
4307          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4308          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4309 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4310 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4311 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4312 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4313          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4314          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4315          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4316          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4317          dZZ_Ci1(k)=0.0d0
4318          dZZ_Ci(k)=0.0d0
4319          do j=1,3
4320            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4321            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4322          enddo
4323
4324          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4325          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4326          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4327 c
4328          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4329          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4330        enddo
4331
4332        do k=1,3
4333          dXX_Ctab(k,i)=dXX_Ci(k)
4334          dXX_C1tab(k,i)=dXX_Ci1(k)
4335          dYY_Ctab(k,i)=dYY_Ci(k)
4336          dYY_C1tab(k,i)=dYY_Ci1(k)
4337          dZZ_Ctab(k,i)=dZZ_Ci(k)
4338          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4339          dXX_XYZtab(k,i)=dXX_XYZ(k)
4340          dYY_XYZtab(k,i)=dYY_XYZ(k)
4341          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4342        enddo
4343
4344        do k = 1,3
4345 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4346 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4347 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4348 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4349 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4350 c     &    dt_dci(k)
4351 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4352 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4353          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4354      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4355          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4356      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4357          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4358      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4359        enddo
4360 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4361 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4362
4363 C to check gradient call subroutine check_grad
4364
4365     1 continue
4366       enddo
4367       return
4368       end
4369 #endif
4370 c------------------------------------------------------------------------------
4371       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4372 C
4373 C This procedure calculates two-body contact function g(rij) and its derivative:
4374 C
4375 C           eps0ij                                     !       x < -1
4376 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4377 C            0                                         !       x > 1
4378 C
4379 C where x=(rij-r0ij)/delta
4380 C
4381 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4382 C
4383       implicit none
4384       double precision rij,r0ij,eps0ij,fcont,fprimcont
4385       double precision x,x2,x4,delta
4386 c     delta=0.02D0*r0ij
4387 c      delta=0.2D0*r0ij
4388       x=(rij-r0ij)/delta
4389       if (x.lt.-1.0D0) then
4390         fcont=eps0ij
4391         fprimcont=0.0D0
4392       else if (x.le.1.0D0) then
4393         x2=x*x
4394         x4=x2*x2
4395         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4396         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4397       else
4398         fcont=0.0D0
4399         fprimcont=0.0D0
4400       endif
4401       return
4402       end
4403 c------------------------------------------------------------------------------
4404       subroutine splinthet(theti,delta,ss,ssder)
4405       implicit real*8 (a-h,o-z)
4406       include 'DIMENSIONS'
4407       include 'sizesclu.dat'
4408       include 'COMMON.VAR'
4409       include 'COMMON.GEO'
4410       thetup=pi-delta
4411       thetlow=delta
4412       if (theti.gt.pipol) then
4413         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4414       else
4415         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4416         ssder=-ssder
4417       endif
4418       return
4419       end
4420 c------------------------------------------------------------------------------
4421       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4422       implicit none
4423       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4424       double precision ksi,ksi2,ksi3,a1,a2,a3
4425       a1=fprim0*delta/(f1-f0)
4426       a2=3.0d0-2.0d0*a1
4427       a3=a1-2.0d0
4428       ksi=(x-x0)/delta
4429       ksi2=ksi*ksi
4430       ksi3=ksi2*ksi
4431       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4432       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4433       return
4434       end
4435 c------------------------------------------------------------------------------
4436       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4437       implicit none
4438       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4439       double precision ksi,ksi2,ksi3,a1,a2,a3
4440       ksi=(x-x0)/delta
4441       ksi2=ksi*ksi
4442       ksi3=ksi2*ksi
4443       a1=fprim0x*delta
4444       a2=3*(f1x-f0x)-2*fprim0x*delta
4445       a3=fprim0x*delta-2*(f1x-f0x)
4446       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4447       return
4448       end
4449 C-----------------------------------------------------------------------------
4450 #ifdef CRYST_TOR
4451 C-----------------------------------------------------------------------------
4452       subroutine etor(etors,edihcnstr,fact)
4453       implicit real*8 (a-h,o-z)
4454       include 'DIMENSIONS'
4455       include 'sizesclu.dat'
4456       include 'COMMON.VAR'
4457       include 'COMMON.GEO'
4458       include 'COMMON.LOCAL'
4459       include 'COMMON.TORSION'
4460       include 'COMMON.INTERACT'
4461       include 'COMMON.DERIV'
4462       include 'COMMON.CHAIN'
4463       include 'COMMON.NAMES'
4464       include 'COMMON.IOUNITS'
4465       include 'COMMON.FFIELD'
4466       include 'COMMON.TORCNSTR'
4467       logical lprn
4468 C Set lprn=.true. for debugging
4469       lprn=.false.
4470 c      lprn=.true.
4471       etors=0.0D0
4472       do i=iphi_start,iphi_end
4473         itori=itortyp(itype(i-2))
4474         itori1=itortyp(itype(i-1))
4475         phii=phi(i)
4476         gloci=0.0D0
4477 C Proline-Proline pair is a special case...
4478         if (itori.eq.3 .and. itori1.eq.3) then
4479           if (phii.gt.-dwapi3) then
4480             cosphi=dcos(3*phii)
4481             fac=1.0D0/(1.0D0-cosphi)
4482             etorsi=v1(1,3,3)*fac
4483             etorsi=etorsi+etorsi
4484             etors=etors+etorsi-v1(1,3,3)
4485             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4486           endif
4487           do j=1,3
4488             v1ij=v1(j+1,itori,itori1)
4489             v2ij=v2(j+1,itori,itori1)
4490             cosphi=dcos(j*phii)
4491             sinphi=dsin(j*phii)
4492             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4493             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4494           enddo
4495         else
4496           do j=1,nterm_old
4497             v1ij=v1(j,itori,itori1)
4498             v2ij=v2(j,itori,itori1)
4499             cosphi=dcos(j*phii)
4500             sinphi=dsin(j*phii)
4501             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4502             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4503           enddo
4504         endif
4505         if (lprn)
4506      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4507      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4508      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4509         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4510 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4511       enddo
4512 ! 6/20/98 - dihedral angle constraints
4513       edihcnstr=0.0d0
4514       do i=1,ndih_constr
4515         itori=idih_constr(i)
4516         phii=phi(itori)
4517         difi=pinorm(phii-phi0(i))
4518         if (difi.gt.drange(i)) then
4519           difi=difi-drange(i)
4520           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4521           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4522         else if (difi.lt.-drange(i)) then
4523           difi=difi+drange(i)
4524           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4525           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4526         endif
4527 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4528 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4529       enddo
4530       write (iout,*) 'edihcnstr',edihcnstr
4531       return
4532       end
4533 c------------------------------------------------------------------------------
4534 #else
4535       subroutine etor(etors,edihcnstr,fact)
4536       implicit real*8 (a-h,o-z)
4537       include 'DIMENSIONS'
4538       include 'sizesclu.dat'
4539       include 'COMMON.VAR'
4540       include 'COMMON.GEO'
4541       include 'COMMON.LOCAL'
4542       include 'COMMON.TORSION'
4543       include 'COMMON.INTERACT'
4544       include 'COMMON.DERIV'
4545       include 'COMMON.CHAIN'
4546       include 'COMMON.NAMES'
4547       include 'COMMON.IOUNITS'
4548       include 'COMMON.FFIELD'
4549       include 'COMMON.TORCNSTR'
4550       logical lprn
4551 C Set lprn=.true. for debugging
4552       lprn=.false.
4553 c      lprn=.true.
4554       etors=0.0D0
4555       do i=iphi_start,iphi_end
4556         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4557         itori=itortyp(itype(i-2))
4558         itori1=itortyp(itype(i-1))
4559         phii=phi(i)
4560         gloci=0.0D0
4561 C Regular cosine and sine terms
4562         do j=1,nterm(itori,itori1)
4563           v1ij=v1(j,itori,itori1)
4564           v2ij=v2(j,itori,itori1)
4565           cosphi=dcos(j*phii)
4566           sinphi=dsin(j*phii)
4567           etors=etors+v1ij*cosphi+v2ij*sinphi
4568           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4569         enddo
4570 C Lorentz terms
4571 C                         v1
4572 C  E = SUM ----------------------------------- - v1
4573 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4574 C
4575         cosphi=dcos(0.5d0*phii)
4576         sinphi=dsin(0.5d0*phii)
4577         do j=1,nlor(itori,itori1)
4578           vl1ij=vlor1(j,itori,itori1)
4579           vl2ij=vlor2(j,itori,itori1)
4580           vl3ij=vlor3(j,itori,itori1)
4581           pom=vl2ij*cosphi+vl3ij*sinphi
4582           pom1=1.0d0/(pom*pom+1.0d0)
4583           etors=etors+vl1ij*pom1
4584           pom=-pom*pom1*pom1
4585           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4586         enddo
4587 C Subtract the constant term
4588         etors=etors-v0(itori,itori1)
4589         if (lprn)
4590      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4591      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4592      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4593         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4594 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4595  1215   continue
4596       enddo
4597 ! 6/20/98 - dihedral angle constraints
4598       edihcnstr=0.0d0
4599 c      write (iout,*) "Dihedral angle restraint energy"
4600       do i=1,ndih_constr
4601         itori=idih_constr(i)
4602         phii=phi(itori)
4603         difi=pinorm(phii-phi0(i))
4604 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
4605 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
4606         if (difi.gt.drange(i)) then
4607           difi=difi-drange(i)
4608           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4609           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4610 c          write (iout,*) 0.25d0*ftors*difi**4
4611         else if (difi.lt.-drange(i)) then
4612           difi=difi+drange(i)
4613           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4614           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4615 c          write (iout,*) 0.25d0*ftors*difi**4
4616         endif
4617       enddo
4618 c      write (iout,*) 'edihcnstr',edihcnstr
4619       return
4620       end
4621 c----------------------------------------------------------------------------
4622       subroutine etor_d(etors_d,fact2)
4623 C 6/23/01 Compute double torsional energy
4624       implicit real*8 (a-h,o-z)
4625       include 'DIMENSIONS'
4626       include 'sizesclu.dat'
4627       include 'COMMON.VAR'
4628       include 'COMMON.GEO'
4629       include 'COMMON.LOCAL'
4630       include 'COMMON.TORSION'
4631       include 'COMMON.INTERACT'
4632       include 'COMMON.DERIV'
4633       include 'COMMON.CHAIN'
4634       include 'COMMON.NAMES'
4635       include 'COMMON.IOUNITS'
4636       include 'COMMON.FFIELD'
4637       include 'COMMON.TORCNSTR'
4638       logical lprn
4639 C Set lprn=.true. for debugging
4640       lprn=.false.
4641 c     lprn=.true.
4642       etors_d=0.0D0
4643       do i=iphi_start,iphi_end-1
4644         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4645      &     goto 1215
4646         itori=itortyp(itype(i-2))
4647         itori1=itortyp(itype(i-1))
4648         itori2=itortyp(itype(i))
4649         phii=phi(i)
4650         phii1=phi(i+1)
4651         gloci1=0.0D0
4652         gloci2=0.0D0
4653 C Regular cosine and sine terms
4654         do j=1,ntermd_1(itori,itori1,itori2)
4655           v1cij=v1c(1,j,itori,itori1,itori2)
4656           v1sij=v1s(1,j,itori,itori1,itori2)
4657           v2cij=v1c(2,j,itori,itori1,itori2)
4658           v2sij=v1s(2,j,itori,itori1,itori2)
4659           cosphi1=dcos(j*phii)
4660           sinphi1=dsin(j*phii)
4661           cosphi2=dcos(j*phii1)
4662           sinphi2=dsin(j*phii1)
4663           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4664      &     v2cij*cosphi2+v2sij*sinphi2
4665           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4666           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4667         enddo
4668         do k=2,ntermd_2(itori,itori1,itori2)
4669           do l=1,k-1
4670             v1cdij = v2c(k,l,itori,itori1,itori2)
4671             v2cdij = v2c(l,k,itori,itori1,itori2)
4672             v1sdij = v2s(k,l,itori,itori1,itori2)
4673             v2sdij = v2s(l,k,itori,itori1,itori2)
4674             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4675             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4676             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4677             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4678             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4679      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4680             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4681      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4682             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4683      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4684           enddo
4685         enddo
4686         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4687         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4688  1215   continue
4689       enddo
4690       return
4691       end
4692 #endif
4693 c------------------------------------------------------------------------------
4694       subroutine eback_sc_corr(esccor,fact)
4695 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4696 c        conformational states; temporarily implemented as differences
4697 c        between UNRES torsional potentials (dependent on three types of
4698 c        residues) and the torsional potentials dependent on all 20 types
4699 c        of residues computed from AM1 energy surfaces of terminally-blocked
4700 c        amino-acid residues.
4701       implicit real*8 (a-h,o-z)
4702       include 'DIMENSIONS'
4703       include 'COMMON.VAR'
4704       include 'COMMON.GEO'
4705       include 'COMMON.LOCAL'
4706       include 'COMMON.TORSION'
4707       include 'COMMON.SCCOR'
4708       include 'COMMON.INTERACT'
4709       include 'COMMON.DERIV'
4710       include 'COMMON.CHAIN'
4711       include 'COMMON.NAMES'
4712       include 'COMMON.IOUNITS'
4713       include 'COMMON.FFIELD'
4714       include 'COMMON.CONTROL'
4715       logical lprn
4716 C Set lprn=.true. for debugging
4717       lprn=.false.
4718 c      lprn=.true.
4719 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4720       esccor=0.0D0
4721       do i=itau_start,itau_end
4722         esccor_ii=0.0D0
4723         isccori=isccortyp(itype(i-2))
4724         isccori1=isccortyp(itype(i-1))
4725         phii=phi(i)
4726 cccc  Added 9 May 2012
4727 cc Tauangle is torsional engle depending on the value of first digit
4728 c(see comment below)
4729 cc Omicron is flat angle depending on the value of first digit
4730 c(see comment below)
4731
4732
4733         do intertyp=1,3 !intertyp
4734 cc Added 09 May 2012 (Adasko)
4735 cc  Intertyp means interaction type of backbone mainchain correlation:
4736 c   1 = SC...Ca...Ca...Ca
4737 c   2 = Ca...Ca...Ca...SC
4738 c   3 = SC...Ca...Ca...SCi
4739         gloci=0.0D0
4740         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4741      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
4742      &      (itype(i-1).eq.21)))
4743      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4744      &     .or.(itype(i-2).eq.21)))
4745      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4746      &      (itype(i-1).eq.21)))) cycle
4747         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
4748         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
4749      & cycle
4750         do j=1,nterm_sccor(isccori,isccori1)
4751           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4752           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4753           cosphi=dcos(j*tauangle(intertyp,i))
4754           sinphi=dsin(j*tauangle(intertyp,i))
4755           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4756           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4757         enddo
4758         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4759 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
4760 c     &gloc_sc(intertyp,i-3,icg)
4761         if (lprn)
4762      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4763      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4764      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
4765      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
4766         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4767        enddo !intertyp
4768       enddo
4769
4770       return
4771       end
4772 c------------------------------------------------------------------------------
4773       subroutine multibody(ecorr)
4774 C This subroutine calculates multi-body contributions to energy following
4775 C the idea of Skolnick et al. If side chains I and J make a contact and
4776 C at the same time side chains I+1 and J+1 make a contact, an extra
4777 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4778       implicit real*8 (a-h,o-z)
4779       include 'DIMENSIONS'
4780       include 'COMMON.IOUNITS'
4781       include 'COMMON.DERIV'
4782       include 'COMMON.INTERACT'
4783       include 'COMMON.CONTACTS'
4784       double precision gx(3),gx1(3)
4785       logical lprn
4786
4787 C Set lprn=.true. for debugging
4788       lprn=.false.
4789
4790       if (lprn) then
4791         write (iout,'(a)') 'Contact function values:'
4792         do i=nnt,nct-2
4793           write (iout,'(i2,20(1x,i2,f10.5))')
4794      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4795         enddo
4796       endif
4797       ecorr=0.0D0
4798       do i=nnt,nct
4799         do j=1,3
4800           gradcorr(j,i)=0.0D0
4801           gradxorr(j,i)=0.0D0
4802         enddo
4803       enddo
4804       do i=nnt,nct-2
4805
4806         DO ISHIFT = 3,4
4807
4808         i1=i+ishift
4809         num_conti=num_cont(i)
4810         num_conti1=num_cont(i1)
4811         do jj=1,num_conti
4812           j=jcont(jj,i)
4813           do kk=1,num_conti1
4814             j1=jcont(kk,i1)
4815             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4816 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4817 cd   &                   ' ishift=',ishift
4818 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4819 C The system gains extra energy.
4820               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4821             endif   ! j1==j+-ishift
4822           enddo     ! kk
4823         enddo       ! jj
4824
4825         ENDDO ! ISHIFT
4826
4827       enddo         ! i
4828       return
4829       end
4830 c------------------------------------------------------------------------------
4831       double precision function esccorr(i,j,k,l,jj,kk)
4832       implicit real*8 (a-h,o-z)
4833       include 'DIMENSIONS'
4834       include 'COMMON.IOUNITS'
4835       include 'COMMON.DERIV'
4836       include 'COMMON.INTERACT'
4837       include 'COMMON.CONTACTS'
4838       double precision gx(3),gx1(3)
4839       logical lprn
4840       lprn=.false.
4841       eij=facont(jj,i)
4842       ekl=facont(kk,k)
4843 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4844 C Calculate the multi-body contribution to energy.
4845 C Calculate multi-body contributions to the gradient.
4846 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4847 cd   & k,l,(gacont(m,kk,k),m=1,3)
4848       do m=1,3
4849         gx(m) =ekl*gacont(m,jj,i)
4850         gx1(m)=eij*gacont(m,kk,k)
4851         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4852         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4853         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4854         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4855       enddo
4856       do m=i,j-1
4857         do ll=1,3
4858           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4859         enddo
4860       enddo
4861       do m=k,l-1
4862         do ll=1,3
4863           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4864         enddo
4865       enddo
4866       esccorr=-eij*ekl
4867       return
4868       end
4869 c------------------------------------------------------------------------------
4870 #ifdef MPL
4871       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4872       implicit real*8 (a-h,o-z)
4873       include 'DIMENSIONS'
4874       integer dimen1,dimen2,atom,indx
4875       double precision buffer(dimen1,dimen2)
4876       double precision zapas
4877       common /contacts_hb/ zapas(3,20,maxres,7),
4878      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4879      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4880       num_kont=num_cont_hb(atom)
4881       do i=1,num_kont
4882         do k=1,7
4883           do j=1,3
4884             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4885           enddo ! j
4886         enddo ! k
4887         buffer(i,indx+22)=facont_hb(i,atom)
4888         buffer(i,indx+23)=ees0p(i,atom)
4889         buffer(i,indx+24)=ees0m(i,atom)
4890         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4891       enddo ! i
4892       buffer(1,indx+26)=dfloat(num_kont)
4893       return
4894       end
4895 c------------------------------------------------------------------------------
4896       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4897       implicit real*8 (a-h,o-z)
4898       include 'DIMENSIONS'
4899       integer dimen1,dimen2,atom,indx
4900       double precision buffer(dimen1,dimen2)
4901       double precision zapas
4902       common /contacts_hb/ zapas(3,20,maxres,7),
4903      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4904      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4905       num_kont=buffer(1,indx+26)
4906       num_kont_old=num_cont_hb(atom)
4907       num_cont_hb(atom)=num_kont+num_kont_old
4908       do i=1,num_kont
4909         ii=i+num_kont_old
4910         do k=1,7
4911           do j=1,3
4912             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4913           enddo ! j
4914         enddo ! k
4915         facont_hb(ii,atom)=buffer(i,indx+22)
4916         ees0p(ii,atom)=buffer(i,indx+23)
4917         ees0m(ii,atom)=buffer(i,indx+24)
4918         jcont_hb(ii,atom)=buffer(i,indx+25)
4919       enddo ! i
4920       return
4921       end
4922 c------------------------------------------------------------------------------
4923 #endif
4924       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4925 C This subroutine calculates multi-body contributions to hydrogen-bonding
4926       implicit real*8 (a-h,o-z)
4927       include 'DIMENSIONS'
4928       include 'sizesclu.dat'
4929       include 'COMMON.IOUNITS'
4930 #ifdef MPL
4931       include 'COMMON.INFO'
4932 #endif
4933       include 'COMMON.FFIELD'
4934       include 'COMMON.DERIV'
4935       include 'COMMON.INTERACT'
4936       include 'COMMON.CONTACTS'
4937 #ifdef MPL
4938       parameter (max_cont=maxconts)
4939       parameter (max_dim=2*(8*3+2))
4940       parameter (msglen1=max_cont*max_dim*4)
4941       parameter (msglen2=2*msglen1)
4942       integer source,CorrelType,CorrelID,Error
4943       double precision buffer(max_cont,max_dim)
4944 #endif
4945       double precision gx(3),gx1(3)
4946       logical lprn,ldone
4947
4948 C Set lprn=.true. for debugging
4949       lprn=.false.
4950 #ifdef MPL
4951       n_corr=0
4952       n_corr1=0
4953       if (fgProcs.le.1) goto 30
4954       if (lprn) then
4955         write (iout,'(a)') 'Contact function values:'
4956         do i=nnt,nct-2
4957           write (iout,'(2i3,50(1x,i2,f5.2))')
4958      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4959      &    j=1,num_cont_hb(i))
4960         enddo
4961       endif
4962 C Caution! Following code assumes that electrostatic interactions concerning
4963 C a given atom are split among at most two processors!
4964       CorrelType=477
4965       CorrelID=MyID+1
4966       ldone=.false.
4967       do i=1,max_cont
4968         do j=1,max_dim
4969           buffer(i,j)=0.0D0
4970         enddo
4971       enddo
4972       mm=mod(MyRank,2)
4973 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4974       if (mm) 20,20,10
4975    10 continue
4976 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4977       if (MyRank.gt.0) then
4978 C Send correlation contributions to the preceding processor
4979         msglen=msglen1
4980         nn=num_cont_hb(iatel_s)
4981         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4982 cd      write (iout,*) 'The BUFFER array:'
4983 cd      do i=1,nn
4984 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4985 cd      enddo
4986         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4987           msglen=msglen2
4988             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4989 C Clear the contacts of the atom passed to the neighboring processor
4990         nn=num_cont_hb(iatel_s+1)
4991 cd      do i=1,nn
4992 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4993 cd      enddo
4994             num_cont_hb(iatel_s)=0
4995         endif
4996 cd      write (iout,*) 'Processor ',MyID,MyRank,
4997 cd   & ' is sending correlation contribution to processor',MyID-1,
4998 cd   & ' msglen=',msglen
4999 cd      write (*,*) 'Processor ',MyID,MyRank,
5000 cd   & ' is sending correlation contribution to processor',MyID-1,
5001 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5002         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5003 cd      write (iout,*) 'Processor ',MyID,
5004 cd   & ' has sent correlation contribution to processor',MyID-1,
5005 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5006 cd      write (*,*) 'Processor ',MyID,
5007 cd   & ' has sent correlation contribution to processor',MyID-1,
5008 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5009         msglen=msglen1
5010       endif ! (MyRank.gt.0)
5011       if (ldone) goto 30
5012       ldone=.true.
5013    20 continue
5014 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5015       if (MyRank.lt.fgProcs-1) then
5016 C Receive correlation contributions from the next processor
5017         msglen=msglen1
5018         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5019 cd      write (iout,*) 'Processor',MyID,
5020 cd   & ' is receiving correlation contribution from processor',MyID+1,
5021 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5022 cd      write (*,*) 'Processor',MyID,
5023 cd   & ' is receiving correlation contribution from processor',MyID+1,
5024 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5025         nbytes=-1
5026         do while (nbytes.le.0)
5027           call mp_probe(MyID+1,CorrelType,nbytes)
5028         enddo
5029 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5030         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5031 cd      write (iout,*) 'Processor',MyID,
5032 cd   & ' has received correlation contribution from processor',MyID+1,
5033 cd   & ' msglen=',msglen,' nbytes=',nbytes
5034 cd      write (iout,*) 'The received BUFFER array:'
5035 cd      do i=1,max_cont
5036 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5037 cd      enddo
5038         if (msglen.eq.msglen1) then
5039           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5040         else if (msglen.eq.msglen2)  then
5041           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5042           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5043         else
5044           write (iout,*)
5045      & 'ERROR!!!! message length changed while processing correlations.'
5046           write (*,*)
5047      & 'ERROR!!!! message length changed while processing correlations.'
5048           call mp_stopall(Error)
5049         endif ! msglen.eq.msglen1
5050       endif ! MyRank.lt.fgProcs-1
5051       if (ldone) goto 30
5052       ldone=.true.
5053       goto 10
5054    30 continue
5055 #endif
5056       if (lprn) then
5057         write (iout,'(a)') 'Contact function values:'
5058         do i=nnt,nct-2
5059           write (iout,'(2i3,50(1x,i2,f5.2))')
5060      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5061      &    j=1,num_cont_hb(i))
5062         enddo
5063       endif
5064       ecorr=0.0D0
5065 C Remove the loop below after debugging !!!
5066       do i=nnt,nct
5067         do j=1,3
5068           gradcorr(j,i)=0.0D0
5069           gradxorr(j,i)=0.0D0
5070         enddo
5071       enddo
5072 C Calculate the local-electrostatic correlation terms
5073       do i=iatel_s,iatel_e+1
5074         i1=i+1
5075         num_conti=num_cont_hb(i)
5076         num_conti1=num_cont_hb(i+1)
5077         do jj=1,num_conti
5078           j=jcont_hb(jj,i)
5079           do kk=1,num_conti1
5080             j1=jcont_hb(kk,i1)
5081 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5082 c     &         ' jj=',jj,' kk=',kk
5083             if (j1.eq.j+1 .or. j1.eq.j-1) then
5084 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5085 C The system gains extra energy.
5086               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5087               n_corr=n_corr+1
5088             else if (j1.eq.j) then
5089 C Contacts I-J and I-(J+1) occur simultaneously.
5090 C The system loses extra energy.
5091 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5092             endif
5093           enddo ! kk
5094           do kk=1,num_conti
5095             j1=jcont_hb(kk,i)
5096 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5097 c    &         ' jj=',jj,' kk=',kk
5098             if (j1.eq.j+1) then
5099 C Contacts I-J and (I+1)-J occur simultaneously.
5100 C The system loses extra energy.
5101 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5102             endif ! j1==j+1
5103           enddo ! kk
5104         enddo ! jj
5105       enddo ! i
5106       return
5107       end
5108 c------------------------------------------------------------------------------
5109       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5110      &  n_corr1)
5111 C This subroutine calculates multi-body contributions to hydrogen-bonding
5112       implicit real*8 (a-h,o-z)
5113       include 'DIMENSIONS'
5114       include 'sizesclu.dat'
5115       include 'COMMON.IOUNITS'
5116 #ifdef MPL
5117       include 'COMMON.INFO'
5118 #endif
5119       include 'COMMON.FFIELD'
5120       include 'COMMON.DERIV'
5121       include 'COMMON.INTERACT'
5122       include 'COMMON.CONTACTS'
5123 #ifdef MPL
5124       parameter (max_cont=maxconts)
5125       parameter (max_dim=2*(8*3+2))
5126       parameter (msglen1=max_cont*max_dim*4)
5127       parameter (msglen2=2*msglen1)
5128       integer source,CorrelType,CorrelID,Error
5129       double precision buffer(max_cont,max_dim)
5130 #endif
5131       double precision gx(3),gx1(3)
5132       logical lprn,ldone
5133
5134 C Set lprn=.true. for debugging
5135       lprn=.false.
5136       eturn6=0.0d0
5137       ecorr6=0.0d0
5138 #ifdef MPL
5139       n_corr=0
5140       n_corr1=0
5141       if (fgProcs.le.1) goto 30
5142       if (lprn) then
5143         write (iout,'(a)') 'Contact function values:'
5144         do i=nnt,nct-2
5145           write (iout,'(2i3,50(1x,i2,f5.2))')
5146      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5147      &    j=1,num_cont_hb(i))
5148         enddo
5149       endif
5150 C Caution! Following code assumes that electrostatic interactions concerning
5151 C a given atom are split among at most two processors!
5152       CorrelType=477
5153       CorrelID=MyID+1
5154       ldone=.false.
5155       do i=1,max_cont
5156         do j=1,max_dim
5157           buffer(i,j)=0.0D0
5158         enddo
5159       enddo
5160       mm=mod(MyRank,2)
5161 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5162       if (mm) 20,20,10
5163    10 continue
5164 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5165       if (MyRank.gt.0) then
5166 C Send correlation contributions to the preceding processor
5167         msglen=msglen1
5168         nn=num_cont_hb(iatel_s)
5169         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5170 cd      write (iout,*) 'The BUFFER array:'
5171 cd      do i=1,nn
5172 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5173 cd      enddo
5174         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5175           msglen=msglen2
5176             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5177 C Clear the contacts of the atom passed to the neighboring processor
5178         nn=num_cont_hb(iatel_s+1)
5179 cd      do i=1,nn
5180 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5181 cd      enddo
5182             num_cont_hb(iatel_s)=0
5183         endif
5184 cd      write (iout,*) 'Processor ',MyID,MyRank,
5185 cd   & ' is sending correlation contribution to processor',MyID-1,
5186 cd   & ' msglen=',msglen
5187 cd      write (*,*) 'Processor ',MyID,MyRank,
5188 cd   & ' is sending correlation contribution to processor',MyID-1,
5189 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5190         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5191 cd      write (iout,*) 'Processor ',MyID,
5192 cd   & ' has sent correlation contribution to processor',MyID-1,
5193 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5194 cd      write (*,*) 'Processor ',MyID,
5195 cd   & ' has sent correlation contribution to processor',MyID-1,
5196 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5197         msglen=msglen1
5198       endif ! (MyRank.gt.0)
5199       if (ldone) goto 30
5200       ldone=.true.
5201    20 continue
5202 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5203       if (MyRank.lt.fgProcs-1) then
5204 C Receive correlation contributions from the next processor
5205         msglen=msglen1
5206         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5207 cd      write (iout,*) 'Processor',MyID,
5208 cd   & ' is receiving correlation contribution from processor',MyID+1,
5209 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5210 cd      write (*,*) 'Processor',MyID,
5211 cd   & ' is receiving correlation contribution from processor',MyID+1,
5212 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5213         nbytes=-1
5214         do while (nbytes.le.0)
5215           call mp_probe(MyID+1,CorrelType,nbytes)
5216         enddo
5217 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5218         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5219 cd      write (iout,*) 'Processor',MyID,
5220 cd   & ' has received correlation contribution from processor',MyID+1,
5221 cd   & ' msglen=',msglen,' nbytes=',nbytes
5222 cd      write (iout,*) 'The received BUFFER array:'
5223 cd      do i=1,max_cont
5224 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5225 cd      enddo
5226         if (msglen.eq.msglen1) then
5227           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5228         else if (msglen.eq.msglen2)  then
5229           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5230           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5231         else
5232           write (iout,*)
5233      & 'ERROR!!!! message length changed while processing correlations.'
5234           write (*,*)
5235      & 'ERROR!!!! message length changed while processing correlations.'
5236           call mp_stopall(Error)
5237         endif ! msglen.eq.msglen1
5238       endif ! MyRank.lt.fgProcs-1
5239       if (ldone) goto 30
5240       ldone=.true.
5241       goto 10
5242    30 continue
5243 #endif
5244       if (lprn) then
5245         write (iout,'(a)') 'Contact function values:'
5246         do i=nnt,nct-2
5247           write (iout,'(2i3,50(1x,i2,f5.2))')
5248      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5249      &    j=1,num_cont_hb(i))
5250         enddo
5251       endif
5252       ecorr=0.0D0
5253       ecorr5=0.0d0
5254       ecorr6=0.0d0
5255 C Remove the loop below after debugging !!!
5256       do i=nnt,nct
5257         do j=1,3
5258           gradcorr(j,i)=0.0D0
5259           gradxorr(j,i)=0.0D0
5260         enddo
5261       enddo
5262 C Calculate the dipole-dipole interaction energies
5263       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5264       do i=iatel_s,iatel_e+1
5265         num_conti=num_cont_hb(i)
5266         do jj=1,num_conti
5267           j=jcont_hb(jj,i)
5268           call dipole(i,j,jj)
5269         enddo
5270       enddo
5271       endif
5272 C Calculate the local-electrostatic correlation terms
5273       do i=iatel_s,iatel_e+1
5274         i1=i+1
5275         num_conti=num_cont_hb(i)
5276         num_conti1=num_cont_hb(i+1)
5277         do jj=1,num_conti
5278           j=jcont_hb(jj,i)
5279           do kk=1,num_conti1
5280             j1=jcont_hb(kk,i1)
5281 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5282 c     &         ' jj=',jj,' kk=',kk
5283             if (j1.eq.j+1 .or. j1.eq.j-1) then
5284 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5285 C The system gains extra energy.
5286               n_corr=n_corr+1
5287               sqd1=dsqrt(d_cont(jj,i))
5288               sqd2=dsqrt(d_cont(kk,i1))
5289               sred_geom = sqd1*sqd2
5290               IF (sred_geom.lt.cutoff_corr) THEN
5291                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5292      &            ekont,fprimcont)
5293 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5294 c     &         ' jj=',jj,' kk=',kk
5295                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5296                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5297                 do l=1,3
5298                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5299                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5300                 enddo
5301                 n_corr1=n_corr1+1
5302 cd               write (iout,*) 'sred_geom=',sred_geom,
5303 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5304                 call calc_eello(i,j,i+1,j1,jj,kk)
5305                 if (wcorr4.gt.0.0d0)
5306      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5307                 if (wcorr5.gt.0.0d0)
5308      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5309 c                print *,"wcorr5",ecorr5
5310 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5311 cd                write(2,*)'ijkl',i,j,i+1,j1
5312                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5313      &               .or. wturn6.eq.0.0d0))then
5314 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5315 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5316 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5317 c     &            'ecorr6=',ecorr6, wcorr6
5318 cd                write (iout,'(4e15.5)') sred_geom,
5319 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5320 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5321 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5322                 else if (wturn6.gt.0.0d0
5323      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5324 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5325                   eturn6=eturn6+eello_turn6(i,jj,kk)
5326 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5327                 endif
5328               ENDIF
5329 1111          continue
5330             else if (j1.eq.j) then
5331 C Contacts I-J and I-(J+1) occur simultaneously.
5332 C The system loses extra energy.
5333 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5334             endif
5335           enddo ! kk
5336           do kk=1,num_conti
5337             j1=jcont_hb(kk,i)
5338 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5339 c    &         ' jj=',jj,' kk=',kk
5340             if (j1.eq.j+1) then
5341 C Contacts I-J and (I+1)-J occur simultaneously.
5342 C The system loses extra energy.
5343 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5344             endif ! j1==j+1
5345           enddo ! kk
5346         enddo ! jj
5347       enddo ! i
5348       return
5349       end
5350 c------------------------------------------------------------------------------
5351       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5352       implicit real*8 (a-h,o-z)
5353       include 'DIMENSIONS'
5354       include 'COMMON.IOUNITS'
5355       include 'COMMON.DERIV'
5356       include 'COMMON.INTERACT'
5357       include 'COMMON.CONTACTS'
5358       double precision gx(3),gx1(3)
5359       logical lprn
5360       lprn=.false.
5361       eij=facont_hb(jj,i)
5362       ekl=facont_hb(kk,k)
5363       ees0pij=ees0p(jj,i)
5364       ees0pkl=ees0p(kk,k)
5365       ees0mij=ees0m(jj,i)
5366       ees0mkl=ees0m(kk,k)
5367       ekont=eij*ekl
5368       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5369 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5370 C Following 4 lines for diagnostics.
5371 cd    ees0pkl=0.0D0
5372 cd    ees0pij=1.0D0
5373 cd    ees0mkl=0.0D0
5374 cd    ees0mij=1.0D0
5375 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5376 c    &   ' and',k,l
5377 c     write (iout,*)'Contacts have occurred for peptide groups',
5378 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5379 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5380 C Calculate the multi-body contribution to energy.
5381       ecorr=ecorr+ekont*ees
5382       if (calc_grad) then
5383 C Calculate multi-body contributions to the gradient.
5384       do ll=1,3
5385         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5386         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5387      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5388      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5389         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5390      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5391      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5392         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5393         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5394      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5395      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5396         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5397      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5398      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5399       enddo
5400       do m=i+1,j-1
5401         do ll=1,3
5402           gradcorr(ll,m)=gradcorr(ll,m)+
5403      &     ees*ekl*gacont_hbr(ll,jj,i)-
5404      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5405      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5406         enddo
5407       enddo
5408       do m=k+1,l-1
5409         do ll=1,3
5410           gradcorr(ll,m)=gradcorr(ll,m)+
5411      &     ees*eij*gacont_hbr(ll,kk,k)-
5412      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5413      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5414         enddo
5415       enddo
5416       endif
5417       ehbcorr=ekont*ees
5418       return
5419       end
5420 C---------------------------------------------------------------------------
5421       subroutine dipole(i,j,jj)
5422       implicit real*8 (a-h,o-z)
5423       include 'DIMENSIONS'
5424       include 'sizesclu.dat'
5425       include 'COMMON.IOUNITS'
5426       include 'COMMON.CHAIN'
5427       include 'COMMON.FFIELD'
5428       include 'COMMON.DERIV'
5429       include 'COMMON.INTERACT'
5430       include 'COMMON.CONTACTS'
5431       include 'COMMON.TORSION'
5432       include 'COMMON.VAR'
5433       include 'COMMON.GEO'
5434       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5435      &  auxmat(2,2)
5436       iti1 = itortyp(itype(i+1))
5437       if (j.lt.nres-1) then
5438         itj1 = itortyp(itype(j+1))
5439       else
5440         itj1=ntortyp+1
5441       endif
5442       do iii=1,2
5443         dipi(iii,1)=Ub2(iii,i)
5444         dipderi(iii)=Ub2der(iii,i)
5445         dipi(iii,2)=b1(iii,iti1)
5446         dipj(iii,1)=Ub2(iii,j)
5447         dipderj(iii)=Ub2der(iii,j)
5448         dipj(iii,2)=b1(iii,itj1)
5449       enddo
5450       kkk=0
5451       do iii=1,2
5452         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5453         do jjj=1,2
5454           kkk=kkk+1
5455           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5456         enddo
5457       enddo
5458       if (.not.calc_grad) return
5459       do kkk=1,5
5460         do lll=1,3
5461           mmm=0
5462           do iii=1,2
5463             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5464      &        auxvec(1))
5465             do jjj=1,2
5466               mmm=mmm+1
5467               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5468             enddo
5469           enddo
5470         enddo
5471       enddo
5472       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5473       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5474       do iii=1,2
5475         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5476       enddo
5477       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5478       do iii=1,2
5479         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5480       enddo
5481       return
5482       end
5483 C---------------------------------------------------------------------------
5484       subroutine calc_eello(i,j,k,l,jj,kk)
5485 C
5486 C This subroutine computes matrices and vectors needed to calculate
5487 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5488 C
5489       implicit real*8 (a-h,o-z)
5490       include 'DIMENSIONS'
5491       include 'sizesclu.dat'
5492       include 'COMMON.IOUNITS'
5493       include 'COMMON.CHAIN'
5494       include 'COMMON.DERIV'
5495       include 'COMMON.INTERACT'
5496       include 'COMMON.CONTACTS'
5497       include 'COMMON.TORSION'
5498       include 'COMMON.VAR'
5499       include 'COMMON.GEO'
5500       include 'COMMON.FFIELD'
5501       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5502      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5503       logical lprn
5504       common /kutas/ lprn
5505 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5506 cd     & ' jj=',jj,' kk=',kk
5507 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5508       do iii=1,2
5509         do jjj=1,2
5510           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5511           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5512         enddo
5513       enddo
5514       call transpose2(aa1(1,1),aa1t(1,1))
5515       call transpose2(aa2(1,1),aa2t(1,1))
5516       do kkk=1,5
5517         do lll=1,3
5518           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5519      &      aa1tder(1,1,lll,kkk))
5520           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5521      &      aa2tder(1,1,lll,kkk))
5522         enddo
5523       enddo
5524       if (l.eq.j+1) then
5525 C parallel orientation of the two CA-CA-CA frames.
5526         if (i.gt.1) then
5527           iti=itortyp(itype(i))
5528         else
5529           iti=ntortyp+1
5530         endif
5531         itk1=itortyp(itype(k+1))
5532         itj=itortyp(itype(j))
5533         if (l.lt.nres-1) then
5534           itl1=itortyp(itype(l+1))
5535         else
5536           itl1=ntortyp+1
5537         endif
5538 C A1 kernel(j+1) A2T
5539 cd        do iii=1,2
5540 cd          write (iout,'(3f10.5,5x,3f10.5)')
5541 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5542 cd        enddo
5543         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5544      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5545      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5546 C Following matrices are needed only for 6-th order cumulants
5547         IF (wcorr6.gt.0.0d0) THEN
5548         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5549      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5550      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5551         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5552      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5553      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5554      &   ADtEAderx(1,1,1,1,1,1))
5555         lprn=.false.
5556         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5557      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5558      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5559      &   ADtEA1derx(1,1,1,1,1,1))
5560         ENDIF
5561 C End 6-th order cumulants
5562 cd        lprn=.false.
5563 cd        if (lprn) then
5564 cd        write (2,*) 'In calc_eello6'
5565 cd        do iii=1,2
5566 cd          write (2,*) 'iii=',iii
5567 cd          do kkk=1,5
5568 cd            write (2,*) 'kkk=',kkk
5569 cd            do jjj=1,2
5570 cd              write (2,'(3(2f10.5),5x)')
5571 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5572 cd            enddo
5573 cd          enddo
5574 cd        enddo
5575 cd        endif
5576         call transpose2(EUgder(1,1,k),auxmat(1,1))
5577         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5578         call transpose2(EUg(1,1,k),auxmat(1,1))
5579         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5580         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5581         do iii=1,2
5582           do kkk=1,5
5583             do lll=1,3
5584               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5585      &          EAEAderx(1,1,lll,kkk,iii,1))
5586             enddo
5587           enddo
5588         enddo
5589 C A1T kernel(i+1) A2
5590         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5591      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5592      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5593 C Following matrices are needed only for 6-th order cumulants
5594         IF (wcorr6.gt.0.0d0) THEN
5595         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5596      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5597      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5598         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5599      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5600      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5601      &   ADtEAderx(1,1,1,1,1,2))
5602         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5603      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5604      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5605      &   ADtEA1derx(1,1,1,1,1,2))
5606         ENDIF
5607 C End 6-th order cumulants
5608         call transpose2(EUgder(1,1,l),auxmat(1,1))
5609         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5610         call transpose2(EUg(1,1,l),auxmat(1,1))
5611         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5612         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5613         do iii=1,2
5614           do kkk=1,5
5615             do lll=1,3
5616               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5617      &          EAEAderx(1,1,lll,kkk,iii,2))
5618             enddo
5619           enddo
5620         enddo
5621 C AEAb1 and AEAb2
5622 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5623 C They are needed only when the fifth- or the sixth-order cumulants are
5624 C indluded.
5625         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5626         call transpose2(AEA(1,1,1),auxmat(1,1))
5627         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5628         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5629         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5630         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5631         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5632         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5633         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5634         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5635         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5636         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5637         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5638         call transpose2(AEA(1,1,2),auxmat(1,1))
5639         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5640         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5641         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5642         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5643         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5644         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5645         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5646         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5647         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5648         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5649         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5650 C Calculate the Cartesian derivatives of the vectors.
5651         do iii=1,2
5652           do kkk=1,5
5653             do lll=1,3
5654               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5655               call matvec2(auxmat(1,1),b1(1,iti),
5656      &          AEAb1derx(1,lll,kkk,iii,1,1))
5657               call matvec2(auxmat(1,1),Ub2(1,i),
5658      &          AEAb2derx(1,lll,kkk,iii,1,1))
5659               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5660      &          AEAb1derx(1,lll,kkk,iii,2,1))
5661               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5662      &          AEAb2derx(1,lll,kkk,iii,2,1))
5663               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5664               call matvec2(auxmat(1,1),b1(1,itj),
5665      &          AEAb1derx(1,lll,kkk,iii,1,2))
5666               call matvec2(auxmat(1,1),Ub2(1,j),
5667      &          AEAb2derx(1,lll,kkk,iii,1,2))
5668               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5669      &          AEAb1derx(1,lll,kkk,iii,2,2))
5670               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5671      &          AEAb2derx(1,lll,kkk,iii,2,2))
5672             enddo
5673           enddo
5674         enddo
5675         ENDIF
5676 C End vectors
5677       else
5678 C Antiparallel orientation of the two CA-CA-CA frames.
5679         if (i.gt.1) then
5680           iti=itortyp(itype(i))
5681         else
5682           iti=ntortyp+1
5683         endif
5684         itk1=itortyp(itype(k+1))
5685         itl=itortyp(itype(l))
5686         itj=itortyp(itype(j))
5687         if (j.lt.nres-1) then
5688           itj1=itortyp(itype(j+1))
5689         else
5690           itj1=ntortyp+1
5691         endif
5692 C A2 kernel(j-1)T A1T
5693         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5694      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5695      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5696 C Following matrices are needed only for 6-th order cumulants
5697         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5698      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5699         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5700      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5701      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5702         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5703      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5704      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5705      &   ADtEAderx(1,1,1,1,1,1))
5706         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5707      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5708      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5709      &   ADtEA1derx(1,1,1,1,1,1))
5710         ENDIF
5711 C End 6-th order cumulants
5712         call transpose2(EUgder(1,1,k),auxmat(1,1))
5713         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5714         call transpose2(EUg(1,1,k),auxmat(1,1))
5715         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5716         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5717         do iii=1,2
5718           do kkk=1,5
5719             do lll=1,3
5720               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5721      &          EAEAderx(1,1,lll,kkk,iii,1))
5722             enddo
5723           enddo
5724         enddo
5725 C A2T kernel(i+1)T A1
5726         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5727      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5728      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5729 C Following matrices are needed only for 6-th order cumulants
5730         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5731      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5732         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5733      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5734      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5735         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5736      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5737      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5738      &   ADtEAderx(1,1,1,1,1,2))
5739         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5740      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5741      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5742      &   ADtEA1derx(1,1,1,1,1,2))
5743         ENDIF
5744 C End 6-th order cumulants
5745         call transpose2(EUgder(1,1,j),auxmat(1,1))
5746         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5747         call transpose2(EUg(1,1,j),auxmat(1,1))
5748         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5749         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5750         do iii=1,2
5751           do kkk=1,5
5752             do lll=1,3
5753               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5754      &          EAEAderx(1,1,lll,kkk,iii,2))
5755             enddo
5756           enddo
5757         enddo
5758 C AEAb1 and AEAb2
5759 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5760 C They are needed only when the fifth- or the sixth-order cumulants are
5761 C indluded.
5762         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5763      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5764         call transpose2(AEA(1,1,1),auxmat(1,1))
5765         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5766         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5767         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5768         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5769         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5770         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5771         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5772         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5773         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5774         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5775         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5776         call transpose2(AEA(1,1,2),auxmat(1,1))
5777         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5778         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5779         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5780         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5781         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5782         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5783         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5784         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5785         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5786         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5787         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5788 C Calculate the Cartesian derivatives of the vectors.
5789         do iii=1,2
5790           do kkk=1,5
5791             do lll=1,3
5792               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5793               call matvec2(auxmat(1,1),b1(1,iti),
5794      &          AEAb1derx(1,lll,kkk,iii,1,1))
5795               call matvec2(auxmat(1,1),Ub2(1,i),
5796      &          AEAb2derx(1,lll,kkk,iii,1,1))
5797               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5798      &          AEAb1derx(1,lll,kkk,iii,2,1))
5799               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5800      &          AEAb2derx(1,lll,kkk,iii,2,1))
5801               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5802               call matvec2(auxmat(1,1),b1(1,itl),
5803      &          AEAb1derx(1,lll,kkk,iii,1,2))
5804               call matvec2(auxmat(1,1),Ub2(1,l),
5805      &          AEAb2derx(1,lll,kkk,iii,1,2))
5806               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5807      &          AEAb1derx(1,lll,kkk,iii,2,2))
5808               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5809      &          AEAb2derx(1,lll,kkk,iii,2,2))
5810             enddo
5811           enddo
5812         enddo
5813         ENDIF
5814 C End vectors
5815       endif
5816       return
5817       end
5818 C---------------------------------------------------------------------------
5819       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5820      &  KK,KKderg,AKA,AKAderg,AKAderx)
5821       implicit none
5822       integer nderg
5823       logical transp
5824       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5825      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5826      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5827       integer iii,kkk,lll
5828       integer jjj,mmm
5829       logical lprn
5830       common /kutas/ lprn
5831       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5832       do iii=1,nderg
5833         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5834      &    AKAderg(1,1,iii))
5835       enddo
5836 cd      if (lprn) write (2,*) 'In kernel'
5837       do kkk=1,5
5838 cd        if (lprn) write (2,*) 'kkk=',kkk
5839         do lll=1,3
5840           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5841      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5842 cd          if (lprn) then
5843 cd            write (2,*) 'lll=',lll
5844 cd            write (2,*) 'iii=1'
5845 cd            do jjj=1,2
5846 cd              write (2,'(3(2f10.5),5x)')
5847 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5848 cd            enddo
5849 cd          endif
5850           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5851      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5852 cd          if (lprn) then
5853 cd            write (2,*) 'lll=',lll
5854 cd            write (2,*) 'iii=2'
5855 cd            do jjj=1,2
5856 cd              write (2,'(3(2f10.5),5x)')
5857 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5858 cd            enddo
5859 cd          endif
5860         enddo
5861       enddo
5862       return
5863       end
5864 C---------------------------------------------------------------------------
5865       double precision function eello4(i,j,k,l,jj,kk)
5866       implicit real*8 (a-h,o-z)
5867       include 'DIMENSIONS'
5868       include 'sizesclu.dat'
5869       include 'COMMON.IOUNITS'
5870       include 'COMMON.CHAIN'
5871       include 'COMMON.DERIV'
5872       include 'COMMON.INTERACT'
5873       include 'COMMON.CONTACTS'
5874       include 'COMMON.TORSION'
5875       include 'COMMON.VAR'
5876       include 'COMMON.GEO'
5877       double precision pizda(2,2),ggg1(3),ggg2(3)
5878 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5879 cd        eello4=0.0d0
5880 cd        return
5881 cd      endif
5882 cd      print *,'eello4:',i,j,k,l,jj,kk
5883 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5884 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5885 cold      eij=facont_hb(jj,i)
5886 cold      ekl=facont_hb(kk,k)
5887 cold      ekont=eij*ekl
5888       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5889       if (calc_grad) then
5890 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5891       gcorr_loc(k-1)=gcorr_loc(k-1)
5892      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5893       if (l.eq.j+1) then
5894         gcorr_loc(l-1)=gcorr_loc(l-1)
5895      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5896       else
5897         gcorr_loc(j-1)=gcorr_loc(j-1)
5898      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5899       endif
5900       do iii=1,2
5901         do kkk=1,5
5902           do lll=1,3
5903             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5904      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5905 cd            derx(lll,kkk,iii)=0.0d0
5906           enddo
5907         enddo
5908       enddo
5909 cd      gcorr_loc(l-1)=0.0d0
5910 cd      gcorr_loc(j-1)=0.0d0
5911 cd      gcorr_loc(k-1)=0.0d0
5912 cd      eel4=1.0d0
5913 cd      write (iout,*)'Contacts have occurred for peptide groups',
5914 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5915 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5916       if (j.lt.nres-1) then
5917         j1=j+1
5918         j2=j-1
5919       else
5920         j1=j-1
5921         j2=j-2
5922       endif
5923       if (l.lt.nres-1) then
5924         l1=l+1
5925         l2=l-1
5926       else
5927         l1=l-1
5928         l2=l-2
5929       endif
5930       do ll=1,3
5931 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5932         ggg1(ll)=eel4*g_contij(ll,1)
5933         ggg2(ll)=eel4*g_contij(ll,2)
5934         ghalf=0.5d0*ggg1(ll)
5935 cd        ghalf=0.0d0
5936         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5937         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5938         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5939         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5940 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5941         ghalf=0.5d0*ggg2(ll)
5942 cd        ghalf=0.0d0
5943         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5944         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5945         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5946         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5947       enddo
5948 cd      goto 1112
5949       do m=i+1,j-1
5950         do ll=1,3
5951 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5952           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5953         enddo
5954       enddo
5955       do m=k+1,l-1
5956         do ll=1,3
5957 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5958           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5959         enddo
5960       enddo
5961 1112  continue
5962       do m=i+2,j2
5963         do ll=1,3
5964           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5965         enddo
5966       enddo
5967       do m=k+2,l2
5968         do ll=1,3
5969           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5970         enddo
5971       enddo
5972 cd      do iii=1,nres-3
5973 cd        write (2,*) iii,gcorr_loc(iii)
5974 cd      enddo
5975       endif
5976       eello4=ekont*eel4
5977 cd      write (2,*) 'ekont',ekont
5978 cd      write (iout,*) 'eello4',ekont*eel4
5979       return
5980       end
5981 C---------------------------------------------------------------------------
5982       double precision function eello5(i,j,k,l,jj,kk)
5983       implicit real*8 (a-h,o-z)
5984       include 'DIMENSIONS'
5985       include 'sizesclu.dat'
5986       include 'COMMON.IOUNITS'
5987       include 'COMMON.CHAIN'
5988       include 'COMMON.DERIV'
5989       include 'COMMON.INTERACT'
5990       include 'COMMON.CONTACTS'
5991       include 'COMMON.TORSION'
5992       include 'COMMON.VAR'
5993       include 'COMMON.GEO'
5994       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5995       double precision ggg1(3),ggg2(3)
5996 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5997 C                                                                              C
5998 C                            Parallel chains                                   C
5999 C                                                                              C
6000 C          o             o                   o             o                   C
6001 C         /l\           / \             \   / \           / \   /              C
6002 C        /   \         /   \             \ /   \         /   \ /               C
6003 C       j| o |l1       | o |              o| o |         | o |o                C
6004 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6005 C      \i/   \         /   \ /             /   \         /   \                 C
6006 C       o    k1             o                                                  C
6007 C         (I)          (II)                (III)          (IV)                 C
6008 C                                                                              C
6009 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6010 C                                                                              C
6011 C                            Antiparallel chains                               C
6012 C                                                                              C
6013 C          o             o                   o             o                   C
6014 C         /j\           / \             \   / \           / \   /              C
6015 C        /   \         /   \             \ /   \         /   \ /               C
6016 C      j1| o |l        | o |              o| o |         | o |o                C
6017 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6018 C      \i/   \         /   \ /             /   \         /   \                 C
6019 C       o     k1            o                                                  C
6020 C         (I)          (II)                (III)          (IV)                 C
6021 C                                                                              C
6022 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6023 C                                                                              C
6024 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6025 C                                                                              C
6026 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6027 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6028 cd        eello5=0.0d0
6029 cd        return
6030 cd      endif
6031 cd      write (iout,*)
6032 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6033 cd     &   ' and',k,l
6034       itk=itortyp(itype(k))
6035       itl=itortyp(itype(l))
6036       itj=itortyp(itype(j))
6037       eello5_1=0.0d0
6038       eello5_2=0.0d0
6039       eello5_3=0.0d0
6040       eello5_4=0.0d0
6041 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6042 cd     &   eel5_3_num,eel5_4_num)
6043       do iii=1,2
6044         do kkk=1,5
6045           do lll=1,3
6046             derx(lll,kkk,iii)=0.0d0
6047           enddo
6048         enddo
6049       enddo
6050 cd      eij=facont_hb(jj,i)
6051 cd      ekl=facont_hb(kk,k)
6052 cd      ekont=eij*ekl
6053 cd      write (iout,*)'Contacts have occurred for peptide groups',
6054 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6055 cd      goto 1111
6056 C Contribution from the graph I.
6057 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6058 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6059       call transpose2(EUg(1,1,k),auxmat(1,1))
6060       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6061       vv(1)=pizda(1,1)-pizda(2,2)
6062       vv(2)=pizda(1,2)+pizda(2,1)
6063       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6064      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6065       if (calc_grad) then
6066 C Explicit gradient in virtual-dihedral angles.
6067       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6068      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6069      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6070       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6071       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6072       vv(1)=pizda(1,1)-pizda(2,2)
6073       vv(2)=pizda(1,2)+pizda(2,1)
6074       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6075      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6076      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6077       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6078       vv(1)=pizda(1,1)-pizda(2,2)
6079       vv(2)=pizda(1,2)+pizda(2,1)
6080       if (l.eq.j+1) then
6081         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6082      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6083      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6084       else
6085         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6086      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6087      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6088       endif
6089 C Cartesian gradient
6090       do iii=1,2
6091         do kkk=1,5
6092           do lll=1,3
6093             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6094      &        pizda(1,1))
6095             vv(1)=pizda(1,1)-pizda(2,2)
6096             vv(2)=pizda(1,2)+pizda(2,1)
6097             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6098      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6099      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6100           enddo
6101         enddo
6102       enddo
6103 c      goto 1112
6104       endif
6105 c1111  continue
6106 C Contribution from graph II
6107       call transpose2(EE(1,1,itk),auxmat(1,1))
6108       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6109       vv(1)=pizda(1,1)+pizda(2,2)
6110       vv(2)=pizda(2,1)-pizda(1,2)
6111       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6112      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6113       if (calc_grad) then
6114 C Explicit gradient in virtual-dihedral angles.
6115       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6116      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6117       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6118       vv(1)=pizda(1,1)+pizda(2,2)
6119       vv(2)=pizda(2,1)-pizda(1,2)
6120       if (l.eq.j+1) then
6121         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6122      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6123      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6124       else
6125         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6126      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6127      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6128       endif
6129 C Cartesian gradient
6130       do iii=1,2
6131         do kkk=1,5
6132           do lll=1,3
6133             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6134      &        pizda(1,1))
6135             vv(1)=pizda(1,1)+pizda(2,2)
6136             vv(2)=pizda(2,1)-pizda(1,2)
6137             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6138      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6139      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6140           enddo
6141         enddo
6142       enddo
6143 cd      goto 1112
6144       endif
6145 cd1111  continue
6146       if (l.eq.j+1) then
6147 cd        goto 1110
6148 C Parallel orientation
6149 C Contribution from graph III
6150         call transpose2(EUg(1,1,l),auxmat(1,1))
6151         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6152         vv(1)=pizda(1,1)-pizda(2,2)
6153         vv(2)=pizda(1,2)+pizda(2,1)
6154         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6155      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6156         if (calc_grad) then
6157 C Explicit gradient in virtual-dihedral angles.
6158         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6159      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6160      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6161         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6162         vv(1)=pizda(1,1)-pizda(2,2)
6163         vv(2)=pizda(1,2)+pizda(2,1)
6164         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6165      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6166      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6167         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6168         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6169         vv(1)=pizda(1,1)-pizda(2,2)
6170         vv(2)=pizda(1,2)+pizda(2,1)
6171         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6172      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6173      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6174 C Cartesian gradient
6175         do iii=1,2
6176           do kkk=1,5
6177             do lll=1,3
6178               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6179      &          pizda(1,1))
6180               vv(1)=pizda(1,1)-pizda(2,2)
6181               vv(2)=pizda(1,2)+pizda(2,1)
6182               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6183      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6184      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6185             enddo
6186           enddo
6187         enddo
6188 cd        goto 1112
6189         endif
6190 C Contribution from graph IV
6191 cd1110    continue
6192         call transpose2(EE(1,1,itl),auxmat(1,1))
6193         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6194         vv(1)=pizda(1,1)+pizda(2,2)
6195         vv(2)=pizda(2,1)-pizda(1,2)
6196         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6197      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6198         if (calc_grad) then
6199 C Explicit gradient in virtual-dihedral angles.
6200         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6201      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6202         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6203         vv(1)=pizda(1,1)+pizda(2,2)
6204         vv(2)=pizda(2,1)-pizda(1,2)
6205         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6206      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6207      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6208 C Cartesian gradient
6209         do iii=1,2
6210           do kkk=1,5
6211             do lll=1,3
6212               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6213      &          pizda(1,1))
6214               vv(1)=pizda(1,1)+pizda(2,2)
6215               vv(2)=pizda(2,1)-pizda(1,2)
6216               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6217      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6218      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6219             enddo
6220           enddo
6221         enddo
6222         endif
6223       else
6224 C Antiparallel orientation
6225 C Contribution from graph III
6226 c        goto 1110
6227         call transpose2(EUg(1,1,j),auxmat(1,1))
6228         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6229         vv(1)=pizda(1,1)-pizda(2,2)
6230         vv(2)=pizda(1,2)+pizda(2,1)
6231         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6232      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6233         if (calc_grad) then
6234 C Explicit gradient in virtual-dihedral angles.
6235         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6236      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6237      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6238         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6239         vv(1)=pizda(1,1)-pizda(2,2)
6240         vv(2)=pizda(1,2)+pizda(2,1)
6241         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6242      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6243      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6244         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6245         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6246         vv(1)=pizda(1,1)-pizda(2,2)
6247         vv(2)=pizda(1,2)+pizda(2,1)
6248         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6249      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6250      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6251 C Cartesian gradient
6252         do iii=1,2
6253           do kkk=1,5
6254             do lll=1,3
6255               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6256      &          pizda(1,1))
6257               vv(1)=pizda(1,1)-pizda(2,2)
6258               vv(2)=pizda(1,2)+pizda(2,1)
6259               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6260      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6261      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6262             enddo
6263           enddo
6264         enddo
6265 cd        goto 1112
6266         endif
6267 C Contribution from graph IV
6268 1110    continue
6269         call transpose2(EE(1,1,itj),auxmat(1,1))
6270         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6271         vv(1)=pizda(1,1)+pizda(2,2)
6272         vv(2)=pizda(2,1)-pizda(1,2)
6273         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6274      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6275         if (calc_grad) then
6276 C Explicit gradient in virtual-dihedral angles.
6277         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6278      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6279         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6280         vv(1)=pizda(1,1)+pizda(2,2)
6281         vv(2)=pizda(2,1)-pizda(1,2)
6282         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6283      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6284      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6285 C Cartesian gradient
6286         do iii=1,2
6287           do kkk=1,5
6288             do lll=1,3
6289               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6290      &          pizda(1,1))
6291               vv(1)=pizda(1,1)+pizda(2,2)
6292               vv(2)=pizda(2,1)-pizda(1,2)
6293               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6294      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6295      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6296             enddo
6297           enddo
6298         enddo
6299       endif
6300       endif
6301 1112  continue
6302       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6303 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6304 cd        write (2,*) 'ijkl',i,j,k,l
6305 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6306 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6307 cd      endif
6308 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6309 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6310 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6311 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6312       if (calc_grad) then
6313       if (j.lt.nres-1) then
6314         j1=j+1
6315         j2=j-1
6316       else
6317         j1=j-1
6318         j2=j-2
6319       endif
6320       if (l.lt.nres-1) then
6321         l1=l+1
6322         l2=l-1
6323       else
6324         l1=l-1
6325         l2=l-2
6326       endif
6327 cd      eij=1.0d0
6328 cd      ekl=1.0d0
6329 cd      ekont=1.0d0
6330 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6331       do ll=1,3
6332         ggg1(ll)=eel5*g_contij(ll,1)
6333         ggg2(ll)=eel5*g_contij(ll,2)
6334 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6335         ghalf=0.5d0*ggg1(ll)
6336 cd        ghalf=0.0d0
6337         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6338         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6339         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6340         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6341 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6342         ghalf=0.5d0*ggg2(ll)
6343 cd        ghalf=0.0d0
6344         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6345         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6346         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6347         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6348       enddo
6349 cd      goto 1112
6350       do m=i+1,j-1
6351         do ll=1,3
6352 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6353           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6354         enddo
6355       enddo
6356       do m=k+1,l-1
6357         do ll=1,3
6358 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6359           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6360         enddo
6361       enddo
6362 c1112  continue
6363       do m=i+2,j2
6364         do ll=1,3
6365           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6366         enddo
6367       enddo
6368       do m=k+2,l2
6369         do ll=1,3
6370           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6371         enddo
6372       enddo
6373 cd      do iii=1,nres-3
6374 cd        write (2,*) iii,g_corr5_loc(iii)
6375 cd      enddo
6376       endif
6377       eello5=ekont*eel5
6378 cd      write (2,*) 'ekont',ekont
6379 cd      write (iout,*) 'eello5',ekont*eel5
6380       return
6381       end
6382 c--------------------------------------------------------------------------
6383       double precision function eello6(i,j,k,l,jj,kk)
6384       implicit real*8 (a-h,o-z)
6385       include 'DIMENSIONS'
6386       include 'sizesclu.dat'
6387       include 'COMMON.IOUNITS'
6388       include 'COMMON.CHAIN'
6389       include 'COMMON.DERIV'
6390       include 'COMMON.INTERACT'
6391       include 'COMMON.CONTACTS'
6392       include 'COMMON.TORSION'
6393       include 'COMMON.VAR'
6394       include 'COMMON.GEO'
6395       include 'COMMON.FFIELD'
6396       double precision ggg1(3),ggg2(3)
6397 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6398 cd        eello6=0.0d0
6399 cd        return
6400 cd      endif
6401 cd      write (iout,*)
6402 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6403 cd     &   ' and',k,l
6404       eello6_1=0.0d0
6405       eello6_2=0.0d0
6406       eello6_3=0.0d0
6407       eello6_4=0.0d0
6408       eello6_5=0.0d0
6409       eello6_6=0.0d0
6410 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6411 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6412       do iii=1,2
6413         do kkk=1,5
6414           do lll=1,3
6415             derx(lll,kkk,iii)=0.0d0
6416           enddo
6417         enddo
6418       enddo
6419 cd      eij=facont_hb(jj,i)
6420 cd      ekl=facont_hb(kk,k)
6421 cd      ekont=eij*ekl
6422 cd      eij=1.0d0
6423 cd      ekl=1.0d0
6424 cd      ekont=1.0d0
6425       if (l.eq.j+1) then
6426         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6427         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6428         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6429         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6430         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6431         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6432       else
6433         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6434         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6435         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6436         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6437         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6438           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6439         else
6440           eello6_5=0.0d0
6441         endif
6442         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6443       endif
6444 C If turn contributions are considered, they will be handled separately.
6445       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6446 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6447 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6448 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6449 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6450 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6451 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6452 cd      goto 1112
6453       if (calc_grad) then
6454       if (j.lt.nres-1) then
6455         j1=j+1
6456         j2=j-1
6457       else
6458         j1=j-1
6459         j2=j-2
6460       endif
6461       if (l.lt.nres-1) then
6462         l1=l+1
6463         l2=l-1
6464       else
6465         l1=l-1
6466         l2=l-2
6467       endif
6468       do ll=1,3
6469         ggg1(ll)=eel6*g_contij(ll,1)
6470         ggg2(ll)=eel6*g_contij(ll,2)
6471 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6472         ghalf=0.5d0*ggg1(ll)
6473 cd        ghalf=0.0d0
6474         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6475         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6476         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6477         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6478         ghalf=0.5d0*ggg2(ll)
6479 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6480 cd        ghalf=0.0d0
6481         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6482         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6483         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6484         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6485       enddo
6486 cd      goto 1112
6487       do m=i+1,j-1
6488         do ll=1,3
6489 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6490           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6491         enddo
6492       enddo
6493       do m=k+1,l-1
6494         do ll=1,3
6495 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6496           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6497         enddo
6498       enddo
6499 1112  continue
6500       do m=i+2,j2
6501         do ll=1,3
6502           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6503         enddo
6504       enddo
6505       do m=k+2,l2
6506         do ll=1,3
6507           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6508         enddo
6509       enddo
6510 cd      do iii=1,nres-3
6511 cd        write (2,*) iii,g_corr6_loc(iii)
6512 cd      enddo
6513       endif
6514       eello6=ekont*eel6
6515 cd      write (2,*) 'ekont',ekont
6516 cd      write (iout,*) 'eello6',ekont*eel6
6517       return
6518       end
6519 c--------------------------------------------------------------------------
6520       double precision function eello6_graph1(i,j,k,l,imat,swap)
6521       implicit real*8 (a-h,o-z)
6522       include 'DIMENSIONS'
6523       include 'sizesclu.dat'
6524       include 'COMMON.IOUNITS'
6525       include 'COMMON.CHAIN'
6526       include 'COMMON.DERIV'
6527       include 'COMMON.INTERACT'
6528       include 'COMMON.CONTACTS'
6529       include 'COMMON.TORSION'
6530       include 'COMMON.VAR'
6531       include 'COMMON.GEO'
6532       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6533       logical swap
6534       logical lprn
6535       common /kutas/ lprn
6536 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6537 C                                                                              C
6538 C      Parallel       Antiparallel                                             C
6539 C                                                                              C
6540 C          o             o                                                     C
6541 C         /l\           /j\                                                    C
6542 C        /   \         /   \                                                   C
6543 C       /| o |         | o |\                                                  C
6544 C     \ j|/k\|  /   \  |/k\|l /                                                C
6545 C      \ /   \ /     \ /   \ /                                                 C
6546 C       o     o       o     o                                                  C
6547 C       i             i                                                        C
6548 C                                                                              C
6549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6550       itk=itortyp(itype(k))
6551       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6552       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6553       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6554       call transpose2(EUgC(1,1,k),auxmat(1,1))
6555       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6556       vv1(1)=pizda1(1,1)-pizda1(2,2)
6557       vv1(2)=pizda1(1,2)+pizda1(2,1)
6558       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6559       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6560       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6561       s5=scalar2(vv(1),Dtobr2(1,i))
6562 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6563       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6564       if (.not. calc_grad) return
6565       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6566      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6567      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6568      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6569      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6570      & +scalar2(vv(1),Dtobr2der(1,i)))
6571       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6572       vv1(1)=pizda1(1,1)-pizda1(2,2)
6573       vv1(2)=pizda1(1,2)+pizda1(2,1)
6574       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6575       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6576       if (l.eq.j+1) then
6577         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6578      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6579      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6580      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6581      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6582       else
6583         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6584      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6585      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6586      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6587      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6588       endif
6589       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6590       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6591       vv1(1)=pizda1(1,1)-pizda1(2,2)
6592       vv1(2)=pizda1(1,2)+pizda1(2,1)
6593       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6594      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6595      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6596      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6597       do iii=1,2
6598         if (swap) then
6599           ind=3-iii
6600         else
6601           ind=iii
6602         endif
6603         do kkk=1,5
6604           do lll=1,3
6605             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6606             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6607             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6608             call transpose2(EUgC(1,1,k),auxmat(1,1))
6609             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6610      &        pizda1(1,1))
6611             vv1(1)=pizda1(1,1)-pizda1(2,2)
6612             vv1(2)=pizda1(1,2)+pizda1(2,1)
6613             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6614             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6615      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6616             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6617      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6618             s5=scalar2(vv(1),Dtobr2(1,i))
6619             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6620           enddo
6621         enddo
6622       enddo
6623       return
6624       end
6625 c----------------------------------------------------------------------------
6626       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6627       implicit real*8 (a-h,o-z)
6628       include 'DIMENSIONS'
6629       include 'sizesclu.dat'
6630       include 'COMMON.IOUNITS'
6631       include 'COMMON.CHAIN'
6632       include 'COMMON.DERIV'
6633       include 'COMMON.INTERACT'
6634       include 'COMMON.CONTACTS'
6635       include 'COMMON.TORSION'
6636       include 'COMMON.VAR'
6637       include 'COMMON.GEO'
6638       logical swap
6639       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6640      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6641       logical lprn
6642       common /kutas/ lprn
6643 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6644 C                                                                              C
6645 C      Parallel       Antiparallel                                             C
6646 C                                                                              C
6647 C          o             o                                                     C
6648 C     \   /l\           /j\   /                                                C
6649 C      \ /   \         /   \ /                                                 C
6650 C       o| o |         | o |o                                                  C
6651 C     \ j|/k\|      \  |/k\|l                                                  C
6652 C      \ /   \       \ /   \                                                   C
6653 C       o             o                                                        C
6654 C       i             i                                                        C
6655 C                                                                              C
6656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6657 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6658 C AL 7/4/01 s1 would occur in the sixth-order moment,
6659 C           but not in a cluster cumulant
6660 #ifdef MOMENT
6661       s1=dip(1,jj,i)*dip(1,kk,k)
6662 #endif
6663       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6664       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6665       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6666       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6667       call transpose2(EUg(1,1,k),auxmat(1,1))
6668       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6669       vv(1)=pizda(1,1)-pizda(2,2)
6670       vv(2)=pizda(1,2)+pizda(2,1)
6671       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6672 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6673 #ifdef MOMENT
6674       eello6_graph2=-(s1+s2+s3+s4)
6675 #else
6676       eello6_graph2=-(s2+s3+s4)
6677 #endif
6678 c      eello6_graph2=-s3
6679       if (.not. calc_grad) return
6680 C Derivatives in gamma(i-1)
6681       if (i.gt.1) then
6682 #ifdef MOMENT
6683         s1=dipderg(1,jj,i)*dip(1,kk,k)
6684 #endif
6685         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6686         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6687         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6688         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6689 #ifdef MOMENT
6690         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6691 #else
6692         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6693 #endif
6694 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6695       endif
6696 C Derivatives in gamma(k-1)
6697 #ifdef MOMENT
6698       s1=dip(1,jj,i)*dipderg(1,kk,k)
6699 #endif
6700       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6701       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6702       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6703       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6704       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6705       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6706       vv(1)=pizda(1,1)-pizda(2,2)
6707       vv(2)=pizda(1,2)+pizda(2,1)
6708       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6709 #ifdef MOMENT
6710       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6711 #else
6712       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6713 #endif
6714 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6715 C Derivatives in gamma(j-1) or gamma(l-1)
6716       if (j.gt.1) then
6717 #ifdef MOMENT
6718         s1=dipderg(3,jj,i)*dip(1,kk,k)
6719 #endif
6720         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6721         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6722         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6723         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6724         vv(1)=pizda(1,1)-pizda(2,2)
6725         vv(2)=pizda(1,2)+pizda(2,1)
6726         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6727 #ifdef MOMENT
6728         if (swap) then
6729           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6730         else
6731           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6732         endif
6733 #endif
6734         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6735 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6736       endif
6737 C Derivatives in gamma(l-1) or gamma(j-1)
6738       if (l.gt.1) then
6739 #ifdef MOMENT
6740         s1=dip(1,jj,i)*dipderg(3,kk,k)
6741 #endif
6742         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6743         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6744         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6745         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6746         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6747         vv(1)=pizda(1,1)-pizda(2,2)
6748         vv(2)=pizda(1,2)+pizda(2,1)
6749         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6750 #ifdef MOMENT
6751         if (swap) then
6752           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6753         else
6754           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6755         endif
6756 #endif
6757         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6758 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6759       endif
6760 C Cartesian derivatives.
6761       if (lprn) then
6762         write (2,*) 'In eello6_graph2'
6763         do iii=1,2
6764           write (2,*) 'iii=',iii
6765           do kkk=1,5
6766             write (2,*) 'kkk=',kkk
6767             do jjj=1,2
6768               write (2,'(3(2f10.5),5x)')
6769      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6770             enddo
6771           enddo
6772         enddo
6773       endif
6774       do iii=1,2
6775         do kkk=1,5
6776           do lll=1,3
6777 #ifdef MOMENT
6778             if (iii.eq.1) then
6779               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6780             else
6781               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6782             endif
6783 #endif
6784             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6785      &        auxvec(1))
6786             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6787             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6788      &        auxvec(1))
6789             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6790             call transpose2(EUg(1,1,k),auxmat(1,1))
6791             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6792      &        pizda(1,1))
6793             vv(1)=pizda(1,1)-pizda(2,2)
6794             vv(2)=pizda(1,2)+pizda(2,1)
6795             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6796 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6797 #ifdef MOMENT
6798             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6799 #else
6800             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6801 #endif
6802             if (swap) then
6803               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6804             else
6805               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6806             endif
6807           enddo
6808         enddo
6809       enddo
6810       return
6811       end
6812 c----------------------------------------------------------------------------
6813       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6814       implicit real*8 (a-h,o-z)
6815       include 'DIMENSIONS'
6816       include 'sizesclu.dat'
6817       include 'COMMON.IOUNITS'
6818       include 'COMMON.CHAIN'
6819       include 'COMMON.DERIV'
6820       include 'COMMON.INTERACT'
6821       include 'COMMON.CONTACTS'
6822       include 'COMMON.TORSION'
6823       include 'COMMON.VAR'
6824       include 'COMMON.GEO'
6825       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6826       logical swap
6827 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6828 C                                                                              C
6829 C      Parallel       Antiparallel                                             C
6830 C                                                                              C
6831 C          o             o                                                     C
6832 C         /l\   /   \   /j\                                                    C
6833 C        /   \ /     \ /   \                                                   C
6834 C       /| o |o       o| o |\                                                  C
6835 C       j|/k\|  /      |/k\|l /                                                C
6836 C        /   \ /       /   \ /                                                 C
6837 C       /     o       /     o                                                  C
6838 C       i             i                                                        C
6839 C                                                                              C
6840 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6841 C
6842 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6843 C           energy moment and not to the cluster cumulant.
6844       iti=itortyp(itype(i))
6845       if (j.lt.nres-1) then
6846         itj1=itortyp(itype(j+1))
6847       else
6848         itj1=ntortyp+1
6849       endif
6850       itk=itortyp(itype(k))
6851       itk1=itortyp(itype(k+1))
6852       if (l.lt.nres-1) then
6853         itl1=itortyp(itype(l+1))
6854       else
6855         itl1=ntortyp+1
6856       endif
6857 #ifdef MOMENT
6858       s1=dip(4,jj,i)*dip(4,kk,k)
6859 #endif
6860       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6861       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6862       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6863       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6864       call transpose2(EE(1,1,itk),auxmat(1,1))
6865       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6866       vv(1)=pizda(1,1)+pizda(2,2)
6867       vv(2)=pizda(2,1)-pizda(1,2)
6868       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6869 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6870 #ifdef MOMENT
6871       eello6_graph3=-(s1+s2+s3+s4)
6872 #else
6873       eello6_graph3=-(s2+s3+s4)
6874 #endif
6875 c      eello6_graph3=-s4
6876       if (.not. calc_grad) return
6877 C Derivatives in gamma(k-1)
6878       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6879       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6880       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6881       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6882 C Derivatives in gamma(l-1)
6883       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6884       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6885       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6886       vv(1)=pizda(1,1)+pizda(2,2)
6887       vv(2)=pizda(2,1)-pizda(1,2)
6888       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6889       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6890 C Cartesian derivatives.
6891       do iii=1,2
6892         do kkk=1,5
6893           do lll=1,3
6894 #ifdef MOMENT
6895             if (iii.eq.1) then
6896               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6897             else
6898               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6899             endif
6900 #endif
6901             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6902      &        auxvec(1))
6903             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6904             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6905      &        auxvec(1))
6906             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6907             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6908      &        pizda(1,1))
6909             vv(1)=pizda(1,1)+pizda(2,2)
6910             vv(2)=pizda(2,1)-pizda(1,2)
6911             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6912 #ifdef MOMENT
6913             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6914 #else
6915             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6916 #endif
6917             if (swap) then
6918               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6919             else
6920               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6921             endif
6922 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6923           enddo
6924         enddo
6925       enddo
6926       return
6927       end
6928 c----------------------------------------------------------------------------
6929       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6930       implicit real*8 (a-h,o-z)
6931       include 'DIMENSIONS'
6932       include 'sizesclu.dat'
6933       include 'COMMON.IOUNITS'
6934       include 'COMMON.CHAIN'
6935       include 'COMMON.DERIV'
6936       include 'COMMON.INTERACT'
6937       include 'COMMON.CONTACTS'
6938       include 'COMMON.TORSION'
6939       include 'COMMON.VAR'
6940       include 'COMMON.GEO'
6941       include 'COMMON.FFIELD'
6942       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6943      & auxvec1(2),auxmat1(2,2)
6944       logical swap
6945 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6946 C                                                                              C
6947 C      Parallel       Antiparallel                                             C
6948 C                                                                              C
6949 C          o             o                                                     C
6950 C         /l\   /   \   /j\                                                    C
6951 C        /   \ /     \ /   \                                                   C
6952 C       /| o |o       o| o |\                                                  C
6953 C     \ j|/k\|      \  |/k\|l                                                  C
6954 C      \ /   \       \ /   \                                                   C
6955 C       o     \       o     \                                                  C
6956 C       i             i                                                        C
6957 C                                                                              C
6958 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6959 C
6960 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6961 C           energy moment and not to the cluster cumulant.
6962 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6963       iti=itortyp(itype(i))
6964       itj=itortyp(itype(j))
6965       if (j.lt.nres-1) then
6966         itj1=itortyp(itype(j+1))
6967       else
6968         itj1=ntortyp+1
6969       endif
6970       itk=itortyp(itype(k))
6971       if (k.lt.nres-1) then
6972         itk1=itortyp(itype(k+1))
6973       else
6974         itk1=ntortyp+1
6975       endif
6976       itl=itortyp(itype(l))
6977       if (l.lt.nres-1) then
6978         itl1=itortyp(itype(l+1))
6979       else
6980         itl1=ntortyp+1
6981       endif
6982 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6983 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6984 cd     & ' itl',itl,' itl1',itl1
6985 #ifdef MOMENT
6986       if (imat.eq.1) then
6987         s1=dip(3,jj,i)*dip(3,kk,k)
6988       else
6989         s1=dip(2,jj,j)*dip(2,kk,l)
6990       endif
6991 #endif
6992       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6993       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6994       if (j.eq.l+1) then
6995         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6996         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6997       else
6998         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6999         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7000       endif
7001       call transpose2(EUg(1,1,k),auxmat(1,1))
7002       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7003       vv(1)=pizda(1,1)-pizda(2,2)
7004       vv(2)=pizda(2,1)+pizda(1,2)
7005       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7006 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7007 #ifdef MOMENT
7008       eello6_graph4=-(s1+s2+s3+s4)
7009 #else
7010       eello6_graph4=-(s2+s3+s4)
7011 #endif
7012       if (.not. calc_grad) return
7013 C Derivatives in gamma(i-1)
7014       if (i.gt.1) then
7015 #ifdef MOMENT
7016         if (imat.eq.1) then
7017           s1=dipderg(2,jj,i)*dip(3,kk,k)
7018         else
7019           s1=dipderg(4,jj,j)*dip(2,kk,l)
7020         endif
7021 #endif
7022         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7023         if (j.eq.l+1) then
7024           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7025           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7026         else
7027           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7028           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7029         endif
7030         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7031         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7032 cd          write (2,*) 'turn6 derivatives'
7033 #ifdef MOMENT
7034           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7035 #else
7036           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7037 #endif
7038         else
7039 #ifdef MOMENT
7040           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7041 #else
7042           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7043 #endif
7044         endif
7045       endif
7046 C Derivatives in gamma(k-1)
7047 #ifdef MOMENT
7048       if (imat.eq.1) then
7049         s1=dip(3,jj,i)*dipderg(2,kk,k)
7050       else
7051         s1=dip(2,jj,j)*dipderg(4,kk,l)
7052       endif
7053 #endif
7054       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7055       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7056       if (j.eq.l+1) then
7057         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7058         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7059       else
7060         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7061         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7062       endif
7063       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7064       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7065       vv(1)=pizda(1,1)-pizda(2,2)
7066       vv(2)=pizda(2,1)+pizda(1,2)
7067       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7068       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7069 #ifdef MOMENT
7070         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7071 #else
7072         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7073 #endif
7074       else
7075 #ifdef MOMENT
7076         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7077 #else
7078         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7079 #endif
7080       endif
7081 C Derivatives in gamma(j-1) or gamma(l-1)
7082       if (l.eq.j+1 .and. l.gt.1) then
7083         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7084         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7085         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7086         vv(1)=pizda(1,1)-pizda(2,2)
7087         vv(2)=pizda(2,1)+pizda(1,2)
7088         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7089         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7090       else if (j.gt.1) then
7091         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7092         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7093         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7094         vv(1)=pizda(1,1)-pizda(2,2)
7095         vv(2)=pizda(2,1)+pizda(1,2)
7096         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7097         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7098           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7099         else
7100           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7101         endif
7102       endif
7103 C Cartesian derivatives.
7104       do iii=1,2
7105         do kkk=1,5
7106           do lll=1,3
7107 #ifdef MOMENT
7108             if (iii.eq.1) then
7109               if (imat.eq.1) then
7110                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7111               else
7112                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7113               endif
7114             else
7115               if (imat.eq.1) then
7116                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7117               else
7118                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7119               endif
7120             endif
7121 #endif
7122             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7123      &        auxvec(1))
7124             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7125             if (j.eq.l+1) then
7126               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7127      &          b1(1,itj1),auxvec(1))
7128               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7129             else
7130               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7131      &          b1(1,itl1),auxvec(1))
7132               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7133             endif
7134             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7135      &        pizda(1,1))
7136             vv(1)=pizda(1,1)-pizda(2,2)
7137             vv(2)=pizda(2,1)+pizda(1,2)
7138             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7139             if (swap) then
7140               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7141 #ifdef MOMENT
7142                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7143      &             -(s1+s2+s4)
7144 #else
7145                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7146      &             -(s2+s4)
7147 #endif
7148                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7149               else
7150 #ifdef MOMENT
7151                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7152 #else
7153                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7154 #endif
7155                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7156               endif
7157             else
7158 #ifdef MOMENT
7159               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7160 #else
7161               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7162 #endif
7163               if (l.eq.j+1) then
7164                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7165               else
7166                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7167               endif
7168             endif
7169           enddo
7170         enddo
7171       enddo
7172       return
7173       end
7174 c----------------------------------------------------------------------------
7175       double precision function eello_turn6(i,jj,kk)
7176       implicit real*8 (a-h,o-z)
7177       include 'DIMENSIONS'
7178       include 'sizesclu.dat'
7179       include 'COMMON.IOUNITS'
7180       include 'COMMON.CHAIN'
7181       include 'COMMON.DERIV'
7182       include 'COMMON.INTERACT'
7183       include 'COMMON.CONTACTS'
7184       include 'COMMON.TORSION'
7185       include 'COMMON.VAR'
7186       include 'COMMON.GEO'
7187       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7188      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7189      &  ggg1(3),ggg2(3)
7190       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7191      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7192 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7193 C           the respective energy moment and not to the cluster cumulant.
7194       eello_turn6=0.0d0
7195       j=i+4
7196       k=i+1
7197       l=i+3
7198       iti=itortyp(itype(i))
7199       itk=itortyp(itype(k))
7200       itk1=itortyp(itype(k+1))
7201       itl=itortyp(itype(l))
7202       itj=itortyp(itype(j))
7203 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7204 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7205 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7206 cd        eello6=0.0d0
7207 cd        return
7208 cd      endif
7209 cd      write (iout,*)
7210 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7211 cd     &   ' and',k,l
7212 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7213       do iii=1,2
7214         do kkk=1,5
7215           do lll=1,3
7216             derx_turn(lll,kkk,iii)=0.0d0
7217           enddo
7218         enddo
7219       enddo
7220 cd      eij=1.0d0
7221 cd      ekl=1.0d0
7222 cd      ekont=1.0d0
7223       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7224 cd      eello6_5=0.0d0
7225 cd      write (2,*) 'eello6_5',eello6_5
7226 #ifdef MOMENT
7227       call transpose2(AEA(1,1,1),auxmat(1,1))
7228       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7229       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7230       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7231 #else
7232       s1 = 0.0d0
7233 #endif
7234       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7235       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7236       s2 = scalar2(b1(1,itk),vtemp1(1))
7237 #ifdef MOMENT
7238       call transpose2(AEA(1,1,2),atemp(1,1))
7239       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7240       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7241       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7242 #else
7243       s8=0.0d0
7244 #endif
7245       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7246       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7247       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7248 #ifdef MOMENT
7249       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7250       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7251       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7252       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7253       ss13 = scalar2(b1(1,itk),vtemp4(1))
7254       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7255 #else
7256       s13=0.0d0
7257 #endif
7258 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7259 c      s1=0.0d0
7260 c      s2=0.0d0
7261 c      s8=0.0d0
7262 c      s12=0.0d0
7263 c      s13=0.0d0
7264       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7265       if (calc_grad) then
7266 C Derivatives in gamma(i+2)
7267 #ifdef MOMENT
7268       call transpose2(AEA(1,1,1),auxmatd(1,1))
7269       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7270       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7271       call transpose2(AEAderg(1,1,2),atempd(1,1))
7272       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7273       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7274 #else
7275       s8d=0.0d0
7276 #endif
7277       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7278       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7279       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7280 c      s1d=0.0d0
7281 c      s2d=0.0d0
7282 c      s8d=0.0d0
7283 c      s12d=0.0d0
7284 c      s13d=0.0d0
7285       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7286 C Derivatives in gamma(i+3)
7287 #ifdef MOMENT
7288       call transpose2(AEA(1,1,1),auxmatd(1,1))
7289       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7290       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7291       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7292 #else
7293       s1d=0.0d0
7294 #endif
7295       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7296       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7297       s2d = scalar2(b1(1,itk),vtemp1d(1))
7298 #ifdef MOMENT
7299       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7300       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7301 #endif
7302       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7303 #ifdef MOMENT
7304       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7305       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7306       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7307 #else
7308       s13d=0.0d0
7309 #endif
7310 c      s1d=0.0d0
7311 c      s2d=0.0d0
7312 c      s8d=0.0d0
7313 c      s12d=0.0d0
7314 c      s13d=0.0d0
7315 #ifdef MOMENT
7316       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7317      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7318 #else
7319       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7320      &               -0.5d0*ekont*(s2d+s12d)
7321 #endif
7322 C Derivatives in gamma(i+4)
7323       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7324       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7325       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7326 #ifdef MOMENT
7327       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7328       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7329       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7330 #else
7331       s13d = 0.0d0
7332 #endif
7333 c      s1d=0.0d0
7334 c      s2d=0.0d0
7335 c      s8d=0.0d0
7336 C      s12d=0.0d0
7337 c      s13d=0.0d0
7338 #ifdef MOMENT
7339       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7340 #else
7341       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7342 #endif
7343 C Derivatives in gamma(i+5)
7344 #ifdef MOMENT
7345       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7346       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7347       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7348 #else
7349       s1d = 0.0d0
7350 #endif
7351       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7352       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7353       s2d = scalar2(b1(1,itk),vtemp1d(1))
7354 #ifdef MOMENT
7355       call transpose2(AEA(1,1,2),atempd(1,1))
7356       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7357       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7358 #else
7359       s8d = 0.0d0
7360 #endif
7361       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7362       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7363 #ifdef MOMENT
7364       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7365       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7366       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7367 #else
7368       s13d = 0.0d0
7369 #endif
7370 c      s1d=0.0d0
7371 c      s2d=0.0d0
7372 c      s8d=0.0d0
7373 c      s12d=0.0d0
7374 c      s13d=0.0d0
7375 #ifdef MOMENT
7376       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7377      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7378 #else
7379       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7380      &               -0.5d0*ekont*(s2d+s12d)
7381 #endif
7382 C Cartesian derivatives
7383       do iii=1,2
7384         do kkk=1,5
7385           do lll=1,3
7386 #ifdef MOMENT
7387             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7388             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7389             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7390 #else
7391             s1d = 0.0d0
7392 #endif
7393             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7394             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7395      &          vtemp1d(1))
7396             s2d = scalar2(b1(1,itk),vtemp1d(1))
7397 #ifdef MOMENT
7398             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7399             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7400             s8d = -(atempd(1,1)+atempd(2,2))*
7401      &           scalar2(cc(1,1,itl),vtemp2(1))
7402 #else
7403             s8d = 0.0d0
7404 #endif
7405             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7406      &           auxmatd(1,1))
7407             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7408             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7409 c      s1d=0.0d0
7410 c      s2d=0.0d0
7411 c      s8d=0.0d0
7412 c      s12d=0.0d0
7413 c      s13d=0.0d0
7414 #ifdef MOMENT
7415             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7416      &        - 0.5d0*(s1d+s2d)
7417 #else
7418             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7419      &        - 0.5d0*s2d
7420 #endif
7421 #ifdef MOMENT
7422             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7423      &        - 0.5d0*(s8d+s12d)
7424 #else
7425             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7426      &        - 0.5d0*s12d
7427 #endif
7428           enddo
7429         enddo
7430       enddo
7431 #ifdef MOMENT
7432       do kkk=1,5
7433         do lll=1,3
7434           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7435      &      achuj_tempd(1,1))
7436           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7437           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7438           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7439           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7440           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7441      &      vtemp4d(1))
7442           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7443           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7444           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7445         enddo
7446       enddo
7447 #endif
7448 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7449 cd     &  16*eel_turn6_num
7450 cd      goto 1112
7451       if (j.lt.nres-1) then
7452         j1=j+1
7453         j2=j-1
7454       else
7455         j1=j-1
7456         j2=j-2
7457       endif
7458       if (l.lt.nres-1) then
7459         l1=l+1
7460         l2=l-1
7461       else
7462         l1=l-1
7463         l2=l-2
7464       endif
7465       do ll=1,3
7466         ggg1(ll)=eel_turn6*g_contij(ll,1)
7467         ggg2(ll)=eel_turn6*g_contij(ll,2)
7468         ghalf=0.5d0*ggg1(ll)
7469 cd        ghalf=0.0d0
7470         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7471      &    +ekont*derx_turn(ll,2,1)
7472         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7473         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7474      &    +ekont*derx_turn(ll,4,1)
7475         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7476         ghalf=0.5d0*ggg2(ll)
7477 cd        ghalf=0.0d0
7478         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7479      &    +ekont*derx_turn(ll,2,2)
7480         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7481         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7482      &    +ekont*derx_turn(ll,4,2)
7483         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7484       enddo
7485 cd      goto 1112
7486       do m=i+1,j-1
7487         do ll=1,3
7488           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7489         enddo
7490       enddo
7491       do m=k+1,l-1
7492         do ll=1,3
7493           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7494         enddo
7495       enddo
7496 1112  continue
7497       do m=i+2,j2
7498         do ll=1,3
7499           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7500         enddo
7501       enddo
7502       do m=k+2,l2
7503         do ll=1,3
7504           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7505         enddo
7506       enddo
7507 cd      do iii=1,nres-3
7508 cd        write (2,*) iii,g_corr6_loc(iii)
7509 cd      enddo
7510       endif
7511       eello_turn6=ekont*eel_turn6
7512 cd      write (2,*) 'ekont',ekont
7513 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7514       return
7515       end
7516 crc-------------------------------------------------
7517       SUBROUTINE MATVEC2(A1,V1,V2)
7518       implicit real*8 (a-h,o-z)
7519       include 'DIMENSIONS'
7520       DIMENSION A1(2,2),V1(2),V2(2)
7521 c      DO 1 I=1,2
7522 c        VI=0.0
7523 c        DO 3 K=1,2
7524 c    3     VI=VI+A1(I,K)*V1(K)
7525 c        Vaux(I)=VI
7526 c    1 CONTINUE
7527
7528       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7529       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7530
7531       v2(1)=vaux1
7532       v2(2)=vaux2
7533       END
7534 C---------------------------------------
7535       SUBROUTINE MATMAT2(A1,A2,A3)
7536       implicit real*8 (a-h,o-z)
7537       include 'DIMENSIONS'
7538       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7539 c      DIMENSION AI3(2,2)
7540 c        DO  J=1,2
7541 c          A3IJ=0.0
7542 c          DO K=1,2
7543 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7544 c          enddo
7545 c          A3(I,J)=A3IJ
7546 c       enddo
7547 c      enddo
7548
7549       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7550       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7551       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7552       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7553
7554       A3(1,1)=AI3_11
7555       A3(2,1)=AI3_21
7556       A3(1,2)=AI3_12
7557       A3(2,2)=AI3_22
7558       END
7559
7560 c-------------------------------------------------------------------------
7561       double precision function scalar2(u,v)
7562       implicit none
7563       double precision u(2),v(2)
7564       double precision sc
7565       integer i
7566       scalar2=u(1)*v(1)+u(2)*v(2)
7567       return
7568       end
7569
7570 C-----------------------------------------------------------------------------
7571
7572       subroutine transpose2(a,at)
7573       implicit none
7574       double precision a(2,2),at(2,2)
7575       at(1,1)=a(1,1)
7576       at(1,2)=a(2,1)
7577       at(2,1)=a(1,2)
7578       at(2,2)=a(2,2)
7579       return
7580       end
7581 c--------------------------------------------------------------------------
7582       subroutine transpose(n,a,at)
7583       implicit none
7584       integer n,i,j
7585       double precision a(n,n),at(n,n)
7586       do i=1,n
7587         do j=1,n
7588           at(j,i)=a(i,j)
7589         enddo
7590       enddo
7591       return
7592       end
7593 C---------------------------------------------------------------------------
7594       subroutine prodmat3(a1,a2,kk,transp,prod)
7595       implicit none
7596       integer i,j
7597       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7598       logical transp
7599 crc      double precision auxmat(2,2),prod_(2,2)
7600
7601       if (transp) then
7602 crc        call transpose2(kk(1,1),auxmat(1,1))
7603 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7604 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7605
7606            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7607      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7608            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7609      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7610            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7611      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7612            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7613      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7614
7615       else
7616 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7617 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7618
7619            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7620      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7621            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7622      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7623            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7624      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7625            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7626      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7627
7628       endif
7629 c      call transpose2(a2(1,1),a2t(1,1))
7630
7631 crc      print *,transp
7632 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7633 crc      print *,((prod(i,j),i=1,2),j=1,2)
7634
7635       return
7636       end
7637 C-----------------------------------------------------------------------------
7638       double precision function scalar(u,v)
7639       implicit none
7640       double precision u(3),v(3)
7641       double precision sc
7642       integer i
7643       sc=0.0d0
7644       do i=1,3
7645         sc=sc+u(i)*v(i)
7646       enddo
7647       scalar=sc
7648       return
7649       end
7650