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