source/cluster/wham/src/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 c     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 c     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 c      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       include 'COMMON.CONTROL'
2880       dimension ggg(3)
2881       ehpb=0.0D0
2882 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2883 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2884       if (link_end.eq.0) return
2885       do i=link_start,link_end
2886 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2887 C CA-CA distance used in regularization of structure.
2888         ii=ihpb(i)
2889         jj=jhpb(i)
2890 C iii and jjj point to the residues for which the distance is assigned.
2891         if (ii.gt.nres) then
2892           iii=ii-nres
2893           jjj=jj-nres
2894         else
2895           iii=ii
2896           jjj=jj
2897         endif
2898 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2899 c     &    dhpb(i),dhpb1(i),forcon(i)
2900 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2901 C    distance and angle dependent SS bond potential.
2902         if (.not.dyn_ss .and. i.le.nss) then
2903 C 15/02/13 CC dynamic SSbond - additional check
2904         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2905           call ssbond_ene(iii,jjj,eij)
2906           ehpb=ehpb+2*eij
2907 cd          write (iout,*) "eij",eij
2908         endif
2909         else if (ii.gt.nres .and. jj.gt.nres) then
2910 c Restraints from contact prediction
2911           dd=dist(ii,jj)
2912          if (constr_dist.eq.11) then
2913             ehpb=ehpb+fordepth(i)**4.0d0
2914      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2915             fac=fordepth(i)**4.0d0
2916      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2917          else
2918           if (dhpb1(i).gt.0.0d0) then
2919             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2920             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2921 c            write (iout,*) "beta nmr",
2922 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2923           else
2924             dd=dist(ii,jj)
2925             rdis=dd-dhpb(i)
2926 C Get the force constant corresponding to this distance.
2927             waga=forcon(i)
2928 C Calculate the contribution to energy.
2929             ehpb=ehpb+waga*rdis*rdis
2930 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2931 C
2932 C Evaluate gradient.
2933 C
2934             fac=waga*rdis/dd
2935           endif !end dhpb1(i).gt.0
2936          endif !end const_dist=11
2937           do j=1,3
2938             ggg(j)=fac*(c(j,jj)-c(j,ii))
2939           enddo
2940           do j=1,3
2941             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2942             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2943           enddo
2944           do k=1,3
2945             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2946             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2947           enddo
2948         else
2949 C Calculate the distance between the two points and its difference from the
2950 C target distance.
2951           dd=dist(ii,jj)
2952 C          write(iout,*) "after",dd
2953           if (constr_dist.eq.11) then
2954             ehpb=ehpb+fordepth(i)**4.0d0
2955      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2956             fac=fordepth(i)**4.0d0
2957      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2958 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
2959 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
2960 C            print *,ehpb,"tu?"
2961 C            write(iout,*) ehpb,"btu?",
2962 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
2963 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
2964 C     &    ehpb,fordepth(i),dd
2965            else
2966           if (dhpb1(i).gt.0.0d0) then
2967             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2968             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2969 c            write (iout,*) "alph nmr",
2970 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2971           else
2972             rdis=dd-dhpb(i)
2973 C Get the force constant corresponding to this distance.
2974             waga=forcon(i)
2975 C Calculate the contribution to energy.
2976             ehpb=ehpb+waga*rdis*rdis
2977 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2978 C
2979 C Evaluate gradient.
2980 C
2981             fac=waga*rdis/dd
2982           endif
2983           endif
2984 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2985 cd   &   ' waga=',waga,' fac=',fac
2986             do j=1,3
2987               ggg(j)=fac*(c(j,jj)-c(j,ii))
2988             enddo
2989 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2990 C If this is a SC-SC distance, we need to calculate the contributions to the
2991 C Cartesian gradient in the SC vectors (ghpbx).
2992           if (iii.lt.ii) then
2993           do j=1,3
2994             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2995             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2996           enddo
2997           endif
2998           do k=1,3
2999             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3000             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3001           enddo
3002         endif
3003       enddo
3004       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3005       return
3006       end
3007 C--------------------------------------------------------------------------
3008       subroutine ssbond_ene(i,j,eij)
3009 C
3010 C Calculate the distance and angle dependent SS-bond potential energy
3011 C using a free-energy function derived based on RHF/6-31G** ab initio
3012 C calculations of diethyl disulfide.
3013 C
3014 C A. Liwo and U. Kozlowska, 11/24/03
3015 C
3016       implicit real*8 (a-h,o-z)
3017       include 'DIMENSIONS'
3018       include 'sizesclu.dat'
3019       include 'COMMON.SBRIDGE'
3020       include 'COMMON.CHAIN'
3021       include 'COMMON.DERIV'
3022       include 'COMMON.LOCAL'
3023       include 'COMMON.INTERACT'
3024       include 'COMMON.VAR'
3025       include 'COMMON.IOUNITS'
3026       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3027       itypi=itype(i)
3028       xi=c(1,nres+i)
3029       yi=c(2,nres+i)
3030       zi=c(3,nres+i)
3031       dxi=dc_norm(1,nres+i)
3032       dyi=dc_norm(2,nres+i)
3033       dzi=dc_norm(3,nres+i)
3034       dsci_inv=dsc_inv(itypi)
3035       itypj=itype(j)
3036       dscj_inv=dsc_inv(itypj)
3037       xj=c(1,nres+j)-xi
3038       yj=c(2,nres+j)-yi
3039       zj=c(3,nres+j)-zi
3040       dxj=dc_norm(1,nres+j)
3041       dyj=dc_norm(2,nres+j)
3042       dzj=dc_norm(3,nres+j)
3043       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3044       rij=dsqrt(rrij)
3045       erij(1)=xj*rij
3046       erij(2)=yj*rij
3047       erij(3)=zj*rij
3048       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3049       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3050       om12=dxi*dxj+dyi*dyj+dzi*dzj
3051       do k=1,3
3052         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3053         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3054       enddo
3055       rij=1.0d0/rij
3056       deltad=rij-d0cm
3057       deltat1=1.0d0-om1
3058       deltat2=1.0d0+om2
3059       deltat12=om2-om1+2.0d0
3060       cosphi=om12-om1*om2
3061       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3062      &  +akct*deltad*deltat12+ebr
3063      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3064 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3065 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3066 c     &  " deltat12",deltat12," eij",eij
3067       ed=2*akcm*deltad+akct*deltat12
3068       pom1=akct*deltad
3069       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3070       eom1=-2*akth*deltat1-pom1-om2*pom2
3071       eom2= 2*akth*deltat2+pom1-om1*pom2
3072       eom12=pom2
3073       do k=1,3
3074         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3075       enddo
3076       do k=1,3
3077         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3078      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3079         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3080      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3081       enddo
3082 C
3083 C Calculate the components of the gradient in DC and X
3084 C
3085       do k=i,j-1
3086         do l=1,3
3087           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3088         enddo
3089       enddo
3090       return
3091       end
3092
3093 C--------------------------------------------------------------------------
3094
3095
3096 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3097       subroutine e_modeller(ehomology_constr)
3098       implicit real*8 (a-h,o-z)
3099
3100       include 'DIMENSIONS'
3101
3102       integer nnn, i, j, k, ki, irec, l
3103       integer katy, odleglosci, test7
3104       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3105       real*8 distance(max_template),distancek(max_template),
3106      &    min_odl,godl(max_template),dih_diff(max_template)
3107
3108 c
3109 c     FP - 30/10/2014 Temporary specifications for homology restraints
3110 c
3111       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3112      &                 sgtheta
3113       double precision, dimension (maxres) :: guscdiff,usc_diff
3114       double precision, dimension (max_template) ::
3115      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3116      &           theta_diff
3117
3118       include 'COMMON.SBRIDGE'
3119       include 'COMMON.CHAIN'
3120       include 'COMMON.GEO'
3121       include 'COMMON.DERIV'
3122       include 'COMMON.LOCAL'
3123       include 'COMMON.INTERACT'
3124       include 'COMMON.VAR'
3125       include 'COMMON.IOUNITS'
3126       include 'COMMON.CONTROL'
3127       include 'COMMON.HOMRESTR'
3128 c
3129       include 'COMMON.SETUP'
3130       include 'COMMON.NAMES'
3131
3132       do i=1,max_template
3133         distancek(i)=9999999.9
3134       enddo
3135
3136       odleg=0.0d0
3137
3138 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3139 c function)
3140 C AL 5/2/14 - Introduce list of restraints
3141 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3142 #ifdef DEBUG
3143       write(iout,*) "------- dist restrs start -------"
3144       write (iout,*) "link_start_homo",link_start_homo,
3145      &    " link_end_homo",link_end_homo
3146 #endif
3147       do ii = link_start_homo,link_end_homo
3148          i = ires_homo(ii)
3149          j = jres_homo(ii)
3150          dij=dist(i,j)
3151 c        write (iout,*) "dij(",i,j,") =",dij
3152          nexl=0
3153          do k=1,constr_homology
3154            if(.not.l_homo(k,ii)) then
3155               nexl=nexl+1
3156               cycle
3157            endif
3158            distance(k)=odl(k,ii)-dij
3159 c          write (iout,*) "distance(",k,") =",distance(k)
3160 c
3161 c          For Gaussian-type Urestr
3162 c
3163            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3164 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3165 c          write (iout,*) "distancek(",k,") =",distancek(k)
3166 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3167 c
3168 c          For Lorentzian-type Urestr
3169 c
3170            if (waga_dist.lt.0.0d0) then
3171               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3172               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3173      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3174            endif
3175          enddo
3176
3177 c         min_odl=minval(distancek)
3178          do kk=1,constr_homology
3179           if(l_homo(kk,ii)) then
3180             min_odl=distancek(kk)
3181             exit
3182           endif
3183          enddo
3184          do kk=1,constr_homology
3185           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3186      &              min_odl=distancek(kk)
3187          enddo
3188 c        write (iout,* )"min_odl",min_odl
3189 #ifdef DEBUG
3190          write (iout,*) "ij dij",i,j,dij
3191          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3192          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3193          write (iout,* )"min_odl",min_odl
3194 #endif
3195 #ifdef OLDRESTR
3196          odleg2=0.0d0
3197 #else
3198          if (waga_dist.ge.0.0d0) then
3199            odleg2=nexl
3200          else
3201            odleg2=0.0d0
3202          endif
3203 #endif
3204          do k=1,constr_homology
3205 c Nie wiem po co to liczycie jeszcze raz!
3206 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3207 c     &              (2*(sigma_odl(i,j,k))**2))
3208            if(.not.l_homo(k,ii)) cycle
3209            if (waga_dist.ge.0.0d0) then
3210 c
3211 c          For Gaussian-type Urestr
3212 c
3213             godl(k)=dexp(-distancek(k)+min_odl)
3214             odleg2=odleg2+godl(k)
3215 c
3216 c          For Lorentzian-type Urestr
3217 c
3218            else
3219             odleg2=odleg2+distancek(k)
3220            endif
3221
3222 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3223 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3224 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3225 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3226
3227          enddo
3228 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3229 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3230 #ifdef DEBUG
3231          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3232          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3233 #endif
3234            if (waga_dist.ge.0.0d0) then
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3239 c
3240 c          For Lorentzian-type Urestr
3241 c
3242            else
3243               odleg=odleg+odleg2/constr_homology
3244            endif
3245 c
3246 #ifdef GRAD
3247 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3248 c Gradient
3249 c
3250 c          For Gaussian-type Urestr
3251 c
3252          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3253          sum_sgodl=0.0d0
3254          do k=1,constr_homology
3255 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3256 c     &           *waga_dist)+min_odl
3257 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3258 c
3259          if(.not.l_homo(k,ii)) cycle
3260          if (waga_dist.ge.0.0d0) then
3261 c          For Gaussian-type Urestr
3262 c
3263            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3264 c
3265 c          For Lorentzian-type Urestr
3266 c
3267          else
3268            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3269      &           sigma_odlir(k,ii)**2)**2)
3270          endif
3271            sum_sgodl=sum_sgodl+sgodl
3272
3273 c            sgodl2=sgodl2+sgodl
3274 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3275 c      write(iout,*) "constr_homology=",constr_homology
3276 c      write(iout,*) i, j, k, "TEST K"
3277          enddo
3278          if (waga_dist.ge.0.0d0) then
3279 c
3280 c          For Gaussian-type Urestr
3281 c
3282             grad_odl3=waga_homology(iset)*waga_dist
3283      &                *sum_sgodl/(sum_godl*dij)
3284 c
3285 c          For Lorentzian-type Urestr
3286 c
3287          else
3288 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3289 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3290             grad_odl3=-waga_homology(iset)*waga_dist*
3291      &                sum_sgodl/(constr_homology*dij)
3292          endif
3293 c
3294 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3295
3296
3297 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3298 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3299 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3300
3301 ccc      write(iout,*) godl, sgodl, grad_odl3
3302
3303 c          grad_odl=grad_odl+grad_odl3
3304
3305          do jik=1,3
3306             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3307 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3308 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3309 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3310             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3311             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3312 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3313 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3314 c         if (i.eq.25.and.j.eq.27) then
3315 c         write(iout,*) "jik",jik,"i",i,"j",j
3316 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3317 c         write(iout,*) "grad_odl3",grad_odl3
3318 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3319 c         write(iout,*) "ggodl",ggodl
3320 c         write(iout,*) "ghpbc(",jik,i,")",
3321 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3322 c     &                 ghpbc(jik,j)
3323 c         endif
3324          enddo
3325 #endif
3326 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3327 ccc     & dLOG(odleg2),"-odleg=", -odleg
3328
3329       enddo ! ii-loop for dist
3330 #ifdef DEBUG
3331       write(iout,*) "------- dist restrs end -------"
3332 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3333 c    &     waga_d.eq.1.0d0) call sum_gradient
3334 #endif
3335 c Pseudo-energy and gradient from dihedral-angle restraints from
3336 c homology templates
3337 c      write (iout,*) "End of distance loop"
3338 c      call flush(iout)
3339       kat=0.0d0
3340 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3341 #ifdef DEBUG
3342       write(iout,*) "------- dih restrs start -------"
3343       do i=idihconstr_start_homo,idihconstr_end_homo
3344         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3345       enddo
3346 #endif
3347       do i=idihconstr_start_homo,idihconstr_end_homo
3348 #ifdef OLDRESTR
3349         kat2=0.0d0
3350 #else
3351         kat2=nexl
3352 #endif
3353 c        betai=beta(i,i+1,i+2,i+3)
3354         betai = phi(i)
3355 c       write (iout,*) "betai =",betai
3356         do k=1,constr_homology
3357           dih_diff(k)=pinorm(dih(k,i)-betai)
3358 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3359 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3360 c     &                                   -(6.28318-dih_diff(i,k))
3361 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3362 c     &                                   6.28318+dih_diff(i,k)
3363 #ifdef OLD_DIHED
3364           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3365 #else
3366           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3367 #endif
3368 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3369           gdih(k)=dexp(kat3)
3370           kat2=kat2+gdih(k)
3371 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3372 c          write(*,*)""
3373         enddo
3374 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3375 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3376 #ifdef DEBUG
3377         write (iout,*) "i",i," betai",betai," kat2",kat2
3378         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3379 #endif
3380         if (kat2.le.1.0d-14) cycle
3381         kat=kat-dLOG(kat2/constr_homology)
3382 c       write (iout,*) "kat",kat ! sum of -ln-s
3383
3384 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3385 ccc     & dLOG(kat2), "-kat=", -kat
3386
3387 #ifdef GRAD
3388 c ----------------------------------------------------------------------
3389 c Gradient
3390 c ----------------------------------------------------------------------
3391
3392         sum_gdih=kat2
3393         sum_sgdih=0.0d0
3394         do k=1,constr_homology
3395 #ifdef OLD_DIHED
3396           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3397 #else
3398           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3399 #endif
3400 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3401           sum_sgdih=sum_sgdih+sgdih
3402         enddo
3403 c       grad_dih3=sum_sgdih/sum_gdih
3404         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3405
3406 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3407 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3408 ccc     & gloc(nphi+i-3,icg)
3409         gloc(i,icg)=gloc(i,icg)+grad_dih3
3410 c        if (i.eq.25) then
3411 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3412 c        endif
3413 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3414 ccc     & gloc(nphi+i-3,icg)
3415 #endif
3416       enddo ! i-loop for dih
3417 #ifdef DEBUG
3418       write(iout,*) "------- dih restrs end -------"
3419 #endif
3420
3421 c Pseudo-energy and gradient for theta angle restraints from
3422 c homology templates
3423 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3424 c adapted
3425
3426 c
3427 c     For constr_homology reference structures (FP)
3428 c
3429 c     Uconst_back_tot=0.0d0
3430       Eval=0.0d0
3431       Erot=0.0d0
3432 c     Econstr_back legacy
3433 #ifdef GRAD
3434       do i=1,nres
3435 c     do i=ithet_start,ithet_end
3436        dutheta(i)=0.0d0
3437 c     enddo
3438 c     do i=loc_start,loc_end
3439         do j=1,3
3440           duscdiff(j,i)=0.0d0
3441           duscdiffx(j,i)=0.0d0
3442         enddo
3443       enddo
3444 #endif
3445 c
3446 c     do iref=1,nref
3447 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3448 c     write (iout,*) "waga_theta",waga_theta
3449       if (waga_theta.gt.0.0d0) then
3450 #ifdef DEBUG
3451       write (iout,*) "usampl",usampl
3452       write(iout,*) "------- theta restrs start -------"
3453 c     do i=ithet_start,ithet_end
3454 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3455 c     enddo
3456 #endif
3457 c     write (iout,*) "maxres",maxres,"nres",nres
3458
3459       do i=ithet_start,ithet_end
3460 c
3461 c     do i=1,nfrag_back
3462 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3463 c
3464 c Deviation of theta angles wrt constr_homology ref structures
3465 c
3466         utheta_i=0.0d0 ! argument of Gaussian for single k
3467 #ifdef OLDRESTR
3468         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3469 #else
3470         gutheta_i=nexl
3471 #endif
3472 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3473 c       over residues in a fragment
3474 c       write (iout,*) "theta(",i,")=",theta(i)
3475         do k=1,constr_homology
3476 c
3477 c         dtheta_i=theta(j)-thetaref(j,iref)
3478 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3479           theta_diff(k)=thetatpl(k,i)-theta(i)
3480 c
3481           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3482 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3483           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3484           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3485 c         Gradient for single Gaussian restraint in subr Econstr_back
3486 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3487 c
3488         enddo
3489 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3490 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3491
3492 c
3493 #ifdef GRAD
3494 c         Gradient for multiple Gaussian restraint
3495         sum_gtheta=gutheta_i
3496         sum_sgtheta=0.0d0
3497         do k=1,constr_homology
3498 c        New generalized expr for multiple Gaussian from Econstr_back
3499          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3500 c
3501 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3502           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3503         enddo
3504 c
3505 c       Final value of gradient using same var as in Econstr_back
3506         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3507      &               *waga_homology(iset)
3508 c       dutheta(i)=sum_sgtheta/sum_gtheta
3509 c
3510 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3511 #endif
3512         Eval=Eval-dLOG(gutheta_i/constr_homology)
3513 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3514 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3515 c       Uconst_back=Uconst_back+utheta(i)
3516       enddo ! (i-loop for theta)
3517 #ifdef DEBUG
3518       write(iout,*) "------- theta restrs end -------"
3519 #endif
3520       endif
3521 c
3522 c Deviation of local SC geometry
3523 c
3524 c Separation of two i-loops (instructed by AL - 11/3/2014)
3525 c
3526 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3527 c     write (iout,*) "waga_d",waga_d
3528
3529 #ifdef DEBUG
3530       write(iout,*) "------- SC restrs start -------"
3531       write (iout,*) "Initial duscdiff,duscdiffx"
3532       do i=loc_start,loc_end
3533         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3534      &                 (duscdiffx(jik,i),jik=1,3)
3535       enddo
3536 #endif
3537       do i=loc_start,loc_end
3538         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3539 #ifdef OLDRESTR
3540         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3541 #else
3542         guscdiff(i)=nexl
3543 #endif
3544 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3545 c       write(iout,*) "xxtab, yytab, zztab"
3546 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3547         do k=1,constr_homology
3548 c
3549           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3550 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3551           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3552           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3553 c         write(iout,*) "dxx, dyy, dzz"
3554 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3555 c
3556           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3557 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3558 c         uscdiffk(k)=usc_diff(i)
3559           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3560           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3561 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3562 c     &      xxref(j),yyref(j),zzref(j)
3563         enddo
3564 c
3565 c       Gradient
3566 c
3567 c       Generalized expression for multiple Gaussian acc to that for a single
3568 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3569 c
3570 c       Original implementation
3571 c       sum_guscdiff=guscdiff(i)
3572 c
3573 c       sum_sguscdiff=0.0d0
3574 c       do k=1,constr_homology
3575 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3576 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3577 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3578 c       enddo
3579 c
3580 c       Implementation of new expressions for gradient (Jan. 2015)
3581 c
3582 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3583 #ifdef GRAD
3584         do k=1,constr_homology
3585 c
3586 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3587 c       before. Now the drivatives should be correct
3588 c
3589           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3590 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3591           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3592           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3593 c
3594 c         New implementation
3595 c
3596           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3597      &                 sigma_d(k,i) ! for the grad wrt r'
3598 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3599 c
3600 c
3601 c        New implementation
3602          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3603          do jik=1,3
3604             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3605      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3606      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3607             duscdiff(jik,i)=duscdiff(jik,i)+
3608      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3609      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3610             duscdiffx(jik,i)=duscdiffx(jik,i)+
3611      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3612      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3613 c
3614 #ifdef DEBUG
3615              write(iout,*) "jik",jik,"i",i
3616              write(iout,*) "dxx, dyy, dzz"
3617              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3618              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3619 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3620 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3621 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3622 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3623 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3624 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3625 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3626 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3627 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3628 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3629 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3630 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3631 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3632 c            endif
3633 #endif
3634          enddo
3635         enddo
3636 #endif
3637 c
3638 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3639 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3640 c
3641 c        write (iout,*) i," uscdiff",uscdiff(i)
3642 c
3643 c Put together deviations from local geometry
3644
3645 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3646 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3647         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3648 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3649 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3650 c       Uconst_back=Uconst_back+usc_diff(i)
3651 c
3652 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3653 c
3654 c     New implment: multiplied by sum_sguscdiff
3655 c
3656
3657       enddo ! (i-loop for dscdiff)
3658
3659 c      endif
3660
3661 #ifdef DEBUG
3662       write(iout,*) "------- SC restrs end -------"
3663         write (iout,*) "------ After SC loop in e_modeller ------"
3664         do i=loc_start,loc_end
3665          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3666          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3667         enddo
3668       if (waga_theta.eq.1.0d0) then
3669       write (iout,*) "in e_modeller after SC restr end: dutheta"
3670       do i=ithet_start,ithet_end
3671         write (iout,*) i,dutheta(i)
3672       enddo
3673       endif
3674       if (waga_d.eq.1.0d0) then
3675       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3676       do i=1,nres
3677         write (iout,*) i,(duscdiff(j,i),j=1,3)
3678         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3679       enddo
3680       endif
3681 #endif
3682
3683 c Total energy from homology restraints
3684 #ifdef DEBUG
3685       write (iout,*) "odleg",odleg," kat",kat
3686       write (iout,*) "odleg",odleg," kat",kat
3687       write (iout,*) "Eval",Eval," Erot",Erot
3688       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3689       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3690       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3691       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3692 #endif
3693 c
3694 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3695 c
3696 c     ehomology_constr=odleg+kat
3697 c
3698 c     For Lorentzian-type Urestr
3699 c
3700
3701       if (waga_dist.ge.0.0d0) then
3702 c
3703 c          For Gaussian-type Urestr
3704 c
3705         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3706      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3707 c     write (iout,*) "ehomology_constr=",ehomology_constr
3708       else
3709 c
3710 c          For Lorentzian-type Urestr
3711 c
3712         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3713      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3714 c     write (iout,*) "ehomology_constr=",ehomology_constr
3715       endif
3716 #ifdef DEBUG
3717       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
3718       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3719      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
3720       write (iout,*) "ehomology_constr",ehomology_constr
3721 #endif
3722       return
3723
3724   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3725   747 format(a12,i4,i4,i4,f8.3,f8.3)
3726   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3727   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3728   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3729      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3730       end
3731 C--------------------------------------------------------------------------
3732       subroutine ebond(estr)
3733 c
3734 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3735 c
3736       implicit real*8 (a-h,o-z)
3737       include 'DIMENSIONS'
3738       include 'COMMON.LOCAL'
3739       include 'COMMON.GEO'
3740       include 'COMMON.INTERACT'
3741       include 'COMMON.DERIV'
3742       include 'COMMON.VAR'
3743       include 'COMMON.CHAIN'
3744       include 'COMMON.IOUNITS'
3745       include 'COMMON.NAMES'
3746       include 'COMMON.FFIELD'
3747       include 'COMMON.CONTROL'
3748       double precision u(3),ud(3)
3749       estr=0.0d0
3750       do i=nnt+1,nct
3751         diff = vbld(i)-vbldp0
3752 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3753         estr=estr+diff*diff
3754         do j=1,3
3755           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3756         enddo
3757       enddo
3758       estr=0.5d0*AKP*estr
3759 c
3760 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3761 c
3762       do i=nnt,nct
3763         iti=itype(i)
3764         if (iti.ne.10) then
3765           nbi=nbondterm(iti)
3766           if (nbi.eq.1) then
3767             diff=vbld(i+nres)-vbldsc0(1,iti)
3768 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3769 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3770             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3771             do j=1,3
3772               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3773             enddo
3774           else
3775             do j=1,nbi
3776               diff=vbld(i+nres)-vbldsc0(j,iti)
3777               ud(j)=aksc(j,iti)*diff
3778               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3779             enddo
3780             uprod=u(1)
3781             do j=2,nbi
3782               uprod=uprod*u(j)
3783             enddo
3784             usum=0.0d0
3785             usumsqder=0.0d0
3786             do j=1,nbi
3787               uprod1=1.0d0
3788               uprod2=1.0d0
3789               do k=1,nbi
3790                 if (k.ne.j) then
3791                   uprod1=uprod1*u(k)
3792                   uprod2=uprod2*u(k)*u(k)
3793                 endif
3794               enddo
3795               usum=usum+uprod1
3796               usumsqder=usumsqder+ud(j)*uprod2
3797             enddo
3798 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3799 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3800             estr=estr+uprod/usum
3801             do j=1,3
3802              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3803             enddo
3804           endif
3805         endif
3806       enddo
3807       return
3808       end
3809 #ifdef CRYST_THETA
3810 C--------------------------------------------------------------------------
3811       subroutine ebend(etheta)
3812 C
3813 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3814 C angles gamma and its derivatives in consecutive thetas and gammas.
3815 C
3816       implicit real*8 (a-h,o-z)
3817       include 'DIMENSIONS'
3818       include 'sizesclu.dat'
3819       include 'COMMON.LOCAL'
3820       include 'COMMON.GEO'
3821       include 'COMMON.INTERACT'
3822       include 'COMMON.DERIV'
3823       include 'COMMON.VAR'
3824       include 'COMMON.CHAIN'
3825       include 'COMMON.IOUNITS'
3826       include 'COMMON.NAMES'
3827       include 'COMMON.FFIELD'
3828       common /calcthet/ term1,term2,termm,diffak,ratak,
3829      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3830      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3831       double precision y(2),z(2)
3832       delta=0.02d0*pi
3833       time11=dexp(-2*time)
3834       time12=1.0d0
3835       etheta=0.0D0
3836 c      write (iout,*) "nres",nres
3837 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3838 c      write (iout,*) ithet_start,ithet_end
3839       do i=ithet_start,ithet_end
3840 C Zero the energy function and its derivative at 0 or pi.
3841         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3842         it=itype(i-1)
3843 c        if (i.gt.ithet_start .and.
3844 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3845 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3846 c          phii=phi(i)
3847 c          y(1)=dcos(phii)
3848 c          y(2)=dsin(phii)
3849 c        else
3850 c          y(1)=0.0D0
3851 c          y(2)=0.0D0
3852 c        endif
3853 c        if (i.lt.nres .and. itel(i).ne.0) then
3854 c          phii1=phi(i+1)
3855 c          z(1)=dcos(phii1)
3856 c          z(2)=dsin(phii1)
3857 c        else
3858 c          z(1)=0.0D0
3859 c          z(2)=0.0D0
3860 c        endif
3861         if (i.gt.3) then
3862 #ifdef OSF
3863           phii=phi(i)
3864           icrc=0
3865           call proc_proc(phii,icrc)
3866           if (icrc.eq.1) phii=150.0
3867 #else
3868           phii=phi(i)
3869 #endif
3870           y(1)=dcos(phii)
3871           y(2)=dsin(phii)
3872         else
3873           y(1)=0.0D0
3874           y(2)=0.0D0
3875         endif
3876         if (i.lt.nres) then
3877 #ifdef OSF
3878           phii1=phi(i+1)
3879           icrc=0
3880           call proc_proc(phii1,icrc)
3881           if (icrc.eq.1) phii1=150.0
3882           phii1=pinorm(phii1)
3883           z(1)=cos(phii1)
3884 #else
3885           phii1=phi(i+1)
3886           z(1)=dcos(phii1)
3887 #endif
3888           z(2)=dsin(phii1)
3889         else
3890           z(1)=0.0D0
3891           z(2)=0.0D0
3892         endif
3893 C Calculate the "mean" value of theta from the part of the distribution
3894 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3895 C In following comments this theta will be referred to as t_c.
3896         thet_pred_mean=0.0d0
3897         do k=1,2
3898           athetk=athet(k,it)
3899           bthetk=bthet(k,it)
3900           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3901         enddo
3902 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3903         dthett=thet_pred_mean*ssd
3904         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3905 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3906 C Derivatives of the "mean" values in gamma1 and gamma2.
3907         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3908         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3909         if (theta(i).gt.pi-delta) then
3910           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3911      &         E_tc0)
3912           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3913           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3914           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3915      &        E_theta)
3916           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3917      &        E_tc)
3918         else if (theta(i).lt.delta) then
3919           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3920           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3921           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3922      &        E_theta)
3923           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3924           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3925      &        E_tc)
3926         else
3927           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3928      &        E_theta,E_tc)
3929         endif
3930         etheta=etheta+ethetai
3931 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3932 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3933         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3934         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3935         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3936  1215   continue
3937       enddo
3938 C Ufff.... We've done all this!!!
3939       return
3940       end
3941 C---------------------------------------------------------------------------
3942       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3943      &     E_tc)
3944       implicit real*8 (a-h,o-z)
3945       include 'DIMENSIONS'
3946       include 'COMMON.LOCAL'
3947       include 'COMMON.IOUNITS'
3948       common /calcthet/ term1,term2,termm,diffak,ratak,
3949      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3950      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3951 C Calculate the contributions to both Gaussian lobes.
3952 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3953 C The "polynomial part" of the "standard deviation" of this part of
3954 C the distribution.
3955         sig=polthet(3,it)
3956         do j=2,0,-1
3957           sig=sig*thet_pred_mean+polthet(j,it)
3958         enddo
3959 C Derivative of the "interior part" of the "standard deviation of the"
3960 C gamma-dependent Gaussian lobe in t_c.
3961         sigtc=3*polthet(3,it)
3962         do j=2,1,-1
3963           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3964         enddo
3965         sigtc=sig*sigtc
3966 C Set the parameters of both Gaussian lobes of the distribution.
3967 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3968         fac=sig*sig+sigc0(it)
3969         sigcsq=fac+fac
3970         sigc=1.0D0/sigcsq
3971 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3972         sigsqtc=-4.0D0*sigcsq*sigtc
3973 c       print *,i,sig,sigtc,sigsqtc
3974 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3975         sigtc=-sigtc/(fac*fac)
3976 C Following variable is sigma(t_c)**(-2)
3977         sigcsq=sigcsq*sigcsq
3978         sig0i=sig0(it)
3979         sig0inv=1.0D0/sig0i**2
3980         delthec=thetai-thet_pred_mean
3981         delthe0=thetai-theta0i
3982         term1=-0.5D0*sigcsq*delthec*delthec
3983         term2=-0.5D0*sig0inv*delthe0*delthe0
3984 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3985 C NaNs in taking the logarithm. We extract the largest exponent which is added
3986 C to the energy (this being the log of the distribution) at the end of energy
3987 C term evaluation for this virtual-bond angle.
3988         if (term1.gt.term2) then
3989           termm=term1
3990           term2=dexp(term2-termm)
3991           term1=1.0d0
3992         else
3993           termm=term2
3994           term1=dexp(term1-termm)
3995           term2=1.0d0
3996         endif
3997 C The ratio between the gamma-independent and gamma-dependent lobes of
3998 C the distribution is a Gaussian function of thet_pred_mean too.
3999         diffak=gthet(2,it)-thet_pred_mean
4000         ratak=diffak/gthet(3,it)**2
4001         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4002 C Let's differentiate it in thet_pred_mean NOW.
4003         aktc=ak*ratak
4004 C Now put together the distribution terms to make complete distribution.
4005         termexp=term1+ak*term2
4006         termpre=sigc+ak*sig0i
4007 C Contribution of the bending energy from this theta is just the -log of
4008 C the sum of the contributions from the two lobes and the pre-exponential
4009 C factor. Simple enough, isn't it?
4010         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4011 C NOW the derivatives!!!
4012 C 6/6/97 Take into account the deformation.
4013         E_theta=(delthec*sigcsq*term1
4014      &       +ak*delthe0*sig0inv*term2)/termexp
4015         E_tc=((sigtc+aktc*sig0i)/termpre
4016      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4017      &       aktc*term2)/termexp)
4018       return
4019       end
4020 c-----------------------------------------------------------------------------
4021       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4022       implicit real*8 (a-h,o-z)
4023       include 'DIMENSIONS'
4024       include 'COMMON.LOCAL'
4025       include 'COMMON.IOUNITS'
4026       common /calcthet/ term1,term2,termm,diffak,ratak,
4027      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4028      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4029       delthec=thetai-thet_pred_mean
4030       delthe0=thetai-theta0i
4031 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4032       t3 = thetai-thet_pred_mean
4033       t6 = t3**2
4034       t9 = term1
4035       t12 = t3*sigcsq
4036       t14 = t12+t6*sigsqtc
4037       t16 = 1.0d0
4038       t21 = thetai-theta0i
4039       t23 = t21**2
4040       t26 = term2
4041       t27 = t21*t26
4042       t32 = termexp
4043       t40 = t32**2
4044       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4045      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4046      & *(-t12*t9-ak*sig0inv*t27)
4047       return
4048       end
4049 #else
4050 C--------------------------------------------------------------------------
4051       subroutine ebend(etheta)
4052 C
4053 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4054 C angles gamma and its derivatives in consecutive thetas and gammas.
4055 C ab initio-derived potentials from
4056 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4057 C
4058       implicit real*8 (a-h,o-z)
4059       include 'DIMENSIONS'
4060       include 'COMMON.LOCAL'
4061       include 'COMMON.GEO'
4062       include 'COMMON.INTERACT'
4063       include 'COMMON.DERIV'
4064       include 'COMMON.VAR'
4065       include 'COMMON.CHAIN'
4066       include 'COMMON.IOUNITS'
4067       include 'COMMON.NAMES'
4068       include 'COMMON.FFIELD'
4069       include 'COMMON.CONTROL'
4070       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4071      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4072      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4073      & sinph1ph2(maxdouble,maxdouble)
4074       logical lprn /.false./, lprn1 /.false./
4075       etheta=0.0D0
4076       do i=ithet_start,ithet_end
4077         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4078      &    (itype(i).eq.ntyp1)) cycle
4079         dethetai=0.0d0
4080         dephii=0.0d0
4081         dephii1=0.0d0
4082         theti2=0.5d0*theta(i)
4083         ityp2=ithetyp(itype(i-1))
4084         do k=1,nntheterm
4085           coskt(k)=dcos(k*theti2)
4086           sinkt(k)=dsin(k*theti2)
4087         enddo
4088         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4089 #ifdef OSF
4090           phii=phi(i)
4091           if (phii.ne.phii) phii=150.0
4092 #else
4093           phii=phi(i)
4094 #endif
4095           ityp1=ithetyp(itype(i-2))
4096           do k=1,nsingle
4097             cosph1(k)=dcos(k*phii)
4098             sinph1(k)=dsin(k*phii)
4099           enddo
4100         else
4101           phii=0.0d0
4102           ityp1=ithetyp(itype(i-2))
4103           do k=1,nsingle
4104             cosph1(k)=0.0d0
4105             sinph1(k)=0.0d0
4106           enddo
4107         endif
4108         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4109 #ifdef OSF
4110           phii1=phi(i+1)
4111           if (phii1.ne.phii1) phii1=150.0
4112           phii1=pinorm(phii1)
4113 #else
4114           phii1=phi(i+1)
4115 #endif
4116           ityp3=ithetyp(itype(i))
4117           do k=1,nsingle
4118             cosph2(k)=dcos(k*phii1)
4119             sinph2(k)=dsin(k*phii1)
4120           enddo
4121         else
4122           phii1=0.0d0
4123           ityp3=ithetyp(itype(i))
4124           do k=1,nsingle
4125             cosph2(k)=0.0d0
4126             sinph2(k)=0.0d0
4127           enddo
4128         endif
4129 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4130 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4131 c        call flush(iout)
4132         ethetai=aa0thet(ityp1,ityp2,ityp3)
4133         do k=1,ndouble
4134           do l=1,k-1
4135             ccl=cosph1(l)*cosph2(k-l)
4136             ssl=sinph1(l)*sinph2(k-l)
4137             scl=sinph1(l)*cosph2(k-l)
4138             csl=cosph1(l)*sinph2(k-l)
4139             cosph1ph2(l,k)=ccl-ssl
4140             cosph1ph2(k,l)=ccl+ssl
4141             sinph1ph2(l,k)=scl+csl
4142             sinph1ph2(k,l)=scl-csl
4143           enddo
4144         enddo
4145         if (lprn) then
4146         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4147      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4148         write (iout,*) "coskt and sinkt"
4149         do k=1,nntheterm
4150           write (iout,*) k,coskt(k),sinkt(k)
4151         enddo
4152         endif
4153         do k=1,ntheterm
4154           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4155           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4156      &      *coskt(k)
4157           if (lprn)
4158      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4159      &     " ethetai",ethetai
4160         enddo
4161         if (lprn) then
4162         write (iout,*) "cosph and sinph"
4163         do k=1,nsingle
4164           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4165         enddo
4166         write (iout,*) "cosph1ph2 and sinph2ph2"
4167         do k=2,ndouble
4168           do l=1,k-1
4169             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4170      &         sinph1ph2(l,k),sinph1ph2(k,l)
4171           enddo
4172         enddo
4173         write(iout,*) "ethetai",ethetai
4174         endif
4175         do m=1,ntheterm2
4176           do k=1,nsingle
4177             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4178      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4179      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4180      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4181             ethetai=ethetai+sinkt(m)*aux
4182             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4183             dephii=dephii+k*sinkt(m)*(
4184      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4185      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4186             dephii1=dephii1+k*sinkt(m)*(
4187      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4188      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4189             if (lprn)
4190      &      write (iout,*) "m",m," k",k," bbthet",
4191      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4192      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4193      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4194      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4195           enddo
4196         enddo
4197         if (lprn)
4198      &  write(iout,*) "ethetai",ethetai
4199         do m=1,ntheterm3
4200           do k=2,ndouble
4201             do l=1,k-1
4202               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4203      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4204      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4205      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4206               ethetai=ethetai+sinkt(m)*aux
4207               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4208               dephii=dephii+l*sinkt(m)*(
4209      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4210      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4211      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4212      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4213               dephii1=dephii1+(k-l)*sinkt(m)*(
4214      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4215      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4216      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4217      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4218               if (lprn) then
4219               write (iout,*) "m",m," k",k," l",l," ffthet",
4220      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4221      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4222      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4223      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4224               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4225      &            cosph1ph2(k,l)*sinkt(m),
4226      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4227               endif
4228             enddo
4229           enddo
4230         enddo
4231 10      continue
4232 c        lprn1=.true.
4233         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4234      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4235      &   phii1*rad2deg,ethetai
4236 c        lprn1=.false.
4237         etheta=etheta+ethetai
4238
4239         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4240         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4241         gloc(nphi+i-2,icg)=wang*dethetai
4242       enddo
4243       return
4244       end
4245 #endif
4246 #ifdef CRYST_SC
4247 c-----------------------------------------------------------------------------
4248       subroutine esc(escloc)
4249 C Calculate the local energy of a side chain and its derivatives in the
4250 C corresponding virtual-bond valence angles THETA and the spherical angles
4251 C ALPHA and OMEGA.
4252       implicit real*8 (a-h,o-z)
4253       include 'DIMENSIONS'
4254       include 'sizesclu.dat'
4255       include 'COMMON.GEO'
4256       include 'COMMON.LOCAL'
4257       include 'COMMON.VAR'
4258       include 'COMMON.INTERACT'
4259       include 'COMMON.DERIV'
4260       include 'COMMON.CHAIN'
4261       include 'COMMON.IOUNITS'
4262       include 'COMMON.NAMES'
4263       include 'COMMON.FFIELD'
4264       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4265      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4266       common /sccalc/ time11,time12,time112,theti,it,nlobit
4267       delta=0.02d0*pi
4268       escloc=0.0D0
4269 c     write (iout,'(a)') 'ESC'
4270       do i=loc_start,loc_end
4271         it=itype(i)
4272         if (it.eq.10) goto 1
4273         nlobit=nlob(it)
4274 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4275 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4276         theti=theta(i+1)-pipol
4277         x(1)=dtan(theti)
4278         x(2)=alph(i)
4279         x(3)=omeg(i)
4280 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4281
4282         if (x(2).gt.pi-delta) then
4283           xtemp(1)=x(1)
4284           xtemp(2)=pi-delta
4285           xtemp(3)=x(3)
4286           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4287           xtemp(2)=pi
4288           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4289           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4290      &        escloci,dersc(2))
4291           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4292      &        ddersc0(1),dersc(1))
4293           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4294      &        ddersc0(3),dersc(3))
4295           xtemp(2)=pi-delta
4296           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4297           xtemp(2)=pi
4298           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4299           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4300      &            dersc0(2),esclocbi,dersc02)
4301           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4302      &            dersc12,dersc01)
4303           call splinthet(x(2),0.5d0*delta,ss,ssd)
4304           dersc0(1)=dersc01
4305           dersc0(2)=dersc02
4306           dersc0(3)=0.0d0
4307           do k=1,3
4308             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4309           enddo
4310           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4311 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4312 c    &             esclocbi,ss,ssd
4313           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4314 c         escloci=esclocbi
4315 c         write (iout,*) escloci
4316         else if (x(2).lt.delta) then
4317           xtemp(1)=x(1)
4318           xtemp(2)=delta
4319           xtemp(3)=x(3)
4320           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4321           xtemp(2)=0.0d0
4322           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4323           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4324      &        escloci,dersc(2))
4325           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4326      &        ddersc0(1),dersc(1))
4327           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4328      &        ddersc0(3),dersc(3))
4329           xtemp(2)=delta
4330           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4331           xtemp(2)=0.0d0
4332           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4333           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4334      &            dersc0(2),esclocbi,dersc02)
4335           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4336      &            dersc12,dersc01)
4337           dersc0(1)=dersc01
4338           dersc0(2)=dersc02
4339           dersc0(3)=0.0d0
4340           call splinthet(x(2),0.5d0*delta,ss,ssd)
4341           do k=1,3
4342             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4343           enddo
4344           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4345 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4346 c    &             esclocbi,ss,ssd
4347           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4348 c         write (iout,*) escloci
4349         else
4350           call enesc(x,escloci,dersc,ddummy,.false.)
4351         endif
4352
4353         escloc=escloc+escloci
4354 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4355
4356         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4357      &   wscloc*dersc(1)
4358         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4359         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4360     1   continue
4361       enddo
4362       return
4363       end
4364 C---------------------------------------------------------------------------
4365       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4366       implicit real*8 (a-h,o-z)
4367       include 'DIMENSIONS'
4368       include 'COMMON.GEO'
4369       include 'COMMON.LOCAL'
4370       include 'COMMON.IOUNITS'
4371       common /sccalc/ time11,time12,time112,theti,it,nlobit
4372       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4373       double precision contr(maxlob,-1:1)
4374       logical mixed
4375 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4376         escloc_i=0.0D0
4377         do j=1,3
4378           dersc(j)=0.0D0
4379           if (mixed) ddersc(j)=0.0d0
4380         enddo
4381         x3=x(3)
4382
4383 C Because of periodicity of the dependence of the SC energy in omega we have
4384 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4385 C To avoid underflows, first compute & store the exponents.
4386
4387         do iii=-1,1
4388
4389           x(3)=x3+iii*dwapi
4390
4391           do j=1,nlobit
4392             do k=1,3
4393               z(k)=x(k)-censc(k,j,it)
4394             enddo
4395             do k=1,3
4396               Axk=0.0D0
4397               do l=1,3
4398                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4399               enddo
4400               Ax(k,j,iii)=Axk
4401             enddo
4402             expfac=0.0D0
4403             do k=1,3
4404               expfac=expfac+Ax(k,j,iii)*z(k)
4405             enddo
4406             contr(j,iii)=expfac
4407           enddo ! j
4408
4409         enddo ! iii
4410
4411         x(3)=x3
4412 C As in the case of ebend, we want to avoid underflows in exponentiation and
4413 C subsequent NaNs and INFs in energy calculation.
4414 C Find the largest exponent
4415         emin=contr(1,-1)
4416         do iii=-1,1
4417           do j=1,nlobit
4418             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4419           enddo
4420         enddo
4421         emin=0.5D0*emin
4422 cd      print *,'it=',it,' emin=',emin
4423
4424 C Compute the contribution to SC energy and derivatives
4425         do iii=-1,1
4426
4427           do j=1,nlobit
4428             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4429 cd          print *,'j=',j,' expfac=',expfac
4430             escloc_i=escloc_i+expfac
4431             do k=1,3
4432               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4433             enddo
4434             if (mixed) then
4435               do k=1,3,2
4436                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4437      &            +gaussc(k,2,j,it))*expfac
4438               enddo
4439             endif
4440           enddo
4441
4442         enddo ! iii
4443
4444         dersc(1)=dersc(1)/cos(theti)**2
4445         ddersc(1)=ddersc(1)/cos(theti)**2
4446         ddersc(3)=ddersc(3)
4447
4448         escloci=-(dlog(escloc_i)-emin)
4449         do j=1,3
4450           dersc(j)=dersc(j)/escloc_i
4451         enddo
4452         if (mixed) then
4453           do j=1,3,2
4454             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4455           enddo
4456         endif
4457       return
4458       end
4459 C------------------------------------------------------------------------------
4460       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4461       implicit real*8 (a-h,o-z)
4462       include 'DIMENSIONS'
4463       include 'COMMON.GEO'
4464       include 'COMMON.LOCAL'
4465       include 'COMMON.IOUNITS'
4466       common /sccalc/ time11,time12,time112,theti,it,nlobit
4467       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4468       double precision contr(maxlob)
4469       logical mixed
4470
4471       escloc_i=0.0D0
4472
4473       do j=1,3
4474         dersc(j)=0.0D0
4475       enddo
4476
4477       do j=1,nlobit
4478         do k=1,2
4479           z(k)=x(k)-censc(k,j,it)
4480         enddo
4481         z(3)=dwapi
4482         do k=1,3
4483           Axk=0.0D0
4484           do l=1,3
4485             Axk=Axk+gaussc(l,k,j,it)*z(l)
4486           enddo
4487           Ax(k,j)=Axk
4488         enddo
4489         expfac=0.0D0
4490         do k=1,3
4491           expfac=expfac+Ax(k,j)*z(k)
4492         enddo
4493         contr(j)=expfac
4494       enddo ! j
4495
4496 C As in the case of ebend, we want to avoid underflows in exponentiation and
4497 C subsequent NaNs and INFs in energy calculation.
4498 C Find the largest exponent
4499       emin=contr(1)
4500       do j=1,nlobit
4501         if (emin.gt.contr(j)) emin=contr(j)
4502       enddo
4503       emin=0.5D0*emin
4504
4505 C Compute the contribution to SC energy and derivatives
4506
4507       dersc12=0.0d0
4508       do j=1,nlobit
4509         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4510         escloc_i=escloc_i+expfac
4511         do k=1,2
4512           dersc(k)=dersc(k)+Ax(k,j)*expfac
4513         enddo
4514         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4515      &            +gaussc(1,2,j,it))*expfac
4516         dersc(3)=0.0d0
4517       enddo
4518
4519       dersc(1)=dersc(1)/cos(theti)**2
4520       dersc12=dersc12/cos(theti)**2
4521       escloci=-(dlog(escloc_i)-emin)
4522       do j=1,2
4523         dersc(j)=dersc(j)/escloc_i
4524       enddo
4525       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4526       return
4527       end
4528 #else
4529 c----------------------------------------------------------------------------------
4530       subroutine esc(escloc)
4531 C Calculate the local energy of a side chain and its derivatives in the
4532 C corresponding virtual-bond valence angles THETA and the spherical angles
4533 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4534 C added by Urszula Kozlowska. 07/11/2007
4535 C
4536       implicit real*8 (a-h,o-z)
4537       include 'DIMENSIONS'
4538       include 'COMMON.GEO'
4539       include 'COMMON.LOCAL'
4540       include 'COMMON.VAR'
4541       include 'COMMON.SCROT'
4542       include 'COMMON.INTERACT'
4543       include 'COMMON.DERIV'
4544       include 'COMMON.CHAIN'
4545       include 'COMMON.IOUNITS'
4546       include 'COMMON.NAMES'
4547       include 'COMMON.FFIELD'
4548       include 'COMMON.CONTROL'
4549       include 'COMMON.VECTORS'
4550       double precision x_prime(3),y_prime(3),z_prime(3)
4551      &    , sumene,dsc_i,dp2_i,x(65),
4552      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4553      &    de_dxx,de_dyy,de_dzz,de_dt
4554       double precision s1_t,s1_6_t,s2_t,s2_6_t
4555       double precision
4556      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4557      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4558      & dt_dCi(3),dt_dCi1(3)
4559       common /sccalc/ time11,time12,time112,theti,it,nlobit
4560       delta=0.02d0*pi
4561       escloc=0.0D0
4562       do i=loc_start,loc_end
4563         costtab(i+1) =dcos(theta(i+1))
4564         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4565         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4566         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4567         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4568         cosfac=dsqrt(cosfac2)
4569         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4570         sinfac=dsqrt(sinfac2)
4571         it=itype(i)
4572         if (it.eq.10) goto 1
4573 c
4574 C  Compute the axes of tghe local cartesian coordinates system; store in
4575 c   x_prime, y_prime and z_prime
4576 c
4577         do j=1,3
4578           x_prime(j) = 0.00
4579           y_prime(j) = 0.00
4580           z_prime(j) = 0.00
4581         enddo
4582 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4583 C     &   dc_norm(3,i+nres)
4584         do j = 1,3
4585           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4586           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4587         enddo
4588         do j = 1,3
4589           z_prime(j) = -uz(j,i-1)
4590         enddo
4591 c       write (2,*) "i",i
4592 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4593 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4594 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4595 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4596 c      & " xy",scalar(x_prime(1),y_prime(1)),
4597 c      & " xz",scalar(x_prime(1),z_prime(1)),
4598 c      & " yy",scalar(y_prime(1),y_prime(1)),
4599 c      & " yz",scalar(y_prime(1),z_prime(1)),
4600 c      & " zz",scalar(z_prime(1),z_prime(1))
4601 c
4602 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4603 C to local coordinate system. Store in xx, yy, zz.
4604 c
4605         xx=0.0d0
4606         yy=0.0d0
4607         zz=0.0d0
4608         do j = 1,3
4609           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4610           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4611           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4612         enddo
4613
4614         xxtab(i)=xx
4615         yytab(i)=yy
4616         zztab(i)=zz
4617 C
4618 C Compute the energy of the ith side cbain
4619 C
4620 c        write (2,*) "xx",xx," yy",yy," zz",zz
4621         it=itype(i)
4622         do j = 1,65
4623           x(j) = sc_parmin(j,it)
4624         enddo
4625 #ifdef CHECK_COORD
4626 Cc diagnostics - remove later
4627         xx1 = dcos(alph(2))
4628         yy1 = dsin(alph(2))*dcos(omeg(2))
4629         zz1 = -dsin(alph(2))*dsin(omeg(2))
4630         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4631      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4632      &    xx1,yy1,zz1
4633 C,"  --- ", xx_w,yy_w,zz_w
4634 c end diagnostics
4635 #endif
4636         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4637      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4638      &   + x(10)*yy*zz
4639         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4640      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4641      & + x(20)*yy*zz
4642         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4643      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4644      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4645      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4646      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4647      &  +x(40)*xx*yy*zz
4648         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4649      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4650      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4651      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4652      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4653      &  +x(60)*xx*yy*zz
4654         dsc_i   = 0.743d0+x(61)
4655         dp2_i   = 1.9d0+x(62)
4656         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4657      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4658         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4659      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4660         s1=(1+x(63))/(0.1d0 + dscp1)
4661         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4662         s2=(1+x(65))/(0.1d0 + dscp2)
4663         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4664         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4665      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4666 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4667 c     &   sumene4,
4668 c     &   dscp1,dscp2,sumene
4669 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4670         escloc = escloc + sumene
4671 c        write (2,*) "escloc",escloc
4672         if (.not. calc_grad) goto 1
4673 #ifdef DEBUG
4674 C
4675 C This section to check the numerical derivatives of the energy of ith side
4676 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4677 C #define DEBUG in the code to turn it on.
4678 C
4679         write (2,*) "sumene               =",sumene
4680         aincr=1.0d-7
4681         xxsave=xx
4682         xx=xx+aincr
4683         write (2,*) xx,yy,zz
4684         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4685         de_dxx_num=(sumenep-sumene)/aincr
4686         xx=xxsave
4687         write (2,*) "xx+ sumene from enesc=",sumenep
4688         yysave=yy
4689         yy=yy+aincr
4690         write (2,*) xx,yy,zz
4691         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4692         de_dyy_num=(sumenep-sumene)/aincr
4693         yy=yysave
4694         write (2,*) "yy+ sumene from enesc=",sumenep
4695         zzsave=zz
4696         zz=zz+aincr
4697         write (2,*) xx,yy,zz
4698         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4699         de_dzz_num=(sumenep-sumene)/aincr
4700         zz=zzsave
4701         write (2,*) "zz+ sumene from enesc=",sumenep
4702         costsave=cost2tab(i+1)
4703         sintsave=sint2tab(i+1)
4704         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4705         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4706         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4707         de_dt_num=(sumenep-sumene)/aincr
4708         write (2,*) " t+ sumene from enesc=",sumenep
4709         cost2tab(i+1)=costsave
4710         sint2tab(i+1)=sintsave
4711 C End of diagnostics section.
4712 #endif
4713 C
4714 C Compute the gradient of esc
4715 C
4716         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4717         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4718         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4719         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4720         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4721         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4722         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4723         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4724         pom1=(sumene3*sint2tab(i+1)+sumene1)
4725      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4726         pom2=(sumene4*cost2tab(i+1)+sumene2)
4727      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4728         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4729         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4730      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4731      &  +x(40)*yy*zz
4732         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4733         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4734      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4735      &  +x(60)*yy*zz
4736         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4737      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4738      &        +(pom1+pom2)*pom_dx
4739 #ifdef DEBUG
4740         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4741 #endif
4742 C
4743         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4744         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4745      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4746      &  +x(40)*xx*zz
4747         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4748         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4749      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4750      &  +x(59)*zz**2 +x(60)*xx*zz
4751         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4752      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4753      &        +(pom1-pom2)*pom_dy
4754 #ifdef DEBUG
4755         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4756 #endif
4757 C
4758         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4759      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4760      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4761      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4762      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4763      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4764      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4765      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4766 #ifdef DEBUG
4767         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4768 #endif
4769 C
4770         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4771      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4772      &  +pom1*pom_dt1+pom2*pom_dt2
4773 #ifdef DEBUG
4774         write(2,*), "de_dt = ", de_dt,de_dt_num
4775 #endif
4776 c
4777 C
4778        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4779        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4780        cosfac2xx=cosfac2*xx
4781        sinfac2yy=sinfac2*yy
4782        do k = 1,3
4783          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4784      &      vbld_inv(i+1)
4785          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4786      &      vbld_inv(i)
4787          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4788          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4789 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4790 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4791 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4792 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4793          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4794          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4795          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4796          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4797          dZZ_Ci1(k)=0.0d0
4798          dZZ_Ci(k)=0.0d0
4799          do j=1,3
4800            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4801            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4802          enddo
4803
4804          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4805          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4806          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4807 c
4808          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4809          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4810        enddo
4811
4812        do k=1,3
4813          dXX_Ctab(k,i)=dXX_Ci(k)
4814          dXX_C1tab(k,i)=dXX_Ci1(k)
4815          dYY_Ctab(k,i)=dYY_Ci(k)
4816          dYY_C1tab(k,i)=dYY_Ci1(k)
4817          dZZ_Ctab(k,i)=dZZ_Ci(k)
4818          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4819          dXX_XYZtab(k,i)=dXX_XYZ(k)
4820          dYY_XYZtab(k,i)=dYY_XYZ(k)
4821          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4822        enddo
4823
4824        do k = 1,3
4825 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4826 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4827 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4828 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4829 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4830 c     &    dt_dci(k)
4831 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4832 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4833          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4834      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4835          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4836      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4837          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4838      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4839        enddo
4840 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4841 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4842
4843 C to check gradient call subroutine check_grad
4844
4845     1 continue
4846       enddo
4847       return
4848       end
4849 #endif
4850 c------------------------------------------------------------------------------
4851       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4852 C
4853 C This procedure calculates two-body contact function g(rij) and its derivative:
4854 C
4855 C           eps0ij                                     !       x < -1
4856 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4857 C            0                                         !       x > 1
4858 C
4859 C where x=(rij-r0ij)/delta
4860 C
4861 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4862 C
4863       implicit none
4864       double precision rij,r0ij,eps0ij,fcont,fprimcont
4865       double precision x,x2,x4,delta
4866 c     delta=0.02D0*r0ij
4867 c      delta=0.2D0*r0ij
4868       x=(rij-r0ij)/delta
4869       if (x.lt.-1.0D0) then
4870         fcont=eps0ij
4871         fprimcont=0.0D0
4872       else if (x.le.1.0D0) then
4873         x2=x*x
4874         x4=x2*x2
4875         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4876         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4877       else
4878         fcont=0.0D0
4879         fprimcont=0.0D0
4880       endif
4881       return
4882       end
4883 c------------------------------------------------------------------------------
4884       subroutine splinthet(theti,delta,ss,ssder)
4885       implicit real*8 (a-h,o-z)
4886       include 'DIMENSIONS'
4887       include 'sizesclu.dat'
4888       include 'COMMON.VAR'
4889       include 'COMMON.GEO'
4890       thetup=pi-delta
4891       thetlow=delta
4892       if (theti.gt.pipol) then
4893         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4894       else
4895         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4896         ssder=-ssder
4897       endif
4898       return
4899       end
4900 c------------------------------------------------------------------------------
4901       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4902       implicit none
4903       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4904       double precision ksi,ksi2,ksi3,a1,a2,a3
4905       a1=fprim0*delta/(f1-f0)
4906       a2=3.0d0-2.0d0*a1
4907       a3=a1-2.0d0
4908       ksi=(x-x0)/delta
4909       ksi2=ksi*ksi
4910       ksi3=ksi2*ksi
4911       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4912       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4913       return
4914       end
4915 c------------------------------------------------------------------------------
4916       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4917       implicit none
4918       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4919       double precision ksi,ksi2,ksi3,a1,a2,a3
4920       ksi=(x-x0)/delta
4921       ksi2=ksi*ksi
4922       ksi3=ksi2*ksi
4923       a1=fprim0x*delta
4924       a2=3*(f1x-f0x)-2*fprim0x*delta
4925       a3=fprim0x*delta-2*(f1x-f0x)
4926       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4927       return
4928       end
4929 C-----------------------------------------------------------------------------
4930 #ifdef CRYST_TOR
4931 C-----------------------------------------------------------------------------
4932       subroutine etor(etors,edihcnstr,fact)
4933       implicit real*8 (a-h,o-z)
4934       include 'DIMENSIONS'
4935       include 'sizesclu.dat'
4936       include 'COMMON.VAR'
4937       include 'COMMON.GEO'
4938       include 'COMMON.LOCAL'
4939       include 'COMMON.TORSION'
4940       include 'COMMON.INTERACT'
4941       include 'COMMON.DERIV'
4942       include 'COMMON.CHAIN'
4943       include 'COMMON.NAMES'
4944       include 'COMMON.IOUNITS'
4945       include 'COMMON.FFIELD'
4946       include 'COMMON.TORCNSTR'
4947       logical lprn
4948 C Set lprn=.true. for debugging
4949       lprn=.false.
4950 c      lprn=.true.
4951       etors=0.0D0
4952       do i=iphi_start,iphi_end
4953         itori=itortyp(itype(i-2))
4954         itori1=itortyp(itype(i-1))
4955         phii=phi(i)
4956         gloci=0.0D0
4957 C Proline-Proline pair is a special case...
4958         if (itori.eq.3 .and. itori1.eq.3) then
4959           if (phii.gt.-dwapi3) then
4960             cosphi=dcos(3*phii)
4961             fac=1.0D0/(1.0D0-cosphi)
4962             etorsi=v1(1,3,3)*fac
4963             etorsi=etorsi+etorsi
4964             etors=etors+etorsi-v1(1,3,3)
4965             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4966           endif
4967           do j=1,3
4968             v1ij=v1(j+1,itori,itori1)
4969             v2ij=v2(j+1,itori,itori1)
4970             cosphi=dcos(j*phii)
4971             sinphi=dsin(j*phii)
4972             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4973             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4974           enddo
4975         else
4976           do j=1,nterm_old
4977             v1ij=v1(j,itori,itori1)
4978             v2ij=v2(j,itori,itori1)
4979             cosphi=dcos(j*phii)
4980             sinphi=dsin(j*phii)
4981             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4982             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4983           enddo
4984         endif
4985         if (lprn)
4986      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4987      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4988      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4989         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4990 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4991       enddo
4992 ! 6/20/98 - dihedral angle constraints
4993       edihcnstr=0.0d0
4994       do i=1,ndih_constr
4995         itori=idih_constr(i)
4996         phii=phi(itori)
4997         difi=pinorm(phii-phi0(i))
4998         if (difi.gt.drange(i)) then
4999           difi=difi-drange(i)
5000           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5001           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5002         else if (difi.lt.-drange(i)) then
5003           difi=difi+drange(i)
5004           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5005           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5006         endif
5007 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5008 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5009       enddo
5010       write (iout,*) 'edihcnstr',edihcnstr
5011       return
5012       end
5013 c------------------------------------------------------------------------------
5014 #else
5015       subroutine etor(etors,edihcnstr,fact)
5016       implicit real*8 (a-h,o-z)
5017       include 'DIMENSIONS'
5018       include 'sizesclu.dat'
5019       include 'COMMON.VAR'
5020       include 'COMMON.GEO'
5021       include 'COMMON.LOCAL'
5022       include 'COMMON.TORSION'
5023       include 'COMMON.INTERACT'
5024       include 'COMMON.DERIV'
5025       include 'COMMON.CHAIN'
5026       include 'COMMON.NAMES'
5027       include 'COMMON.IOUNITS'
5028       include 'COMMON.FFIELD'
5029       include 'COMMON.TORCNSTR'
5030       logical lprn
5031 C Set lprn=.true. for debugging
5032       lprn=.false.
5033 c      lprn=.true.
5034       etors=0.0D0
5035       do i=iphi_start,iphi_end
5036         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5037         itori=itortyp(itype(i-2))
5038         itori1=itortyp(itype(i-1))
5039         phii=phi(i)
5040         gloci=0.0D0
5041 C Regular cosine and sine terms
5042         do j=1,nterm(itori,itori1)
5043           v1ij=v1(j,itori,itori1)
5044           v2ij=v2(j,itori,itori1)
5045           cosphi=dcos(j*phii)
5046           sinphi=dsin(j*phii)
5047           etors=etors+v1ij*cosphi+v2ij*sinphi
5048           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5049         enddo
5050 C Lorentz terms
5051 C                         v1
5052 C  E = SUM ----------------------------------- - v1
5053 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5054 C
5055         cosphi=dcos(0.5d0*phii)
5056         sinphi=dsin(0.5d0*phii)
5057         do j=1,nlor(itori,itori1)
5058           vl1ij=vlor1(j,itori,itori1)
5059           vl2ij=vlor2(j,itori,itori1)
5060           vl3ij=vlor3(j,itori,itori1)
5061           pom=vl2ij*cosphi+vl3ij*sinphi
5062           pom1=1.0d0/(pom*pom+1.0d0)
5063           etors=etors+vl1ij*pom1
5064           pom=-pom*pom1*pom1
5065           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5066         enddo
5067 C Subtract the constant term
5068         etors=etors-v0(itori,itori1)
5069         if (lprn)
5070      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5071      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5072      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5073         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5074 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5075  1215   continue
5076       enddo
5077 ! 6/20/98 - dihedral angle constraints
5078       edihcnstr=0.0d0
5079 c      write (iout,*) "Dihedral angle restraint energy"
5080       do i=1,ndih_constr
5081         itori=idih_constr(i)
5082         phii=phi(itori)
5083         difi=pinorm(phii-phi0(i))
5084 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5085 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5086         if (difi.gt.drange(i)) then
5087           difi=difi-drange(i)
5088           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5089           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5090 c          write (iout,*) 0.25d0*ftors*difi**4
5091         else if (difi.lt.-drange(i)) then
5092           difi=difi+drange(i)
5093           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5094           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5095 c          write (iout,*) 0.25d0*ftors*difi**4
5096         endif
5097       enddo
5098 c      write (iout,*) 'edihcnstr',edihcnstr
5099       return
5100       end
5101 c----------------------------------------------------------------------------
5102       subroutine etor_d(etors_d,fact2)
5103 C 6/23/01 Compute double torsional energy
5104       implicit real*8 (a-h,o-z)
5105       include 'DIMENSIONS'
5106       include 'sizesclu.dat'
5107       include 'COMMON.VAR'
5108       include 'COMMON.GEO'
5109       include 'COMMON.LOCAL'
5110       include 'COMMON.TORSION'
5111       include 'COMMON.INTERACT'
5112       include 'COMMON.DERIV'
5113       include 'COMMON.CHAIN'
5114       include 'COMMON.NAMES'
5115       include 'COMMON.IOUNITS'
5116       include 'COMMON.FFIELD'
5117       include 'COMMON.TORCNSTR'
5118       logical lprn
5119 C Set lprn=.true. for debugging
5120       lprn=.false.
5121 c     lprn=.true.
5122       etors_d=0.0D0
5123       do i=iphi_start,iphi_end-1
5124         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5125      &     goto 1215
5126         itori=itortyp(itype(i-2))
5127         itori1=itortyp(itype(i-1))
5128         itori2=itortyp(itype(i))
5129         phii=phi(i)
5130         phii1=phi(i+1)
5131         gloci1=0.0D0
5132         gloci2=0.0D0
5133 C Regular cosine and sine terms
5134         do j=1,ntermd_1(itori,itori1,itori2)
5135           v1cij=v1c(1,j,itori,itori1,itori2)
5136           v1sij=v1s(1,j,itori,itori1,itori2)
5137           v2cij=v1c(2,j,itori,itori1,itori2)
5138           v2sij=v1s(2,j,itori,itori1,itori2)
5139           cosphi1=dcos(j*phii)
5140           sinphi1=dsin(j*phii)
5141           cosphi2=dcos(j*phii1)
5142           sinphi2=dsin(j*phii1)
5143           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5144      &     v2cij*cosphi2+v2sij*sinphi2
5145           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5146           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5147         enddo
5148         do k=2,ntermd_2(itori,itori1,itori2)
5149           do l=1,k-1
5150             v1cdij = v2c(k,l,itori,itori1,itori2)
5151             v2cdij = v2c(l,k,itori,itori1,itori2)
5152             v1sdij = v2s(k,l,itori,itori1,itori2)
5153             v2sdij = v2s(l,k,itori,itori1,itori2)
5154             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5155             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5156             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5157             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5158             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5159      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5160             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5161      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5162             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5163      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5164           enddo
5165         enddo
5166         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5167         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5168  1215   continue
5169       enddo
5170       return
5171       end
5172 #endif
5173 c------------------------------------------------------------------------------
5174       subroutine eback_sc_corr(esccor,fact)
5175 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5176 c        conformational states; temporarily implemented as differences
5177 c        between UNRES torsional potentials (dependent on three types of
5178 c        residues) and the torsional potentials dependent on all 20 types
5179 c        of residues computed from AM1 energy surfaces of terminally-blocked
5180 c        amino-acid residues.
5181       implicit real*8 (a-h,o-z)
5182       include 'DIMENSIONS'
5183       include 'COMMON.VAR'
5184       include 'COMMON.GEO'
5185       include 'COMMON.LOCAL'
5186       include 'COMMON.TORSION'
5187       include 'COMMON.SCCOR'
5188       include 'COMMON.INTERACT'
5189       include 'COMMON.DERIV'
5190       include 'COMMON.CHAIN'
5191       include 'COMMON.NAMES'
5192       include 'COMMON.IOUNITS'
5193       include 'COMMON.FFIELD'
5194       include 'COMMON.CONTROL'
5195       logical lprn
5196 C Set lprn=.true. for debugging
5197       lprn=.false.
5198 c      lprn=.true.
5199 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5200       esccor=0.0D0
5201       do i=itau_start,itau_end
5202         esccor_ii=0.0D0
5203         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5204         isccori=isccortyp(itype(i-2))
5205         isccori1=isccortyp(itype(i-1))
5206         phii=phi(i)
5207 cccc  Added 9 May 2012
5208 cc Tauangle is torsional engle depending on the value of first digit
5209 c(see comment below)
5210 cc Omicron is flat angle depending on the value of first digit
5211 c(see comment below)
5212
5213
5214         do intertyp=1,3 !intertyp
5215 cc Added 09 May 2012 (Adasko)
5216 cc  Intertyp means interaction type of backbone mainchain correlation:
5217 c   1 = SC...Ca...Ca...Ca
5218 c   2 = Ca...Ca...Ca...SC
5219 c   3 = SC...Ca...Ca...SCi
5220         gloci=0.0D0
5221         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5222      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5223      &      (itype(i-1).eq.21)))
5224      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5225      &     .or.(itype(i-2).eq.21)))
5226      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5227      &      (itype(i-1).eq.21)))) cycle
5228         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5229         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5230      & cycle
5231         do j=1,nterm_sccor(isccori,isccori1)
5232           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5233           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5234           cosphi=dcos(j*tauangle(intertyp,i))
5235           sinphi=dsin(j*tauangle(intertyp,i))
5236           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5237 #ifdef DEBUG
5238           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5239 #endif
5240           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5241         enddo
5242         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5243 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5244 c     &gloc_sc(intertyp,i-3,icg)
5245         if (lprn)
5246      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5247      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5248      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5249      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5250         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5251        enddo !intertyp
5252 #ifdef DEBUG
5253        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5254 #endif
5255       enddo
5256
5257       return
5258       end
5259 c------------------------------------------------------------------------------
5260       subroutine multibody(ecorr)
5261 C This subroutine calculates multi-body contributions to energy following
5262 C the idea of Skolnick et al. If side chains I and J make a contact and
5263 C at the same time side chains I+1 and J+1 make a contact, an extra
5264 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5265       implicit real*8 (a-h,o-z)
5266       include 'DIMENSIONS'
5267       include 'COMMON.IOUNITS'
5268       include 'COMMON.DERIV'
5269       include 'COMMON.INTERACT'
5270       include 'COMMON.CONTACTS'
5271       double precision gx(3),gx1(3)
5272       logical lprn
5273
5274 C Set lprn=.true. for debugging
5275       lprn=.false.
5276
5277       if (lprn) then
5278         write (iout,'(a)') 'Contact function values:'
5279         do i=nnt,nct-2
5280           write (iout,'(i2,20(1x,i2,f10.5))')
5281      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5282         enddo
5283       endif
5284       ecorr=0.0D0
5285       do i=nnt,nct
5286         do j=1,3
5287           gradcorr(j,i)=0.0D0
5288           gradxorr(j,i)=0.0D0
5289         enddo
5290       enddo
5291       do i=nnt,nct-2
5292
5293         DO ISHIFT = 3,4
5294
5295         i1=i+ishift
5296         num_conti=num_cont(i)
5297         num_conti1=num_cont(i1)
5298         do jj=1,num_conti
5299           j=jcont(jj,i)
5300           do kk=1,num_conti1
5301             j1=jcont(kk,i1)
5302             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5303 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5304 cd   &                   ' ishift=',ishift
5305 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5306 C The system gains extra energy.
5307               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5308             endif   ! j1==j+-ishift
5309           enddo     ! kk
5310         enddo       ! jj
5311
5312         ENDDO ! ISHIFT
5313
5314       enddo         ! i
5315       return
5316       end
5317 c------------------------------------------------------------------------------
5318       double precision function esccorr(i,j,k,l,jj,kk)
5319       implicit real*8 (a-h,o-z)
5320       include 'DIMENSIONS'
5321       include 'COMMON.IOUNITS'
5322       include 'COMMON.DERIV'
5323       include 'COMMON.INTERACT'
5324       include 'COMMON.CONTACTS'
5325       double precision gx(3),gx1(3)
5326       logical lprn
5327       lprn=.false.
5328       eij=facont(jj,i)
5329       ekl=facont(kk,k)
5330 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5331 C Calculate the multi-body contribution to energy.
5332 C Calculate multi-body contributions to the gradient.
5333 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5334 cd   & k,l,(gacont(m,kk,k),m=1,3)
5335       do m=1,3
5336         gx(m) =ekl*gacont(m,jj,i)
5337         gx1(m)=eij*gacont(m,kk,k)
5338         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5339         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5340         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5341         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5342       enddo
5343       do m=i,j-1
5344         do ll=1,3
5345           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5346         enddo
5347       enddo
5348       do m=k,l-1
5349         do ll=1,3
5350           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5351         enddo
5352       enddo
5353       esccorr=-eij*ekl
5354       return
5355       end
5356 c------------------------------------------------------------------------------
5357 #ifdef MPL
5358       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5359       implicit real*8 (a-h,o-z)
5360       include 'DIMENSIONS'
5361       integer dimen1,dimen2,atom,indx
5362       double precision buffer(dimen1,dimen2)
5363       double precision zapas
5364       common /contacts_hb/ zapas(3,20,maxres,7),
5365      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5366      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5367       num_kont=num_cont_hb(atom)
5368       do i=1,num_kont
5369         do k=1,7
5370           do j=1,3
5371             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5372           enddo ! j
5373         enddo ! k
5374         buffer(i,indx+22)=facont_hb(i,atom)
5375         buffer(i,indx+23)=ees0p(i,atom)
5376         buffer(i,indx+24)=ees0m(i,atom)
5377         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5378       enddo ! i
5379       buffer(1,indx+26)=dfloat(num_kont)
5380       return
5381       end
5382 c------------------------------------------------------------------------------
5383       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5384       implicit real*8 (a-h,o-z)
5385       include 'DIMENSIONS'
5386       integer dimen1,dimen2,atom,indx
5387       double precision buffer(dimen1,dimen2)
5388       double precision zapas
5389       common /contacts_hb/ zapas(3,20,maxres,7),
5390      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5391      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5392       num_kont=buffer(1,indx+26)
5393       num_kont_old=num_cont_hb(atom)
5394       num_cont_hb(atom)=num_kont+num_kont_old
5395       do i=1,num_kont
5396         ii=i+num_kont_old
5397         do k=1,7
5398           do j=1,3
5399             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5400           enddo ! j
5401         enddo ! k
5402         facont_hb(ii,atom)=buffer(i,indx+22)
5403         ees0p(ii,atom)=buffer(i,indx+23)
5404         ees0m(ii,atom)=buffer(i,indx+24)
5405         jcont_hb(ii,atom)=buffer(i,indx+25)
5406       enddo ! i
5407       return
5408       end
5409 c------------------------------------------------------------------------------
5410 #endif
5411       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5412 C This subroutine calculates multi-body contributions to hydrogen-bonding
5413       implicit real*8 (a-h,o-z)
5414       include 'DIMENSIONS'
5415       include 'sizesclu.dat'
5416       include 'COMMON.IOUNITS'
5417 #ifdef MPL
5418       include 'COMMON.INFO'
5419 #endif
5420       include 'COMMON.FFIELD'
5421       include 'COMMON.DERIV'
5422       include 'COMMON.INTERACT'
5423       include 'COMMON.CONTACTS'
5424 #ifdef MPL
5425       parameter (max_cont=maxconts)
5426       parameter (max_dim=2*(8*3+2))
5427       parameter (msglen1=max_cont*max_dim*4)
5428       parameter (msglen2=2*msglen1)
5429       integer source,CorrelType,CorrelID,Error
5430       double precision buffer(max_cont,max_dim)
5431 #endif
5432       double precision gx(3),gx1(3)
5433       logical lprn,ldone
5434
5435 C Set lprn=.true. for debugging
5436       lprn=.false.
5437 #ifdef MPL
5438       n_corr=0
5439       n_corr1=0
5440       if (fgProcs.le.1) goto 30
5441       if (lprn) then
5442         write (iout,'(a)') 'Contact function values:'
5443         do i=nnt,nct-2
5444           write (iout,'(2i3,50(1x,i2,f5.2))')
5445      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5446      &    j=1,num_cont_hb(i))
5447         enddo
5448       endif
5449 C Caution! Following code assumes that electrostatic interactions concerning
5450 C a given atom are split among at most two processors!
5451       CorrelType=477
5452       CorrelID=MyID+1
5453       ldone=.false.
5454       do i=1,max_cont
5455         do j=1,max_dim
5456           buffer(i,j)=0.0D0
5457         enddo
5458       enddo
5459       mm=mod(MyRank,2)
5460 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5461       if (mm) 20,20,10
5462    10 continue
5463 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5464       if (MyRank.gt.0) then
5465 C Send correlation contributions to the preceding processor
5466         msglen=msglen1
5467         nn=num_cont_hb(iatel_s)
5468         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5469 cd      write (iout,*) 'The BUFFER array:'
5470 cd      do i=1,nn
5471 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5472 cd      enddo
5473         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5474           msglen=msglen2
5475             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5476 C Clear the contacts of the atom passed to the neighboring processor
5477         nn=num_cont_hb(iatel_s+1)
5478 cd      do i=1,nn
5479 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5480 cd      enddo
5481             num_cont_hb(iatel_s)=0
5482         endif
5483 cd      write (iout,*) 'Processor ',MyID,MyRank,
5484 cd   & ' is sending correlation contribution to processor',MyID-1,
5485 cd   & ' msglen=',msglen
5486 cd      write (*,*) 'Processor ',MyID,MyRank,
5487 cd   & ' is sending correlation contribution to processor',MyID-1,
5488 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5489         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5490 cd      write (iout,*) 'Processor ',MyID,
5491 cd   & ' has sent correlation contribution to processor',MyID-1,
5492 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5493 cd      write (*,*) 'Processor ',MyID,
5494 cd   & ' has sent correlation contribution to processor',MyID-1,
5495 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5496         msglen=msglen1
5497       endif ! (MyRank.gt.0)
5498       if (ldone) goto 30
5499       ldone=.true.
5500    20 continue
5501 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5502       if (MyRank.lt.fgProcs-1) then
5503 C Receive correlation contributions from the next processor
5504         msglen=msglen1
5505         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5506 cd      write (iout,*) 'Processor',MyID,
5507 cd   & ' is receiving correlation contribution from processor',MyID+1,
5508 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5509 cd      write (*,*) 'Processor',MyID,
5510 cd   & ' is receiving correlation contribution from processor',MyID+1,
5511 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5512         nbytes=-1
5513         do while (nbytes.le.0)
5514           call mp_probe(MyID+1,CorrelType,nbytes)
5515         enddo
5516 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5517         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5518 cd      write (iout,*) 'Processor',MyID,
5519 cd   & ' has received correlation contribution from processor',MyID+1,
5520 cd   & ' msglen=',msglen,' nbytes=',nbytes
5521 cd      write (iout,*) 'The received BUFFER array:'
5522 cd      do i=1,max_cont
5523 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5524 cd      enddo
5525         if (msglen.eq.msglen1) then
5526           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5527         else if (msglen.eq.msglen2)  then
5528           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5529           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5530         else
5531           write (iout,*)
5532      & 'ERROR!!!! message length changed while processing correlations.'
5533           write (*,*)
5534      & 'ERROR!!!! message length changed while processing correlations.'
5535           call mp_stopall(Error)
5536         endif ! msglen.eq.msglen1
5537       endif ! MyRank.lt.fgProcs-1
5538       if (ldone) goto 30
5539       ldone=.true.
5540       goto 10
5541    30 continue
5542 #endif
5543       if (lprn) then
5544         write (iout,'(a)') 'Contact function values:'
5545         do i=nnt,nct-2
5546           write (iout,'(2i3,50(1x,i2,f5.2))')
5547      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5548      &    j=1,num_cont_hb(i))
5549         enddo
5550       endif
5551       ecorr=0.0D0
5552 C Remove the loop below after debugging !!!
5553       do i=nnt,nct
5554         do j=1,3
5555           gradcorr(j,i)=0.0D0
5556           gradxorr(j,i)=0.0D0
5557         enddo
5558       enddo
5559 C Calculate the local-electrostatic correlation terms
5560       do i=iatel_s,iatel_e+1
5561         i1=i+1
5562         num_conti=num_cont_hb(i)
5563         num_conti1=num_cont_hb(i+1)
5564         do jj=1,num_conti
5565           j=jcont_hb(jj,i)
5566           do kk=1,num_conti1
5567             j1=jcont_hb(kk,i1)
5568 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5569 c     &         ' jj=',jj,' kk=',kk
5570             if (j1.eq.j+1 .or. j1.eq.j-1) then
5571 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5572 C The system gains extra energy.
5573               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5574               n_corr=n_corr+1
5575             else if (j1.eq.j) then
5576 C Contacts I-J and I-(J+1) occur simultaneously.
5577 C The system loses extra energy.
5578 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5579             endif
5580           enddo ! kk
5581           do kk=1,num_conti
5582             j1=jcont_hb(kk,i)
5583 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5584 c    &         ' jj=',jj,' kk=',kk
5585             if (j1.eq.j+1) then
5586 C Contacts I-J and (I+1)-J occur simultaneously.
5587 C The system loses extra energy.
5588 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5589             endif ! j1==j+1
5590           enddo ! kk
5591         enddo ! jj
5592       enddo ! i
5593       return
5594       end
5595 c------------------------------------------------------------------------------
5596       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5597      &  n_corr1)
5598 C This subroutine calculates multi-body contributions to hydrogen-bonding
5599       implicit real*8 (a-h,o-z)
5600       include 'DIMENSIONS'
5601       include 'sizesclu.dat'
5602       include 'COMMON.IOUNITS'
5603 #ifdef MPL
5604       include 'COMMON.INFO'
5605 #endif
5606       include 'COMMON.FFIELD'
5607       include 'COMMON.DERIV'
5608       include 'COMMON.INTERACT'
5609       include 'COMMON.CONTACTS'
5610 #ifdef MPL
5611       parameter (max_cont=maxconts)
5612       parameter (max_dim=2*(8*3+2))
5613       parameter (msglen1=max_cont*max_dim*4)
5614       parameter (msglen2=2*msglen1)
5615       integer source,CorrelType,CorrelID,Error
5616       double precision buffer(max_cont,max_dim)
5617 #endif
5618       double precision gx(3),gx1(3)
5619       logical lprn,ldone
5620
5621 C Set lprn=.true. for debugging
5622       lprn=.false.
5623       eturn6=0.0d0
5624       ecorr6=0.0d0
5625 #ifdef MPL
5626       n_corr=0
5627       n_corr1=0
5628       if (fgProcs.le.1) goto 30
5629       if (lprn) then
5630         write (iout,'(a)') 'Contact function values:'
5631         do i=nnt,nct-2
5632           write (iout,'(2i3,50(1x,i2,f5.2))')
5633      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5634      &    j=1,num_cont_hb(i))
5635         enddo
5636       endif
5637 C Caution! Following code assumes that electrostatic interactions concerning
5638 C a given atom are split among at most two processors!
5639       CorrelType=477
5640       CorrelID=MyID+1
5641       ldone=.false.
5642       do i=1,max_cont
5643         do j=1,max_dim
5644           buffer(i,j)=0.0D0
5645         enddo
5646       enddo
5647       mm=mod(MyRank,2)
5648 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5649       if (mm) 20,20,10
5650    10 continue
5651 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5652       if (MyRank.gt.0) then
5653 C Send correlation contributions to the preceding processor
5654         msglen=msglen1
5655         nn=num_cont_hb(iatel_s)
5656         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5657 cd      write (iout,*) 'The BUFFER array:'
5658 cd      do i=1,nn
5659 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5660 cd      enddo
5661         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5662           msglen=msglen2
5663             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5664 C Clear the contacts of the atom passed to the neighboring processor
5665         nn=num_cont_hb(iatel_s+1)
5666 cd      do i=1,nn
5667 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5668 cd      enddo
5669             num_cont_hb(iatel_s)=0
5670         endif
5671 cd      write (iout,*) 'Processor ',MyID,MyRank,
5672 cd   & ' is sending correlation contribution to processor',MyID-1,
5673 cd   & ' msglen=',msglen
5674 cd      write (*,*) 'Processor ',MyID,MyRank,
5675 cd   & ' is sending correlation contribution to processor',MyID-1,
5676 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5677         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5678 cd      write (iout,*) 'Processor ',MyID,
5679 cd   & ' has sent correlation contribution to processor',MyID-1,
5680 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5681 cd      write (*,*) 'Processor ',MyID,
5682 cd   & ' has sent correlation contribution to processor',MyID-1,
5683 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5684         msglen=msglen1
5685       endif ! (MyRank.gt.0)
5686       if (ldone) goto 30
5687       ldone=.true.
5688    20 continue
5689 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5690       if (MyRank.lt.fgProcs-1) then
5691 C Receive correlation contributions from the next processor
5692         msglen=msglen1
5693         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5694 cd      write (iout,*) 'Processor',MyID,
5695 cd   & ' is receiving correlation contribution from processor',MyID+1,
5696 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5697 cd      write (*,*) 'Processor',MyID,
5698 cd   & ' is receiving correlation contribution from processor',MyID+1,
5699 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5700         nbytes=-1
5701         do while (nbytes.le.0)
5702           call mp_probe(MyID+1,CorrelType,nbytes)
5703         enddo
5704 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5705         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5706 cd      write (iout,*) 'Processor',MyID,
5707 cd   & ' has received correlation contribution from processor',MyID+1,
5708 cd   & ' msglen=',msglen,' nbytes=',nbytes
5709 cd      write (iout,*) 'The received BUFFER array:'
5710 cd      do i=1,max_cont
5711 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5712 cd      enddo
5713         if (msglen.eq.msglen1) then
5714           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5715         else if (msglen.eq.msglen2)  then
5716           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5717           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5718         else
5719           write (iout,*)
5720      & 'ERROR!!!! message length changed while processing correlations.'
5721           write (*,*)
5722      & 'ERROR!!!! message length changed while processing correlations.'
5723           call mp_stopall(Error)
5724         endif ! msglen.eq.msglen1
5725       endif ! MyRank.lt.fgProcs-1
5726       if (ldone) goto 30
5727       ldone=.true.
5728       goto 10
5729    30 continue
5730 #endif
5731       if (lprn) then
5732         write (iout,'(a)') 'Contact function values:'
5733         do i=nnt,nct-2
5734           write (iout,'(2i3,50(1x,i2,f5.2))')
5735      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5736      &    j=1,num_cont_hb(i))
5737         enddo
5738       endif
5739       ecorr=0.0D0
5740       ecorr5=0.0d0
5741       ecorr6=0.0d0
5742 C Remove the loop below after debugging !!!
5743       do i=nnt,nct
5744         do j=1,3
5745           gradcorr(j,i)=0.0D0
5746           gradxorr(j,i)=0.0D0
5747         enddo
5748       enddo
5749 C Calculate the dipole-dipole interaction energies
5750       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5751       do i=iatel_s,iatel_e+1
5752         num_conti=num_cont_hb(i)
5753         do jj=1,num_conti
5754           j=jcont_hb(jj,i)
5755           call dipole(i,j,jj)
5756         enddo
5757       enddo
5758       endif
5759 C Calculate the local-electrostatic correlation terms
5760       do i=iatel_s,iatel_e+1
5761         i1=i+1
5762         num_conti=num_cont_hb(i)
5763         num_conti1=num_cont_hb(i+1)
5764         do jj=1,num_conti
5765           j=jcont_hb(jj,i)
5766           do kk=1,num_conti1
5767             j1=jcont_hb(kk,i1)
5768 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5769 c     &         ' jj=',jj,' kk=',kk
5770             if (j1.eq.j+1 .or. j1.eq.j-1) then
5771 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5772 C The system gains extra energy.
5773               n_corr=n_corr+1
5774               sqd1=dsqrt(d_cont(jj,i))
5775               sqd2=dsqrt(d_cont(kk,i1))
5776               sred_geom = sqd1*sqd2
5777               IF (sred_geom.lt.cutoff_corr) THEN
5778                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5779      &            ekont,fprimcont)
5780 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5781 c     &         ' jj=',jj,' kk=',kk
5782                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5783                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5784                 do l=1,3
5785                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5786                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5787                 enddo
5788                 n_corr1=n_corr1+1
5789 cd               write (iout,*) 'sred_geom=',sred_geom,
5790 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5791                 call calc_eello(i,j,i+1,j1,jj,kk)
5792                 if (wcorr4.gt.0.0d0)
5793      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5794                 if (wcorr5.gt.0.0d0)
5795      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5796 c                print *,"wcorr5",ecorr5
5797 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5798 cd                write(2,*)'ijkl',i,j,i+1,j1
5799                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5800      &               .or. wturn6.eq.0.0d0))then
5801 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5802 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5803 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5804 c     &            'ecorr6=',ecorr6, wcorr6
5805 cd                write (iout,'(4e15.5)') sred_geom,
5806 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5807 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5808 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5809                 else if (wturn6.gt.0.0d0
5810      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5811 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5812                   eturn6=eturn6+eello_turn6(i,jj,kk)
5813 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5814                 endif
5815               ENDIF
5816 1111          continue
5817             else if (j1.eq.j) then
5818 C Contacts I-J and I-(J+1) occur simultaneously.
5819 C The system loses extra energy.
5820 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5821             endif
5822           enddo ! kk
5823           do kk=1,num_conti
5824             j1=jcont_hb(kk,i)
5825 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5826 c    &         ' jj=',jj,' kk=',kk
5827             if (j1.eq.j+1) then
5828 C Contacts I-J and (I+1)-J occur simultaneously.
5829 C The system loses extra energy.
5830 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5831             endif ! j1==j+1
5832           enddo ! kk
5833         enddo ! jj
5834       enddo ! i
5835       return
5836       end
5837 c------------------------------------------------------------------------------
5838       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5839       implicit real*8 (a-h,o-z)
5840       include 'DIMENSIONS'
5841       include 'COMMON.IOUNITS'
5842       include 'COMMON.DERIV'
5843       include 'COMMON.INTERACT'
5844       include 'COMMON.CONTACTS'
5845       double precision gx(3),gx1(3)
5846       logical lprn
5847       lprn=.false.
5848       eij=facont_hb(jj,i)
5849       ekl=facont_hb(kk,k)
5850       ees0pij=ees0p(jj,i)
5851       ees0pkl=ees0p(kk,k)
5852       ees0mij=ees0m(jj,i)
5853       ees0mkl=ees0m(kk,k)
5854       ekont=eij*ekl
5855       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5856 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5857 C Following 4 lines for diagnostics.
5858 cd    ees0pkl=0.0D0
5859 cd    ees0pij=1.0D0
5860 cd    ees0mkl=0.0D0
5861 cd    ees0mij=1.0D0
5862 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5863 c    &   ' and',k,l
5864 c     write (iout,*)'Contacts have occurred for peptide groups',
5865 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5866 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5867 C Calculate the multi-body contribution to energy.
5868       ecorr=ecorr+ekont*ees
5869       if (calc_grad) then
5870 C Calculate multi-body contributions to the gradient.
5871       do ll=1,3
5872         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5873         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5874      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5875      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5876         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5877      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5878      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5879         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5880         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5881      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5882      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5883         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5884      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5885      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5886       enddo
5887       do m=i+1,j-1
5888         do ll=1,3
5889           gradcorr(ll,m)=gradcorr(ll,m)+
5890      &     ees*ekl*gacont_hbr(ll,jj,i)-
5891      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5892      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5893         enddo
5894       enddo
5895       do m=k+1,l-1
5896         do ll=1,3
5897           gradcorr(ll,m)=gradcorr(ll,m)+
5898      &     ees*eij*gacont_hbr(ll,kk,k)-
5899      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5900      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5901         enddo
5902       enddo
5903       endif
5904       ehbcorr=ekont*ees
5905       return
5906       end
5907 C---------------------------------------------------------------------------
5908       subroutine dipole(i,j,jj)
5909       implicit real*8 (a-h,o-z)
5910       include 'DIMENSIONS'
5911       include 'sizesclu.dat'
5912       include 'COMMON.IOUNITS'
5913       include 'COMMON.CHAIN'
5914       include 'COMMON.FFIELD'
5915       include 'COMMON.DERIV'
5916       include 'COMMON.INTERACT'
5917       include 'COMMON.CONTACTS'
5918       include 'COMMON.TORSION'
5919       include 'COMMON.VAR'
5920       include 'COMMON.GEO'
5921       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5922      &  auxmat(2,2)
5923       iti1 = itortyp(itype(i+1))
5924       if (j.lt.nres-1) then
5925         itj1 = itortyp(itype(j+1))
5926       else
5927         itj1=ntortyp+1
5928       endif
5929       do iii=1,2
5930         dipi(iii,1)=Ub2(iii,i)
5931         dipderi(iii)=Ub2der(iii,i)
5932         dipi(iii,2)=b1(iii,iti1)
5933         dipj(iii,1)=Ub2(iii,j)
5934         dipderj(iii)=Ub2der(iii,j)
5935         dipj(iii,2)=b1(iii,itj1)
5936       enddo
5937       kkk=0
5938       do iii=1,2
5939         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5940         do jjj=1,2
5941           kkk=kkk+1
5942           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5943         enddo
5944       enddo
5945       if (.not.calc_grad) return
5946       do kkk=1,5
5947         do lll=1,3
5948           mmm=0
5949           do iii=1,2
5950             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5951      &        auxvec(1))
5952             do jjj=1,2
5953               mmm=mmm+1
5954               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5955             enddo
5956           enddo
5957         enddo
5958       enddo
5959       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5960       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5961       do iii=1,2
5962         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5963       enddo
5964       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5965       do iii=1,2
5966         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5967       enddo
5968       return
5969       end
5970 C---------------------------------------------------------------------------
5971       subroutine calc_eello(i,j,k,l,jj,kk)
5972 C
5973 C This subroutine computes matrices and vectors needed to calculate
5974 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5975 C
5976       implicit real*8 (a-h,o-z)
5977       include 'DIMENSIONS'
5978       include 'sizesclu.dat'
5979       include 'COMMON.IOUNITS'
5980       include 'COMMON.CHAIN'
5981       include 'COMMON.DERIV'
5982       include 'COMMON.INTERACT'
5983       include 'COMMON.CONTACTS'
5984       include 'COMMON.TORSION'
5985       include 'COMMON.VAR'
5986       include 'COMMON.GEO'
5987       include 'COMMON.FFIELD'
5988       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5989      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5990       logical lprn
5991       common /kutas/ lprn
5992 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5993 cd     & ' jj=',jj,' kk=',kk
5994 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5995       do iii=1,2
5996         do jjj=1,2
5997           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5998           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5999         enddo
6000       enddo
6001       call transpose2(aa1(1,1),aa1t(1,1))
6002       call transpose2(aa2(1,1),aa2t(1,1))
6003       do kkk=1,5
6004         do lll=1,3
6005           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6006      &      aa1tder(1,1,lll,kkk))
6007           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6008      &      aa2tder(1,1,lll,kkk))
6009         enddo
6010       enddo
6011       if (l.eq.j+1) then
6012 C parallel orientation of the two CA-CA-CA frames.
6013         if (i.gt.1) then
6014           iti=itortyp(itype(i))
6015         else
6016           iti=ntortyp+1
6017         endif
6018         itk1=itortyp(itype(k+1))
6019         itj=itortyp(itype(j))
6020         if (l.lt.nres-1) then
6021           itl1=itortyp(itype(l+1))
6022         else
6023           itl1=ntortyp+1
6024         endif
6025 C A1 kernel(j+1) A2T
6026 cd        do iii=1,2
6027 cd          write (iout,'(3f10.5,5x,3f10.5)')
6028 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6029 cd        enddo
6030         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6031      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6032      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6033 C Following matrices are needed only for 6-th order cumulants
6034         IF (wcorr6.gt.0.0d0) THEN
6035         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6036      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6037      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6038         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6039      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6040      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6041      &   ADtEAderx(1,1,1,1,1,1))
6042         lprn=.false.
6043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6044      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6045      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6046      &   ADtEA1derx(1,1,1,1,1,1))
6047         ENDIF
6048 C End 6-th order cumulants
6049 cd        lprn=.false.
6050 cd        if (lprn) then
6051 cd        write (2,*) 'In calc_eello6'
6052 cd        do iii=1,2
6053 cd          write (2,*) 'iii=',iii
6054 cd          do kkk=1,5
6055 cd            write (2,*) 'kkk=',kkk
6056 cd            do jjj=1,2
6057 cd              write (2,'(3(2f10.5),5x)')
6058 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6059 cd            enddo
6060 cd          enddo
6061 cd        enddo
6062 cd        endif
6063         call transpose2(EUgder(1,1,k),auxmat(1,1))
6064         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6065         call transpose2(EUg(1,1,k),auxmat(1,1))
6066         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6067         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6068         do iii=1,2
6069           do kkk=1,5
6070             do lll=1,3
6071               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6072      &          EAEAderx(1,1,lll,kkk,iii,1))
6073             enddo
6074           enddo
6075         enddo
6076 C A1T kernel(i+1) A2
6077         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6078      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6079      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6080 C Following matrices are needed only for 6-th order cumulants
6081         IF (wcorr6.gt.0.0d0) THEN
6082         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6083      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6084      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6085         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6086      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6087      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6088      &   ADtEAderx(1,1,1,1,1,2))
6089         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6090      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6091      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6092      &   ADtEA1derx(1,1,1,1,1,2))
6093         ENDIF
6094 C End 6-th order cumulants
6095         call transpose2(EUgder(1,1,l),auxmat(1,1))
6096         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6097         call transpose2(EUg(1,1,l),auxmat(1,1))
6098         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6099         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6100         do iii=1,2
6101           do kkk=1,5
6102             do lll=1,3
6103               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6104      &          EAEAderx(1,1,lll,kkk,iii,2))
6105             enddo
6106           enddo
6107         enddo
6108 C AEAb1 and AEAb2
6109 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6110 C They are needed only when the fifth- or the sixth-order cumulants are
6111 C indluded.
6112         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6113         call transpose2(AEA(1,1,1),auxmat(1,1))
6114         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6115         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6116         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6117         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6118         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6119         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6120         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6121         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6122         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6123         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6124         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6125         call transpose2(AEA(1,1,2),auxmat(1,1))
6126         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6127         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6128         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6129         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6130         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6131         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6132         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6133         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6134         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6135         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6136         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6137 C Calculate the Cartesian derivatives of the vectors.
6138         do iii=1,2
6139           do kkk=1,5
6140             do lll=1,3
6141               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6142               call matvec2(auxmat(1,1),b1(1,iti),
6143      &          AEAb1derx(1,lll,kkk,iii,1,1))
6144               call matvec2(auxmat(1,1),Ub2(1,i),
6145      &          AEAb2derx(1,lll,kkk,iii,1,1))
6146               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6147      &          AEAb1derx(1,lll,kkk,iii,2,1))
6148               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6149      &          AEAb2derx(1,lll,kkk,iii,2,1))
6150               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6151               call matvec2(auxmat(1,1),b1(1,itj),
6152      &          AEAb1derx(1,lll,kkk,iii,1,2))
6153               call matvec2(auxmat(1,1),Ub2(1,j),
6154      &          AEAb2derx(1,lll,kkk,iii,1,2))
6155               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6156      &          AEAb1derx(1,lll,kkk,iii,2,2))
6157               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6158      &          AEAb2derx(1,lll,kkk,iii,2,2))
6159             enddo
6160           enddo
6161         enddo
6162         ENDIF
6163 C End vectors
6164       else
6165 C Antiparallel orientation of the two CA-CA-CA frames.
6166         if (i.gt.1) then
6167           iti=itortyp(itype(i))
6168         else
6169           iti=ntortyp+1
6170         endif
6171         itk1=itortyp(itype(k+1))
6172         itl=itortyp(itype(l))
6173         itj=itortyp(itype(j))
6174         if (j.lt.nres-1) then
6175           itj1=itortyp(itype(j+1))
6176         else
6177           itj1=ntortyp+1
6178         endif
6179 C A2 kernel(j-1)T A1T
6180         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6181      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6182      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6183 C Following matrices are needed only for 6-th order cumulants
6184         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6185      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6186         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6187      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6188      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6189         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6190      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6191      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6192      &   ADtEAderx(1,1,1,1,1,1))
6193         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6194      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6195      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6196      &   ADtEA1derx(1,1,1,1,1,1))
6197         ENDIF
6198 C End 6-th order cumulants
6199         call transpose2(EUgder(1,1,k),auxmat(1,1))
6200         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6201         call transpose2(EUg(1,1,k),auxmat(1,1))
6202         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6203         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6204         do iii=1,2
6205           do kkk=1,5
6206             do lll=1,3
6207               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6208      &          EAEAderx(1,1,lll,kkk,iii,1))
6209             enddo
6210           enddo
6211         enddo
6212 C A2T kernel(i+1)T A1
6213         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6214      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6215      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6216 C Following matrices are needed only for 6-th order cumulants
6217         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6218      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6219         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6220      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6221      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6222         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6223      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6224      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6225      &   ADtEAderx(1,1,1,1,1,2))
6226         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6227      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6228      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6229      &   ADtEA1derx(1,1,1,1,1,2))
6230         ENDIF
6231 C End 6-th order cumulants
6232         call transpose2(EUgder(1,1,j),auxmat(1,1))
6233         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6234         call transpose2(EUg(1,1,j),auxmat(1,1))
6235         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6236         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6237         do iii=1,2
6238           do kkk=1,5
6239             do lll=1,3
6240               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6241      &          EAEAderx(1,1,lll,kkk,iii,2))
6242             enddo
6243           enddo
6244         enddo
6245 C AEAb1 and AEAb2
6246 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6247 C They are needed only when the fifth- or the sixth-order cumulants are
6248 C indluded.
6249         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6250      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6251         call transpose2(AEA(1,1,1),auxmat(1,1))
6252         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6253         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6254         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6255         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6256         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6257         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6258         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6259         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6260         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6261         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6262         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6263         call transpose2(AEA(1,1,2),auxmat(1,1))
6264         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6265         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6266         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6267         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6268         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6269         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6270         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6271         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6272         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6273         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6274         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6275 C Calculate the Cartesian derivatives of the vectors.
6276         do iii=1,2
6277           do kkk=1,5
6278             do lll=1,3
6279               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6280               call matvec2(auxmat(1,1),b1(1,iti),
6281      &          AEAb1derx(1,lll,kkk,iii,1,1))
6282               call matvec2(auxmat(1,1),Ub2(1,i),
6283      &          AEAb2derx(1,lll,kkk,iii,1,1))
6284               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6285      &          AEAb1derx(1,lll,kkk,iii,2,1))
6286               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6287      &          AEAb2derx(1,lll,kkk,iii,2,1))
6288               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6289               call matvec2(auxmat(1,1),b1(1,itl),
6290      &          AEAb1derx(1,lll,kkk,iii,1,2))
6291               call matvec2(auxmat(1,1),Ub2(1,l),
6292      &          AEAb2derx(1,lll,kkk,iii,1,2))
6293               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6294      &          AEAb1derx(1,lll,kkk,iii,2,2))
6295               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6296      &          AEAb2derx(1,lll,kkk,iii,2,2))
6297             enddo
6298           enddo
6299         enddo
6300         ENDIF
6301 C End vectors
6302       endif
6303       return
6304       end
6305 C---------------------------------------------------------------------------
6306       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6307      &  KK,KKderg,AKA,AKAderg,AKAderx)
6308       implicit none
6309       integer nderg
6310       logical transp
6311       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6312      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6313      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6314       integer iii,kkk,lll
6315       integer jjj,mmm
6316       logical lprn
6317       common /kutas/ lprn
6318       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6319       do iii=1,nderg
6320         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6321      &    AKAderg(1,1,iii))
6322       enddo
6323 cd      if (lprn) write (2,*) 'In kernel'
6324       do kkk=1,5
6325 cd        if (lprn) write (2,*) 'kkk=',kkk
6326         do lll=1,3
6327           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6328      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6329 cd          if (lprn) then
6330 cd            write (2,*) 'lll=',lll
6331 cd            write (2,*) 'iii=1'
6332 cd            do jjj=1,2
6333 cd              write (2,'(3(2f10.5),5x)')
6334 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6335 cd            enddo
6336 cd          endif
6337           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6338      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6339 cd          if (lprn) then
6340 cd            write (2,*) 'lll=',lll
6341 cd            write (2,*) 'iii=2'
6342 cd            do jjj=1,2
6343 cd              write (2,'(3(2f10.5),5x)')
6344 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6345 cd            enddo
6346 cd          endif
6347         enddo
6348       enddo
6349       return
6350       end
6351 C---------------------------------------------------------------------------
6352       double precision function eello4(i,j,k,l,jj,kk)
6353       implicit real*8 (a-h,o-z)
6354       include 'DIMENSIONS'
6355       include 'sizesclu.dat'
6356       include 'COMMON.IOUNITS'
6357       include 'COMMON.CHAIN'
6358       include 'COMMON.DERIV'
6359       include 'COMMON.INTERACT'
6360       include 'COMMON.CONTACTS'
6361       include 'COMMON.TORSION'
6362       include 'COMMON.VAR'
6363       include 'COMMON.GEO'
6364       double precision pizda(2,2),ggg1(3),ggg2(3)
6365 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6366 cd        eello4=0.0d0
6367 cd        return
6368 cd      endif
6369 cd      print *,'eello4:',i,j,k,l,jj,kk
6370 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6371 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6372 cold      eij=facont_hb(jj,i)
6373 cold      ekl=facont_hb(kk,k)
6374 cold      ekont=eij*ekl
6375       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6376       if (calc_grad) then
6377 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6378       gcorr_loc(k-1)=gcorr_loc(k-1)
6379      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6380       if (l.eq.j+1) then
6381         gcorr_loc(l-1)=gcorr_loc(l-1)
6382      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6383       else
6384         gcorr_loc(j-1)=gcorr_loc(j-1)
6385      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6386       endif
6387       do iii=1,2
6388         do kkk=1,5
6389           do lll=1,3
6390             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6391      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6392 cd            derx(lll,kkk,iii)=0.0d0
6393           enddo
6394         enddo
6395       enddo
6396 cd      gcorr_loc(l-1)=0.0d0
6397 cd      gcorr_loc(j-1)=0.0d0
6398 cd      gcorr_loc(k-1)=0.0d0
6399 cd      eel4=1.0d0
6400 cd      write (iout,*)'Contacts have occurred for peptide groups',
6401 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6402 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6403       if (j.lt.nres-1) then
6404         j1=j+1
6405         j2=j-1
6406       else
6407         j1=j-1
6408         j2=j-2
6409       endif
6410       if (l.lt.nres-1) then
6411         l1=l+1
6412         l2=l-1
6413       else
6414         l1=l-1
6415         l2=l-2
6416       endif
6417       do ll=1,3
6418 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6419         ggg1(ll)=eel4*g_contij(ll,1)
6420         ggg2(ll)=eel4*g_contij(ll,2)
6421         ghalf=0.5d0*ggg1(ll)
6422 cd        ghalf=0.0d0
6423         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6424         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6425         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6426         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6427 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6428         ghalf=0.5d0*ggg2(ll)
6429 cd        ghalf=0.0d0
6430         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6431         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6432         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6433         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6434       enddo
6435 cd      goto 1112
6436       do m=i+1,j-1
6437         do ll=1,3
6438 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6439           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6440         enddo
6441       enddo
6442       do m=k+1,l-1
6443         do ll=1,3
6444 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6445           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6446         enddo
6447       enddo
6448 1112  continue
6449       do m=i+2,j2
6450         do ll=1,3
6451           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6452         enddo
6453       enddo
6454       do m=k+2,l2
6455         do ll=1,3
6456           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6457         enddo
6458       enddo
6459 cd      do iii=1,nres-3
6460 cd        write (2,*) iii,gcorr_loc(iii)
6461 cd      enddo
6462       endif
6463       eello4=ekont*eel4
6464 cd      write (2,*) 'ekont',ekont
6465 cd      write (iout,*) 'eello4',ekont*eel4
6466       return
6467       end
6468 C---------------------------------------------------------------------------
6469       double precision function eello5(i,j,k,l,jj,kk)
6470       implicit real*8 (a-h,o-z)
6471       include 'DIMENSIONS'
6472       include 'sizesclu.dat'
6473       include 'COMMON.IOUNITS'
6474       include 'COMMON.CHAIN'
6475       include 'COMMON.DERIV'
6476       include 'COMMON.INTERACT'
6477       include 'COMMON.CONTACTS'
6478       include 'COMMON.TORSION'
6479       include 'COMMON.VAR'
6480       include 'COMMON.GEO'
6481       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6482       double precision ggg1(3),ggg2(3)
6483 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6484 C                                                                              C
6485 C                            Parallel chains                                   C
6486 C                                                                              C
6487 C          o             o                   o             o                   C
6488 C         /l\           / \             \   / \           / \   /              C
6489 C        /   \         /   \             \ /   \         /   \ /               C
6490 C       j| o |l1       | o |              o| o |         | o |o                C
6491 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6492 C      \i/   \         /   \ /             /   \         /   \                 C
6493 C       o    k1             o                                                  C
6494 C         (I)          (II)                (III)          (IV)                 C
6495 C                                                                              C
6496 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6497 C                                                                              C
6498 C                            Antiparallel chains                               C
6499 C                                                                              C
6500 C          o             o                   o             o                   C
6501 C         /j\           / \             \   / \           / \   /              C
6502 C        /   \         /   \             \ /   \         /   \ /               C
6503 C      j1| o |l        | o |              o| o |         | o |o                C
6504 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6505 C      \i/   \         /   \ /             /   \         /   \                 C
6506 C       o     k1            o                                                  C
6507 C         (I)          (II)                (III)          (IV)                 C
6508 C                                                                              C
6509 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6510 C                                                                              C
6511 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6512 C                                                                              C
6513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6514 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6515 cd        eello5=0.0d0
6516 cd        return
6517 cd      endif
6518 cd      write (iout,*)
6519 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6520 cd     &   ' and',k,l
6521       itk=itortyp(itype(k))
6522       itl=itortyp(itype(l))
6523       itj=itortyp(itype(j))
6524       eello5_1=0.0d0
6525       eello5_2=0.0d0
6526       eello5_3=0.0d0
6527       eello5_4=0.0d0
6528 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6529 cd     &   eel5_3_num,eel5_4_num)
6530       do iii=1,2
6531         do kkk=1,5
6532           do lll=1,3
6533             derx(lll,kkk,iii)=0.0d0
6534           enddo
6535         enddo
6536       enddo
6537 cd      eij=facont_hb(jj,i)
6538 cd      ekl=facont_hb(kk,k)
6539 cd      ekont=eij*ekl
6540 cd      write (iout,*)'Contacts have occurred for peptide groups',
6541 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6542 cd      goto 1111
6543 C Contribution from the graph I.
6544 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6545 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6546       call transpose2(EUg(1,1,k),auxmat(1,1))
6547       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6548       vv(1)=pizda(1,1)-pizda(2,2)
6549       vv(2)=pizda(1,2)+pizda(2,1)
6550       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6551      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6552       if (calc_grad) then
6553 C Explicit gradient in virtual-dihedral angles.
6554       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6555      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6556      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6557       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6558       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6559       vv(1)=pizda(1,1)-pizda(2,2)
6560       vv(2)=pizda(1,2)+pizda(2,1)
6561       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6562      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6563      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6564       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6565       vv(1)=pizda(1,1)-pizda(2,2)
6566       vv(2)=pizda(1,2)+pizda(2,1)
6567       if (l.eq.j+1) then
6568         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6569      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6570      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6571       else
6572         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6573      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6574      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6575       endif
6576 C Cartesian gradient
6577       do iii=1,2
6578         do kkk=1,5
6579           do lll=1,3
6580             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6581      &        pizda(1,1))
6582             vv(1)=pizda(1,1)-pizda(2,2)
6583             vv(2)=pizda(1,2)+pizda(2,1)
6584             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6585      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6586      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6587           enddo
6588         enddo
6589       enddo
6590 c      goto 1112
6591       endif
6592 c1111  continue
6593 C Contribution from graph II
6594       call transpose2(EE(1,1,itk),auxmat(1,1))
6595       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6596       vv(1)=pizda(1,1)+pizda(2,2)
6597       vv(2)=pizda(2,1)-pizda(1,2)
6598       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6599      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6600       if (calc_grad) then
6601 C Explicit gradient in virtual-dihedral angles.
6602       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6603      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6604       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6605       vv(1)=pizda(1,1)+pizda(2,2)
6606       vv(2)=pizda(2,1)-pizda(1,2)
6607       if (l.eq.j+1) then
6608         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6609      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6610      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6611       else
6612         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6613      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6614      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6615       endif
6616 C Cartesian gradient
6617       do iii=1,2
6618         do kkk=1,5
6619           do lll=1,3
6620             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6621      &        pizda(1,1))
6622             vv(1)=pizda(1,1)+pizda(2,2)
6623             vv(2)=pizda(2,1)-pizda(1,2)
6624             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6625      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6626      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6627           enddo
6628         enddo
6629       enddo
6630 cd      goto 1112
6631       endif
6632 cd1111  continue
6633       if (l.eq.j+1) then
6634 cd        goto 1110
6635 C Parallel orientation
6636 C Contribution from graph III
6637         call transpose2(EUg(1,1,l),auxmat(1,1))
6638         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6639         vv(1)=pizda(1,1)-pizda(2,2)
6640         vv(2)=pizda(1,2)+pizda(2,1)
6641         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6642      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6643         if (calc_grad) then
6644 C Explicit gradient in virtual-dihedral angles.
6645         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6646      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6647      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6648         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6649         vv(1)=pizda(1,1)-pizda(2,2)
6650         vv(2)=pizda(1,2)+pizda(2,1)
6651         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6652      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6653      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6654         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6655         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6656         vv(1)=pizda(1,1)-pizda(2,2)
6657         vv(2)=pizda(1,2)+pizda(2,1)
6658         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6659      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6661 C Cartesian gradient
6662         do iii=1,2
6663           do kkk=1,5
6664             do lll=1,3
6665               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6666      &          pizda(1,1))
6667               vv(1)=pizda(1,1)-pizda(2,2)
6668               vv(2)=pizda(1,2)+pizda(2,1)
6669               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6670      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6671      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6672             enddo
6673           enddo
6674         enddo
6675 cd        goto 1112
6676         endif
6677 C Contribution from graph IV
6678 cd1110    continue
6679         call transpose2(EE(1,1,itl),auxmat(1,1))
6680         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6681         vv(1)=pizda(1,1)+pizda(2,2)
6682         vv(2)=pizda(2,1)-pizda(1,2)
6683         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6684      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6685         if (calc_grad) then
6686 C Explicit gradient in virtual-dihedral angles.
6687         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6688      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6689         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6690         vv(1)=pizda(1,1)+pizda(2,2)
6691         vv(2)=pizda(2,1)-pizda(1,2)
6692         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6693      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6694      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6695 C Cartesian gradient
6696         do iii=1,2
6697           do kkk=1,5
6698             do lll=1,3
6699               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6700      &          pizda(1,1))
6701               vv(1)=pizda(1,1)+pizda(2,2)
6702               vv(2)=pizda(2,1)-pizda(1,2)
6703               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6704      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6705      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6706             enddo
6707           enddo
6708         enddo
6709         endif
6710       else
6711 C Antiparallel orientation
6712 C Contribution from graph III
6713 c        goto 1110
6714         call transpose2(EUg(1,1,j),auxmat(1,1))
6715         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6716         vv(1)=pizda(1,1)-pizda(2,2)
6717         vv(2)=pizda(1,2)+pizda(2,1)
6718         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6720         if (calc_grad) then
6721 C Explicit gradient in virtual-dihedral angles.
6722         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6723      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6724      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6725         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6726         vv(1)=pizda(1,1)-pizda(2,2)
6727         vv(2)=pizda(1,2)+pizda(2,1)
6728         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6729      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6730      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6731         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6732         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6733         vv(1)=pizda(1,1)-pizda(2,2)
6734         vv(2)=pizda(1,2)+pizda(2,1)
6735         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6736      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6737      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6738 C Cartesian gradient
6739         do iii=1,2
6740           do kkk=1,5
6741             do lll=1,3
6742               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6743      &          pizda(1,1))
6744               vv(1)=pizda(1,1)-pizda(2,2)
6745               vv(2)=pizda(1,2)+pizda(2,1)
6746               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6747      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6748      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6749             enddo
6750           enddo
6751         enddo
6752 cd        goto 1112
6753         endif
6754 C Contribution from graph IV
6755 1110    continue
6756         call transpose2(EE(1,1,itj),auxmat(1,1))
6757         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6758         vv(1)=pizda(1,1)+pizda(2,2)
6759         vv(2)=pizda(2,1)-pizda(1,2)
6760         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6761      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6762         if (calc_grad) then
6763 C Explicit gradient in virtual-dihedral angles.
6764         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6765      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6766         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6767         vv(1)=pizda(1,1)+pizda(2,2)
6768         vv(2)=pizda(2,1)-pizda(1,2)
6769         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6770      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6771      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6772 C Cartesian gradient
6773         do iii=1,2
6774           do kkk=1,5
6775             do lll=1,3
6776               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6777      &          pizda(1,1))
6778               vv(1)=pizda(1,1)+pizda(2,2)
6779               vv(2)=pizda(2,1)-pizda(1,2)
6780               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6781      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6782      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6783             enddo
6784           enddo
6785         enddo
6786       endif
6787       endif
6788 1112  continue
6789       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6790 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6791 cd        write (2,*) 'ijkl',i,j,k,l
6792 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6793 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6794 cd      endif
6795 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6796 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6797 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6798 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6799       if (calc_grad) then
6800       if (j.lt.nres-1) then
6801         j1=j+1
6802         j2=j-1
6803       else
6804         j1=j-1
6805         j2=j-2
6806       endif
6807       if (l.lt.nres-1) then
6808         l1=l+1
6809         l2=l-1
6810       else
6811         l1=l-1
6812         l2=l-2
6813       endif
6814 cd      eij=1.0d0
6815 cd      ekl=1.0d0
6816 cd      ekont=1.0d0
6817 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6818       do ll=1,3
6819         ggg1(ll)=eel5*g_contij(ll,1)
6820         ggg2(ll)=eel5*g_contij(ll,2)
6821 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6822         ghalf=0.5d0*ggg1(ll)
6823 cd        ghalf=0.0d0
6824         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6825         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6826         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6827         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6828 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6829         ghalf=0.5d0*ggg2(ll)
6830 cd        ghalf=0.0d0
6831         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6832         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6833         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6834         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6835       enddo
6836 cd      goto 1112
6837       do m=i+1,j-1
6838         do ll=1,3
6839 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6840           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6841         enddo
6842       enddo
6843       do m=k+1,l-1
6844         do ll=1,3
6845 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6846           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6847         enddo
6848       enddo
6849 c1112  continue
6850       do m=i+2,j2
6851         do ll=1,3
6852           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6853         enddo
6854       enddo
6855       do m=k+2,l2
6856         do ll=1,3
6857           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6858         enddo
6859       enddo
6860 cd      do iii=1,nres-3
6861 cd        write (2,*) iii,g_corr5_loc(iii)
6862 cd      enddo
6863       endif
6864       eello5=ekont*eel5
6865 cd      write (2,*) 'ekont',ekont
6866 cd      write (iout,*) 'eello5',ekont*eel5
6867       return
6868       end
6869 c--------------------------------------------------------------------------
6870       double precision function eello6(i,j,k,l,jj,kk)
6871       implicit real*8 (a-h,o-z)
6872       include 'DIMENSIONS'
6873       include 'sizesclu.dat'
6874       include 'COMMON.IOUNITS'
6875       include 'COMMON.CHAIN'
6876       include 'COMMON.DERIV'
6877       include 'COMMON.INTERACT'
6878       include 'COMMON.CONTACTS'
6879       include 'COMMON.TORSION'
6880       include 'COMMON.VAR'
6881       include 'COMMON.GEO'
6882       include 'COMMON.FFIELD'
6883       double precision ggg1(3),ggg2(3)
6884 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6885 cd        eello6=0.0d0
6886 cd        return
6887 cd      endif
6888 cd      write (iout,*)
6889 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6890 cd     &   ' and',k,l
6891       eello6_1=0.0d0
6892       eello6_2=0.0d0
6893       eello6_3=0.0d0
6894       eello6_4=0.0d0
6895       eello6_5=0.0d0
6896       eello6_6=0.0d0
6897 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6898 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6899       do iii=1,2
6900         do kkk=1,5
6901           do lll=1,3
6902             derx(lll,kkk,iii)=0.0d0
6903           enddo
6904         enddo
6905       enddo
6906 cd      eij=facont_hb(jj,i)
6907 cd      ekl=facont_hb(kk,k)
6908 cd      ekont=eij*ekl
6909 cd      eij=1.0d0
6910 cd      ekl=1.0d0
6911 cd      ekont=1.0d0
6912       if (l.eq.j+1) then
6913         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6914         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6915         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6916         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6917         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6918         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6919       else
6920         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6921         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6922         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6923         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6924         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6925           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6926         else
6927           eello6_5=0.0d0
6928         endif
6929         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6930       endif
6931 C If turn contributions are considered, they will be handled separately.
6932       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6933 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6934 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6935 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6936 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6937 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6938 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6939 cd      goto 1112
6940       if (calc_grad) then
6941       if (j.lt.nres-1) then
6942         j1=j+1
6943         j2=j-1
6944       else
6945         j1=j-1
6946         j2=j-2
6947       endif
6948       if (l.lt.nres-1) then
6949         l1=l+1
6950         l2=l-1
6951       else
6952         l1=l-1
6953         l2=l-2
6954       endif
6955       do ll=1,3
6956         ggg1(ll)=eel6*g_contij(ll,1)
6957         ggg2(ll)=eel6*g_contij(ll,2)
6958 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6959         ghalf=0.5d0*ggg1(ll)
6960 cd        ghalf=0.0d0
6961         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6962         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6963         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6964         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6965         ghalf=0.5d0*ggg2(ll)
6966 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6967 cd        ghalf=0.0d0
6968         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6969         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6970         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6971         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6972       enddo
6973 cd      goto 1112
6974       do m=i+1,j-1
6975         do ll=1,3
6976 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6977           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6978         enddo
6979       enddo
6980       do m=k+1,l-1
6981         do ll=1,3
6982 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6983           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6984         enddo
6985       enddo
6986 1112  continue
6987       do m=i+2,j2
6988         do ll=1,3
6989           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6990         enddo
6991       enddo
6992       do m=k+2,l2
6993         do ll=1,3
6994           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6995         enddo
6996       enddo
6997 cd      do iii=1,nres-3
6998 cd        write (2,*) iii,g_corr6_loc(iii)
6999 cd      enddo
7000       endif
7001       eello6=ekont*eel6
7002 cd      write (2,*) 'ekont',ekont
7003 cd      write (iout,*) 'eello6',ekont*eel6
7004       return
7005       end
7006 c--------------------------------------------------------------------------
7007       double precision function eello6_graph1(i,j,k,l,imat,swap)
7008       implicit real*8 (a-h,o-z)
7009       include 'DIMENSIONS'
7010       include 'sizesclu.dat'
7011       include 'COMMON.IOUNITS'
7012       include 'COMMON.CHAIN'
7013       include 'COMMON.DERIV'
7014       include 'COMMON.INTERACT'
7015       include 'COMMON.CONTACTS'
7016       include 'COMMON.TORSION'
7017       include 'COMMON.VAR'
7018       include 'COMMON.GEO'
7019       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7020       logical swap
7021       logical lprn
7022       common /kutas/ lprn
7023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7024 C                                                                              C
7025 C      Parallel       Antiparallel                                             C
7026 C                                                                              C
7027 C          o             o                                                     C
7028 C         /l\           /j\                                                    C
7029 C        /   \         /   \                                                   C
7030 C       /| o |         | o |\                                                  C
7031 C     \ j|/k\|  /   \  |/k\|l /                                                C
7032 C      \ /   \ /     \ /   \ /                                                 C
7033 C       o     o       o     o                                                  C
7034 C       i             i                                                        C
7035 C                                                                              C
7036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7037       itk=itortyp(itype(k))
7038       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7039       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7040       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7041       call transpose2(EUgC(1,1,k),auxmat(1,1))
7042       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7043       vv1(1)=pizda1(1,1)-pizda1(2,2)
7044       vv1(2)=pizda1(1,2)+pizda1(2,1)
7045       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7046       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7047       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7048       s5=scalar2(vv(1),Dtobr2(1,i))
7049 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7050       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7051       if (.not. calc_grad) return
7052       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7053      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7054      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7055      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7056      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7057      & +scalar2(vv(1),Dtobr2der(1,i)))
7058       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7059       vv1(1)=pizda1(1,1)-pizda1(2,2)
7060       vv1(2)=pizda1(1,2)+pizda1(2,1)
7061       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7062       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7063       if (l.eq.j+1) then
7064         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7065      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7066      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7067      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7068      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7069       else
7070         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7071      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7072      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7073      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7074      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7075       endif
7076       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7077       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7078       vv1(1)=pizda1(1,1)-pizda1(2,2)
7079       vv1(2)=pizda1(1,2)+pizda1(2,1)
7080       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7081      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7082      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7083      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7084       do iii=1,2
7085         if (swap) then
7086           ind=3-iii
7087         else
7088           ind=iii
7089         endif
7090         do kkk=1,5
7091           do lll=1,3
7092             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7093             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7094             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7095             call transpose2(EUgC(1,1,k),auxmat(1,1))
7096             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7097      &        pizda1(1,1))
7098             vv1(1)=pizda1(1,1)-pizda1(2,2)
7099             vv1(2)=pizda1(1,2)+pizda1(2,1)
7100             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7101             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7102      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7103             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7104      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7105             s5=scalar2(vv(1),Dtobr2(1,i))
7106             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7107           enddo
7108         enddo
7109       enddo
7110       return
7111       end
7112 c----------------------------------------------------------------------------
7113       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7114       implicit real*8 (a-h,o-z)
7115       include 'DIMENSIONS'
7116       include 'sizesclu.dat'
7117       include 'COMMON.IOUNITS'
7118       include 'COMMON.CHAIN'
7119       include 'COMMON.DERIV'
7120       include 'COMMON.INTERACT'
7121       include 'COMMON.CONTACTS'
7122       include 'COMMON.TORSION'
7123       include 'COMMON.VAR'
7124       include 'COMMON.GEO'
7125       logical swap
7126       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7127      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7128       logical lprn
7129       common /kutas/ lprn
7130 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7131 C                                                                              C
7132 C      Parallel       Antiparallel                                             C
7133 C                                                                              C
7134 C          o             o                                                     C
7135 C     \   /l\           /j\   /                                                C
7136 C      \ /   \         /   \ /                                                 C
7137 C       o| o |         | o |o                                                  C
7138 C     \ j|/k\|      \  |/k\|l                                                  C
7139 C      \ /   \       \ /   \                                                   C
7140 C       o             o                                                        C
7141 C       i             i                                                        C
7142 C                                                                              C
7143 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7144 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7145 C AL 7/4/01 s1 would occur in the sixth-order moment,
7146 C           but not in a cluster cumulant
7147 #ifdef MOMENT
7148       s1=dip(1,jj,i)*dip(1,kk,k)
7149 #endif
7150       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7151       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7152       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7153       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7154       call transpose2(EUg(1,1,k),auxmat(1,1))
7155       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7156       vv(1)=pizda(1,1)-pizda(2,2)
7157       vv(2)=pizda(1,2)+pizda(2,1)
7158       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7159 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7160 #ifdef MOMENT
7161       eello6_graph2=-(s1+s2+s3+s4)
7162 #else
7163       eello6_graph2=-(s2+s3+s4)
7164 #endif
7165 c      eello6_graph2=-s3
7166       if (.not. calc_grad) return
7167 C Derivatives in gamma(i-1)
7168       if (i.gt.1) then
7169 #ifdef MOMENT
7170         s1=dipderg(1,jj,i)*dip(1,kk,k)
7171 #endif
7172         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7173         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7174         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7175         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7176 #ifdef MOMENT
7177         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7178 #else
7179         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7180 #endif
7181 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7182       endif
7183 C Derivatives in gamma(k-1)
7184 #ifdef MOMENT
7185       s1=dip(1,jj,i)*dipderg(1,kk,k)
7186 #endif
7187       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7188       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7189       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7190       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7191       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7192       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7193       vv(1)=pizda(1,1)-pizda(2,2)
7194       vv(2)=pizda(1,2)+pizda(2,1)
7195       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7196 #ifdef MOMENT
7197       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7198 #else
7199       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7200 #endif
7201 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7202 C Derivatives in gamma(j-1) or gamma(l-1)
7203       if (j.gt.1) then
7204 #ifdef MOMENT
7205         s1=dipderg(3,jj,i)*dip(1,kk,k)
7206 #endif
7207         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7208         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7209         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7210         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7211         vv(1)=pizda(1,1)-pizda(2,2)
7212         vv(2)=pizda(1,2)+pizda(2,1)
7213         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7214 #ifdef MOMENT
7215         if (swap) then
7216           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7217         else
7218           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7219         endif
7220 #endif
7221         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7222 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7223       endif
7224 C Derivatives in gamma(l-1) or gamma(j-1)
7225       if (l.gt.1) then
7226 #ifdef MOMENT
7227         s1=dip(1,jj,i)*dipderg(3,kk,k)
7228 #endif
7229         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7230         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7231         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7232         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7233         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7234         vv(1)=pizda(1,1)-pizda(2,2)
7235         vv(2)=pizda(1,2)+pizda(2,1)
7236         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7237 #ifdef MOMENT
7238         if (swap) then
7239           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7240         else
7241           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7242         endif
7243 #endif
7244         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7245 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7246       endif
7247 C Cartesian derivatives.
7248       if (lprn) then
7249         write (2,*) 'In eello6_graph2'
7250         do iii=1,2
7251           write (2,*) 'iii=',iii
7252           do kkk=1,5
7253             write (2,*) 'kkk=',kkk
7254             do jjj=1,2
7255               write (2,'(3(2f10.5),5x)')
7256      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7257             enddo
7258           enddo
7259         enddo
7260       endif
7261       do iii=1,2
7262         do kkk=1,5
7263           do lll=1,3
7264 #ifdef MOMENT
7265             if (iii.eq.1) then
7266               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7267             else
7268               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7269             endif
7270 #endif
7271             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7272      &        auxvec(1))
7273             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7274             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7275      &        auxvec(1))
7276             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7277             call transpose2(EUg(1,1,k),auxmat(1,1))
7278             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7279      &        pizda(1,1))
7280             vv(1)=pizda(1,1)-pizda(2,2)
7281             vv(2)=pizda(1,2)+pizda(2,1)
7282             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7283 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7284 #ifdef MOMENT
7285             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7286 #else
7287             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7288 #endif
7289             if (swap) then
7290               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7291             else
7292               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7293             endif
7294           enddo
7295         enddo
7296       enddo
7297       return
7298       end
7299 c----------------------------------------------------------------------------
7300       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7301       implicit real*8 (a-h,o-z)
7302       include 'DIMENSIONS'
7303       include 'sizesclu.dat'
7304       include 'COMMON.IOUNITS'
7305       include 'COMMON.CHAIN'
7306       include 'COMMON.DERIV'
7307       include 'COMMON.INTERACT'
7308       include 'COMMON.CONTACTS'
7309       include 'COMMON.TORSION'
7310       include 'COMMON.VAR'
7311       include 'COMMON.GEO'
7312       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7313       logical swap
7314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7315 C                                                                              C
7316 C      Parallel       Antiparallel                                             C
7317 C                                                                              C
7318 C          o             o                                                     C
7319 C         /l\   /   \   /j\                                                    C
7320 C        /   \ /     \ /   \                                                   C
7321 C       /| o |o       o| o |\                                                  C
7322 C       j|/k\|  /      |/k\|l /                                                C
7323 C        /   \ /       /   \ /                                                 C
7324 C       /     o       /     o                                                  C
7325 C       i             i                                                        C
7326 C                                                                              C
7327 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7328 C
7329 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7330 C           energy moment and not to the cluster cumulant.
7331       iti=itortyp(itype(i))
7332       if (j.lt.nres-1) then
7333         itj1=itortyp(itype(j+1))
7334       else
7335         itj1=ntortyp+1
7336       endif
7337       itk=itortyp(itype(k))
7338       itk1=itortyp(itype(k+1))
7339       if (l.lt.nres-1) then
7340         itl1=itortyp(itype(l+1))
7341       else
7342         itl1=ntortyp+1
7343       endif
7344 #ifdef MOMENT
7345       s1=dip(4,jj,i)*dip(4,kk,k)
7346 #endif
7347       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7348       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7349       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7350       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7351       call transpose2(EE(1,1,itk),auxmat(1,1))
7352       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7353       vv(1)=pizda(1,1)+pizda(2,2)
7354       vv(2)=pizda(2,1)-pizda(1,2)
7355       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7356 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7357 #ifdef MOMENT
7358       eello6_graph3=-(s1+s2+s3+s4)
7359 #else
7360       eello6_graph3=-(s2+s3+s4)
7361 #endif
7362 c      eello6_graph3=-s4
7363       if (.not. calc_grad) return
7364 C Derivatives in gamma(k-1)
7365       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7366       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7367       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7368       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7369 C Derivatives in gamma(l-1)
7370       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7371       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7372       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7373       vv(1)=pizda(1,1)+pizda(2,2)
7374       vv(2)=pizda(2,1)-pizda(1,2)
7375       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7376       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7377 C Cartesian derivatives.
7378       do iii=1,2
7379         do kkk=1,5
7380           do lll=1,3
7381 #ifdef MOMENT
7382             if (iii.eq.1) then
7383               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7384             else
7385               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7386             endif
7387 #endif
7388             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7389      &        auxvec(1))
7390             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7391             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7392      &        auxvec(1))
7393             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7394             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7395      &        pizda(1,1))
7396             vv(1)=pizda(1,1)+pizda(2,2)
7397             vv(2)=pizda(2,1)-pizda(1,2)
7398             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7399 #ifdef MOMENT
7400             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7401 #else
7402             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7403 #endif
7404             if (swap) then
7405               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7406             else
7407               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7408             endif
7409 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7410           enddo
7411         enddo
7412       enddo
7413       return
7414       end
7415 c----------------------------------------------------------------------------
7416       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7417       implicit real*8 (a-h,o-z)
7418       include 'DIMENSIONS'
7419       include 'sizesclu.dat'
7420       include 'COMMON.IOUNITS'
7421       include 'COMMON.CHAIN'
7422       include 'COMMON.DERIV'
7423       include 'COMMON.INTERACT'
7424       include 'COMMON.CONTACTS'
7425       include 'COMMON.TORSION'
7426       include 'COMMON.VAR'
7427       include 'COMMON.GEO'
7428       include 'COMMON.FFIELD'
7429       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7430      & auxvec1(2),auxmat1(2,2)
7431       logical swap
7432 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7433 C                                                                              C
7434 C      Parallel       Antiparallel                                             C
7435 C                                                                              C
7436 C          o             o                                                     C
7437 C         /l\   /   \   /j\                                                    C
7438 C        /   \ /     \ /   \                                                   C
7439 C       /| o |o       o| o |\                                                  C
7440 C     \ j|/k\|      \  |/k\|l                                                  C
7441 C      \ /   \       \ /   \                                                   C
7442 C       o     \       o     \                                                  C
7443 C       i             i                                                        C
7444 C                                                                              C
7445 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7446 C
7447 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7448 C           energy moment and not to the cluster cumulant.
7449 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7450       iti=itortyp(itype(i))
7451       itj=itortyp(itype(j))
7452       if (j.lt.nres-1) then
7453         itj1=itortyp(itype(j+1))
7454       else
7455         itj1=ntortyp+1
7456       endif
7457       itk=itortyp(itype(k))
7458       if (k.lt.nres-1) then
7459         itk1=itortyp(itype(k+1))
7460       else
7461         itk1=ntortyp+1
7462       endif
7463       itl=itortyp(itype(l))
7464       if (l.lt.nres-1) then
7465         itl1=itortyp(itype(l+1))
7466       else
7467         itl1=ntortyp+1
7468       endif
7469 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7470 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7471 cd     & ' itl',itl,' itl1',itl1
7472 #ifdef MOMENT
7473       if (imat.eq.1) then
7474         s1=dip(3,jj,i)*dip(3,kk,k)
7475       else
7476         s1=dip(2,jj,j)*dip(2,kk,l)
7477       endif
7478 #endif
7479       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7480       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7481       if (j.eq.l+1) then
7482         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7483         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7484       else
7485         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7486         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7487       endif
7488       call transpose2(EUg(1,1,k),auxmat(1,1))
7489       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7490       vv(1)=pizda(1,1)-pizda(2,2)
7491       vv(2)=pizda(2,1)+pizda(1,2)
7492       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7493 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7494 #ifdef MOMENT
7495       eello6_graph4=-(s1+s2+s3+s4)
7496 #else
7497       eello6_graph4=-(s2+s3+s4)
7498 #endif
7499       if (.not. calc_grad) return
7500 C Derivatives in gamma(i-1)
7501       if (i.gt.1) then
7502 #ifdef MOMENT
7503         if (imat.eq.1) then
7504           s1=dipderg(2,jj,i)*dip(3,kk,k)
7505         else
7506           s1=dipderg(4,jj,j)*dip(2,kk,l)
7507         endif
7508 #endif
7509         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7510         if (j.eq.l+1) then
7511           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7512           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7513         else
7514           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7515           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7516         endif
7517         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7518         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7519 cd          write (2,*) 'turn6 derivatives'
7520 #ifdef MOMENT
7521           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7522 #else
7523           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7524 #endif
7525         else
7526 #ifdef MOMENT
7527           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7528 #else
7529           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7530 #endif
7531         endif
7532       endif
7533 C Derivatives in gamma(k-1)
7534 #ifdef MOMENT
7535       if (imat.eq.1) then
7536         s1=dip(3,jj,i)*dipderg(2,kk,k)
7537       else
7538         s1=dip(2,jj,j)*dipderg(4,kk,l)
7539       endif
7540 #endif
7541       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7542       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7543       if (j.eq.l+1) then
7544         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7545         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7546       else
7547         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7548         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7549       endif
7550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7551       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7552       vv(1)=pizda(1,1)-pizda(2,2)
7553       vv(2)=pizda(2,1)+pizda(1,2)
7554       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7555       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7556 #ifdef MOMENT
7557         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7558 #else
7559         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7560 #endif
7561       else
7562 #ifdef MOMENT
7563         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7564 #else
7565         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7566 #endif
7567       endif
7568 C Derivatives in gamma(j-1) or gamma(l-1)
7569       if (l.eq.j+1 .and. l.gt.1) then
7570         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7571         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7572         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7573         vv(1)=pizda(1,1)-pizda(2,2)
7574         vv(2)=pizda(2,1)+pizda(1,2)
7575         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7576         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7577       else if (j.gt.1) then
7578         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7579         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7580         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7581         vv(1)=pizda(1,1)-pizda(2,2)
7582         vv(2)=pizda(2,1)+pizda(1,2)
7583         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7584         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7585           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7586         else
7587           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7588         endif
7589       endif
7590 C Cartesian derivatives.
7591       do iii=1,2
7592         do kkk=1,5
7593           do lll=1,3
7594 #ifdef MOMENT
7595             if (iii.eq.1) then
7596               if (imat.eq.1) then
7597                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7598               else
7599                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7600               endif
7601             else
7602               if (imat.eq.1) then
7603                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7604               else
7605                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7606               endif
7607             endif
7608 #endif
7609             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7610      &        auxvec(1))
7611             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7612             if (j.eq.l+1) then
7613               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7614      &          b1(1,itj1),auxvec(1))
7615               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7616             else
7617               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7618      &          b1(1,itl1),auxvec(1))
7619               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7620             endif
7621             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7622      &        pizda(1,1))
7623             vv(1)=pizda(1,1)-pizda(2,2)
7624             vv(2)=pizda(2,1)+pizda(1,2)
7625             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7626             if (swap) then
7627               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7628 #ifdef MOMENT
7629                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7630      &             -(s1+s2+s4)
7631 #else
7632                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7633      &             -(s2+s4)
7634 #endif
7635                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7636               else
7637 #ifdef MOMENT
7638                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7639 #else
7640                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7641 #endif
7642                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7643               endif
7644             else
7645 #ifdef MOMENT
7646               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7647 #else
7648               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7649 #endif
7650               if (l.eq.j+1) then
7651                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7652               else
7653                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7654               endif
7655             endif
7656           enddo
7657         enddo
7658       enddo
7659       return
7660       end
7661 c----------------------------------------------------------------------------
7662       double precision function eello_turn6(i,jj,kk)
7663       implicit real*8 (a-h,o-z)
7664       include 'DIMENSIONS'
7665       include 'sizesclu.dat'
7666       include 'COMMON.IOUNITS'
7667       include 'COMMON.CHAIN'
7668       include 'COMMON.DERIV'
7669       include 'COMMON.INTERACT'
7670       include 'COMMON.CONTACTS'
7671       include 'COMMON.TORSION'
7672       include 'COMMON.VAR'
7673       include 'COMMON.GEO'
7674       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7675      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7676      &  ggg1(3),ggg2(3)
7677       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7678      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7679 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7680 C           the respective energy moment and not to the cluster cumulant.
7681       eello_turn6=0.0d0
7682       j=i+4
7683       k=i+1
7684       l=i+3
7685       iti=itortyp(itype(i))
7686       itk=itortyp(itype(k))
7687       itk1=itortyp(itype(k+1))
7688       itl=itortyp(itype(l))
7689       itj=itortyp(itype(j))
7690 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7691 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7692 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7693 cd        eello6=0.0d0
7694 cd        return
7695 cd      endif
7696 cd      write (iout,*)
7697 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7698 cd     &   ' and',k,l
7699 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7700       do iii=1,2
7701         do kkk=1,5
7702           do lll=1,3
7703             derx_turn(lll,kkk,iii)=0.0d0
7704           enddo
7705         enddo
7706       enddo
7707 cd      eij=1.0d0
7708 cd      ekl=1.0d0
7709 cd      ekont=1.0d0
7710       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7711 cd      eello6_5=0.0d0
7712 cd      write (2,*) 'eello6_5',eello6_5
7713 #ifdef MOMENT
7714       call transpose2(AEA(1,1,1),auxmat(1,1))
7715       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7716       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7717       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7718 #else
7719       s1 = 0.0d0
7720 #endif
7721       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7722       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7723       s2 = scalar2(b1(1,itk),vtemp1(1))
7724 #ifdef MOMENT
7725       call transpose2(AEA(1,1,2),atemp(1,1))
7726       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7727       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7728       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7729 #else
7730       s8=0.0d0
7731 #endif
7732       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7733       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7734       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7735 #ifdef MOMENT
7736       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7737       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7738       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7739       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7740       ss13 = scalar2(b1(1,itk),vtemp4(1))
7741       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7742 #else
7743       s13=0.0d0
7744 #endif
7745 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7746 c      s1=0.0d0
7747 c      s2=0.0d0
7748 c      s8=0.0d0
7749 c      s12=0.0d0
7750 c      s13=0.0d0
7751       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7752       if (calc_grad) then
7753 C Derivatives in gamma(i+2)
7754 #ifdef MOMENT
7755       call transpose2(AEA(1,1,1),auxmatd(1,1))
7756       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7757       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7758       call transpose2(AEAderg(1,1,2),atempd(1,1))
7759       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7760       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7761 #else
7762       s8d=0.0d0
7763 #endif
7764       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7765       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7766       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7767 c      s1d=0.0d0
7768 c      s2d=0.0d0
7769 c      s8d=0.0d0
7770 c      s12d=0.0d0
7771 c      s13d=0.0d0
7772       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7773 C Derivatives in gamma(i+3)
7774 #ifdef MOMENT
7775       call transpose2(AEA(1,1,1),auxmatd(1,1))
7776       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7777       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7778       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7779 #else
7780       s1d=0.0d0
7781 #endif
7782       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7783       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7784       s2d = scalar2(b1(1,itk),vtemp1d(1))
7785 #ifdef MOMENT
7786       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7787       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7788 #endif
7789       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7790 #ifdef MOMENT
7791       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7792       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7793       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7794 #else
7795       s13d=0.0d0
7796 #endif
7797 c      s1d=0.0d0
7798 c      s2d=0.0d0
7799 c      s8d=0.0d0
7800 c      s12d=0.0d0
7801 c      s13d=0.0d0
7802 #ifdef MOMENT
7803       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7804      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7805 #else
7806       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7807      &               -0.5d0*ekont*(s2d+s12d)
7808 #endif
7809 C Derivatives in gamma(i+4)
7810       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7811       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7812       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7813 #ifdef MOMENT
7814       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7815       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7816       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7817 #else
7818       s13d = 0.0d0
7819 #endif
7820 c      s1d=0.0d0
7821 c      s2d=0.0d0
7822 c      s8d=0.0d0
7823 C      s12d=0.0d0
7824 c      s13d=0.0d0
7825 #ifdef MOMENT
7826       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7827 #else
7828       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7829 #endif
7830 C Derivatives in gamma(i+5)
7831 #ifdef MOMENT
7832       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7833       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7834       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7835 #else
7836       s1d = 0.0d0
7837 #endif
7838       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7839       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7840       s2d = scalar2(b1(1,itk),vtemp1d(1))
7841 #ifdef MOMENT
7842       call transpose2(AEA(1,1,2),atempd(1,1))
7843       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7844       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7845 #else
7846       s8d = 0.0d0
7847 #endif
7848       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7849       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7850 #ifdef MOMENT
7851       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7852       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7853       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7854 #else
7855       s13d = 0.0d0
7856 #endif
7857 c      s1d=0.0d0
7858 c      s2d=0.0d0
7859 c      s8d=0.0d0
7860 c      s12d=0.0d0
7861 c      s13d=0.0d0
7862 #ifdef MOMENT
7863       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7864      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7865 #else
7866       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7867      &               -0.5d0*ekont*(s2d+s12d)
7868 #endif
7869 C Cartesian derivatives
7870       do iii=1,2
7871         do kkk=1,5
7872           do lll=1,3
7873 #ifdef MOMENT
7874             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7875             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7876             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7877 #else
7878             s1d = 0.0d0
7879 #endif
7880             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7881             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7882      &          vtemp1d(1))
7883             s2d = scalar2(b1(1,itk),vtemp1d(1))
7884 #ifdef MOMENT
7885             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7886             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7887             s8d = -(atempd(1,1)+atempd(2,2))*
7888      &           scalar2(cc(1,1,itl),vtemp2(1))
7889 #else
7890             s8d = 0.0d0
7891 #endif
7892             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7893      &           auxmatd(1,1))
7894             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7895             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7896 c      s1d=0.0d0
7897 c      s2d=0.0d0
7898 c      s8d=0.0d0
7899 c      s12d=0.0d0
7900 c      s13d=0.0d0
7901 #ifdef MOMENT
7902             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7903      &        - 0.5d0*(s1d+s2d)
7904 #else
7905             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7906      &        - 0.5d0*s2d
7907 #endif
7908 #ifdef MOMENT
7909             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7910      &        - 0.5d0*(s8d+s12d)
7911 #else
7912             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7913      &        - 0.5d0*s12d
7914 #endif
7915           enddo
7916         enddo
7917       enddo
7918 #ifdef MOMENT
7919       do kkk=1,5
7920         do lll=1,3
7921           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7922      &      achuj_tempd(1,1))
7923           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7924           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7925           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7926           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7927           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7928      &      vtemp4d(1))
7929           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7930           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7931           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7932         enddo
7933       enddo
7934 #endif
7935 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7936 cd     &  16*eel_turn6_num
7937 cd      goto 1112
7938       if (j.lt.nres-1) then
7939         j1=j+1
7940         j2=j-1
7941       else
7942         j1=j-1
7943         j2=j-2
7944       endif
7945       if (l.lt.nres-1) then
7946         l1=l+1
7947         l2=l-1
7948       else
7949         l1=l-1
7950         l2=l-2
7951       endif
7952       do ll=1,3
7953         ggg1(ll)=eel_turn6*g_contij(ll,1)
7954         ggg2(ll)=eel_turn6*g_contij(ll,2)
7955         ghalf=0.5d0*ggg1(ll)
7956 cd        ghalf=0.0d0
7957         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7958      &    +ekont*derx_turn(ll,2,1)
7959         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7960         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7961      &    +ekont*derx_turn(ll,4,1)
7962         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7963         ghalf=0.5d0*ggg2(ll)
7964 cd        ghalf=0.0d0
7965         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7966      &    +ekont*derx_turn(ll,2,2)
7967         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7968         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7969      &    +ekont*derx_turn(ll,4,2)
7970         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7971       enddo
7972 cd      goto 1112
7973       do m=i+1,j-1
7974         do ll=1,3
7975           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7976         enddo
7977       enddo
7978       do m=k+1,l-1
7979         do ll=1,3
7980           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7981         enddo
7982       enddo
7983 1112  continue
7984       do m=i+2,j2
7985         do ll=1,3
7986           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7987         enddo
7988       enddo
7989       do m=k+2,l2
7990         do ll=1,3
7991           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7992         enddo
7993       enddo
7994 cd      do iii=1,nres-3
7995 cd        write (2,*) iii,g_corr6_loc(iii)
7996 cd      enddo
7997       endif
7998       eello_turn6=ekont*eel_turn6
7999 cd      write (2,*) 'ekont',ekont
8000 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8001       return
8002       end
8003 crc-------------------------------------------------
8004       SUBROUTINE MATVEC2(A1,V1,V2)
8005       implicit real*8 (a-h,o-z)
8006       include 'DIMENSIONS'
8007       DIMENSION A1(2,2),V1(2),V2(2)
8008 c      DO 1 I=1,2
8009 c        VI=0.0
8010 c        DO 3 K=1,2
8011 c    3     VI=VI+A1(I,K)*V1(K)
8012 c        Vaux(I)=VI
8013 c    1 CONTINUE
8014
8015       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8016       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8017
8018       v2(1)=vaux1
8019       v2(2)=vaux2
8020       END
8021 C---------------------------------------
8022       SUBROUTINE MATMAT2(A1,A2,A3)
8023       implicit real*8 (a-h,o-z)
8024       include 'DIMENSIONS'
8025       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8026 c      DIMENSION AI3(2,2)
8027 c        DO  J=1,2
8028 c          A3IJ=0.0
8029 c          DO K=1,2
8030 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8031 c          enddo
8032 c          A3(I,J)=A3IJ
8033 c       enddo
8034 c      enddo
8035
8036       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8037       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8038       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8039       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8040
8041       A3(1,1)=AI3_11
8042       A3(2,1)=AI3_21
8043       A3(1,2)=AI3_12
8044       A3(2,2)=AI3_22
8045       END
8046
8047 c-------------------------------------------------------------------------
8048       double precision function scalar2(u,v)
8049       implicit none
8050       double precision u(2),v(2)
8051       double precision sc
8052       integer i
8053       scalar2=u(1)*v(1)+u(2)*v(2)
8054       return
8055       end
8056
8057 C-----------------------------------------------------------------------------
8058
8059       subroutine transpose2(a,at)
8060       implicit none
8061       double precision a(2,2),at(2,2)
8062       at(1,1)=a(1,1)
8063       at(1,2)=a(2,1)
8064       at(2,1)=a(1,2)
8065       at(2,2)=a(2,2)
8066       return
8067       end
8068 c--------------------------------------------------------------------------
8069       subroutine transpose(n,a,at)
8070       implicit none
8071       integer n,i,j
8072       double precision a(n,n),at(n,n)
8073       do i=1,n
8074         do j=1,n
8075           at(j,i)=a(i,j)
8076         enddo
8077       enddo
8078       return
8079       end
8080 C---------------------------------------------------------------------------
8081       subroutine prodmat3(a1,a2,kk,transp,prod)
8082       implicit none
8083       integer i,j
8084       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8085       logical transp
8086 crc      double precision auxmat(2,2),prod_(2,2)
8087
8088       if (transp) then
8089 crc        call transpose2(kk(1,1),auxmat(1,1))
8090 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8091 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8092
8093            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8094      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8095            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8096      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8097            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8098      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8099            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8100      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8101
8102       else
8103 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8104 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8105
8106            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8107      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8108            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8109      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8110            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8111      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8112            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8113      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8114
8115       endif
8116 c      call transpose2(a2(1,1),a2t(1,1))
8117
8118 crc      print *,transp
8119 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8120 crc      print *,((prod(i,j),i=1,2),j=1,2)
8121
8122       return
8123       end
8124 C-----------------------------------------------------------------------------
8125       double precision function scalar(u,v)
8126       implicit none
8127       double precision u(3),v(3)
8128       double precision sc
8129       integer i
8130       sc=0.0d0
8131       do i=1,3
8132         sc=sc+u(i)*v(i)
8133       enddo
8134       scalar=sc
8135       return
8136       end
8137