source/cluster/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 c     external proc_proc
   7 #ifdef WINPGI
   8 cMS$ATTRIBUTES C ::  proc_proc
   9 #endif
  10
  11       include 'COMMON.IOUNITS'
  12       double precision energia(0:max_ene),energia1(0:max_ene+1)
  13 #ifdef MPL
  14       include 'COMMON.INFO'
  15       external d_vadd
  16       integer ready
  17 #endif
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.CONTROL'
  24
  25       double precision fact(5)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor,fact(1))
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105
 106 c      write(iout,*) "TEST_ENE",constr_homology
 107       if (constr_homology.ge.1) then
 108         call e_modeller(ehomology_constr)
 109       else
 110         ehomology_constr=0.0d0
 111       endif
 112 c      write(iout,*) "TEST_ENE",ehomology_constr
 113
 114 C     BARTEK for dfa test!
 115       if (wdfa_dist.gt.0) call edfad(edfadis)
 116 c      print*, 'edfad is finished!', edfadis
 117       if (wdfa_tor.gt.0) call edfat(edfator)
 118 c      print*, 'edfat is finished!', edfator
 119       if (wdfa_nei.gt.0) call edfan(edfanei)
 120 c      print*, 'edfan is finished!', edfanei
 121       if (wdfa_beta.gt.0) call edfab(edfabet)
 122 c      print*, 'edfab is finished!', edfabet
 123
 124
 125 C     call multibody(ecorr)
 126 C
 127 C Sum the energies
 128 C
 129 #ifdef SPLITELE
 130       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*ees+wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*(ees+evdw1)
 141      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 142      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 143      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 144      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 145      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 146      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 147      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 148      & +wdfa_beta*edfabet
 149 #endif
 150       energia(0)=etot
 151       energia(1)=evdw
 152 #ifdef SCP14
 153       energia(2)=evdw2-evdw2_14
 154       energia(17)=evdw2_14
 155 #else
 156       energia(2)=evdw2
 157       energia(17)=0.0d0
 158 #endif
 159 #ifdef SPLITELE
 160       energia(3)=ees
 161       energia(16)=evdw1
 162 #else
 163       energia(3)=ees+evdw1
 164       energia(16)=0.0d0
 165 #endif
 166       energia(4)=ecorr
 167       energia(5)=ecorr5
 168       energia(6)=ecorr6
 169       energia(7)=eel_loc
 170       energia(8)=eello_turn3
 171       energia(9)=eello_turn4
 172       energia(10)=eturn6
 173       energia(11)=ebe
 174       energia(12)=escloc
 175       energia(13)=etors
 176       energia(14)=etors_d
 177       energia(15)=ehpb
 178       energia(18)=estr
 179       energia(19)=esccor
 180       energia(20)=edihcnstr
 181       energia(21)=ehomology_constr
 182       energia(22)=edfadis
 183       energia(23)=edfator
 184       energia(24)=edfanei
 185       energia(25)=edfabet
 186 cc      if (dyn_ss) call dyn_set_nss
 187 c detecting NaNQ
 188       i=0
 189 #ifdef WINPGI
 190       idumm=proc_proc(etot,i)
 191 #else
 192 c     call proc_proc(etot,i)
 193 #endif
 194       if(i.eq.1)energia(0)=1.0d+99
 195 #ifdef MPL
 196 c     endif
 197 #endif
 198       if (calc_grad) then
 199 C
 200 C Sum up the components of the Cartesian gradient.
 201 C
 202 #ifdef SPLITELE
 203       do i=1,nct
 204         do j=1,3
 205           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 206      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 207      &                wbond*gradb(j,i)+
 208      &                wstrain*ghpbc(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)+
 217      &                wdfa_dist*gdfad(j,i)+
 218      &                wdfa_tor*gdfat(j,i)+
 219      &                wdfa_nei*gdfan(j,i)+
 220      &                wdfa_beta*gdfab(j,i)
 221           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 222      &                  wbond*gradbx(j,i)+
 223      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 224         enddo
 225 #else
 226       do i=1,nct
 227         do j=1,3
 228           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 229      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 230      &                wbond*gradb(j,i)+
 231      &                wcorr*fact(3)*gradcorr(j,i)+
 232      &                wel_loc*fact(2)*gel_loc(j,i)+
 233      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 234      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 235      &                wcorr5*fact(4)*gradcorr5(j,i)+
 236      &                wcorr6*fact(5)*gradcorr6(j,i)+
 237      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 238      &                wsccor*fact(2)*gsccorc(j,i)+
 239      &                wdfa_dist*gdfad(j,i)+
 240      &                wdfa_tor*gdfat(j,i)+
 241      &                wdfa_nei*gdfan(j,i)+
 242      &                wdfa_beta*gdfab(j,i)
 243           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 244      &                  wbond*gradbx(j,i)+
 245      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 246         enddo
 247 #endif
 248 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 249 cd   &        (gradc(k,i),k=1,3)
 250       enddo
 251
 252
 253       do i=1,nres-3
 254 cd        write (iout,*) i,g_corr5_loc(i)
 255         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 256      &   +wcorr5*fact(4)*g_corr5_loc(i)
 257      &   +wcorr6*fact(5)*g_corr6_loc(i)
 258      &   +wturn4*fact(3)*gel_loc_turn4(i)
 259      &   +wturn3*fact(2)*gel_loc_turn3(i)
 260      &   +wturn6*fact(5)*gel_loc_turn6(i)
 261      &   +wel_loc*fact(2)*gel_loc_loc(i)
 262      &   +wsccor*fact(1)*gsccor_loc(i)
 263       enddo
 264       endif
 265 c      call enerprint(energia(0),fact)
 266 cd    call intout
 267 cd    stop
 268       return
 269       end
 270 C------------------------------------------------------------------------
 271       subroutine enerprint(energia,fact)
 272       implicit real*8 (a-h,o-z)
 273       include 'DIMENSIONS'
 274       include 'sizesclu.dat'
 275       include 'COMMON.IOUNITS'
 276       include 'COMMON.FFIELD'
 277       include 'COMMON.SBRIDGE'
 278       double precision energia(0:max_ene),fact(5)
 279       etot=energia(0)
 280       evdw=energia(1)
 281 #ifdef SCP14
 282       evdw2=energia(2)+energia(17)
 283 #else
 284       evdw2=energia(2)
 285 #endif
 286       ees=energia(3)
 287 #ifdef SPLITELE
 288       evdw1=energia(16)
 289 #endif
 290       ecorr=energia(4)
 291       ecorr5=energia(5)
 292       ecorr6=energia(6)
 293       eel_loc=energia(7)
 294       eello_turn3=energia(8)
 295       eello_turn4=energia(9)
 296       eello_turn6=energia(10)
 297       ebe=energia(11)
 298       escloc=energia(12)
 299       etors=energia(13)
 300       etors_d=energia(14)
 301       ehpb=energia(15)
 302       esccor=energia(19)
 303       edihcnstr=energia(20)
 304       estr=energia(18)
 305       ehomology_constr=energia(21)
 306       edfadis=energia(22)
 307       edfator=energia(23)
 308       edfanei=energia(24)
 309       edfabet=energia(25)
 310 #ifdef SPLITELE
 311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 312      &  wvdwpp,
 313      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 314      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 315      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 316      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 317      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 318      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 320      &  wdfa_beta,etot
 321    10 format (/'Virtual-chain energies:'//
 322      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 323      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 324      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 325      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 332      & ' (SS bridges & dist. cnstr.)'/
 333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 341      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 342      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 344      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 345      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 346      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 347      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #else
 350       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 351      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 352      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 353      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 354      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 355      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 356      &  edihcnstr,ehomology_constr,ebr*nss,
 357      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 358      &  wdfa_beta,etot
 359    10 format (/'Virtual-chain energies:'//
 360      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 361      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 362      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 363      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 364      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 365      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 366      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 367      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 368      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 369      & ' (SS bridges & dist. cnstr.)'/
 370      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 372      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 373      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 374      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 375      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 376      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 377      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 378      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 379      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 380      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 381      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 382      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 383      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 384      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 385      & 'ETOT=  ',1pE16.6,' (total)')
 386 #endif
 387       return
 388       end
 389 C-----------------------------------------------------------------------
 390       subroutine elj(evdw)
 391 C
 392 C This subroutine calculates the interaction energy of nonbonded side chains
 393 C assuming the LJ potential of interaction.
 394 C
 395       implicit real*8 (a-h,o-z)
 396       include 'DIMENSIONS'
 397       include 'sizesclu.dat'
 398 c      include "DIMENSIONS.COMPAR"
 399       parameter (accur=1.0d-10)
 400       include 'COMMON.GEO'
 401       include 'COMMON.VAR'
 402       include 'COMMON.LOCAL'
 403       include 'COMMON.CHAIN'
 404       include 'COMMON.DERIV'
 405       include 'COMMON.INTERACT'
 406       include 'COMMON.TORSION'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.NAMES'
 409       include 'COMMON.IOUNITS'
 410       include 'COMMON.CONTACTS'
 411       dimension gg(3)
 412       integer icant
 413       external icant
 414 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 415       evdw=0.0D0
 416       do i=iatsc_s,iatsc_e
 417         itypi=itype(i)
 418         itypi1=itype(i+1)
 419         xi=c(1,nres+i)
 420         yi=c(2,nres+i)
 421         zi=c(3,nres+i)
 422 C Change 12/1/95
 423         num_conti=0
 424 C
 425 C Calculate SC interaction energy.
 426 C
 427         do iint=1,nint_gr(i)
 428 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 429 cd   &                  'iend=',iend(i,iint)
 430           do j=istart(i,iint),iend(i,iint)
 431             itypj=itype(j)
 432             xj=c(1,nres+j)-xi
 433             yj=c(2,nres+j)-yi
 434             zj=c(3,nres+j)-zi
 435 C Change 12/1/95 to calculate four-body interactions
 436             rij=xj*xj+yj*yj+zj*zj
 437             rrij=1.0D0/rij
 438 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 439             eps0ij=eps(itypi,itypj)
 440             fac=rrij**expon2
 441             e1=fac*fac*aa(itypi,itypj)
 442             e2=fac*bb(itypi,itypj)
 443             evdwij=e1+e2
 444             ij=icant(itypi,itypj)
 445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 447 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 449 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 450 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 451             evdw=evdw+evdwij
 452             if (calc_grad) then
 453 C
 454 C Calculate the components of the gradient in DC and X
 455 C
 456             fac=-rrij*(e1+evdwij)
 457             gg(1)=xj*fac
 458             gg(2)=yj*fac
 459             gg(3)=zj*fac
 460             do k=1,3
 461               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 462               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 463             enddo
 464             do k=i,j-1
 465               do l=1,3
 466                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 467               enddo
 468             enddo
 469             endif
 470 C
 471 C 12/1/95, revised on 5/20/97
 472 C
 473 C Calculate the contact function. The ith column of the array JCONT will
 474 C contain the numbers of atoms that make contacts with the atom I (of numbers
 475 C greater than I). The arrays FACONT and GACONT will contain the values of
 476 C the contact function and its derivative.
 477 C
 478 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 479 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 480 C Uncomment next line, if the correlation interactions are contact function only
 481             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 482               rij=dsqrt(rij)
 483               sigij=sigma(itypi,itypj)
 484               r0ij=rs0(itypi,itypj)
 485 C
 486 C Check whether the SC's are not too far to make a contact.
 487 C
 488               rcut=1.5d0*r0ij
 489               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 490 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 491 C
 492               if (fcont.gt.0.0D0) then
 493 C If the SC-SC distance if close to sigma, apply spline.
 494 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 495 cAdam &             fcont1,fprimcont1)
 496 cAdam           fcont1=1.0d0-fcont1
 497 cAdam           if (fcont1.gt.0.0d0) then
 498 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 499 cAdam             fcont=fcont*fcont1
 500 cAdam           endif
 501 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 502 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 503 cga             do k=1,3
 504 cga               gg(k)=gg(k)*eps0ij
 505 cga             enddo
 506 cga             eps0ij=-evdwij*eps0ij
 507 C Uncomment for AL's type of SC correlation interactions.
 508 cadam           eps0ij=-evdwij
 509                 num_conti=num_conti+1
 510                 jcont(num_conti,i)=j
 511                 facont(num_conti,i)=fcont*eps0ij
 512                 fprimcont=eps0ij*fprimcont/rij
 513                 fcont=expon*fcont
 514 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 515 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 516 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 517 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 518                 gacont(1,num_conti,i)=-fprimcont*xj
 519                 gacont(2,num_conti,i)=-fprimcont*yj
 520                 gacont(3,num_conti,i)=-fprimcont*zj
 521 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 522 cd              write (iout,'(2i3,3f10.5)')
 523 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 524               endif
 525             endif
 526           enddo      ! j
 527         enddo        ! iint
 528 C Change 12/1/95
 529         num_cont(i)=num_conti
 530       enddo          ! i
 531       if (calc_grad) then
 532       do i=1,nct
 533         do j=1,3
 534           gvdwc(j,i)=expon*gvdwc(j,i)
 535           gvdwx(j,i)=expon*gvdwx(j,i)
 536         enddo
 537       enddo
 538       endif
 539 C******************************************************************************
 540 C
 541 C                              N O T E !!!
 542 C
 543 C To save time, the factor of EXPON has been extracted from ALL components
 544 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 545 C use!
 546 C
 547 C******************************************************************************
 548       return
 549       end
 550 C-----------------------------------------------------------------------------
 551       subroutine eljk(evdw)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJK potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'sizesclu.dat'
 559 c      include "DIMENSIONS.COMPAR"
 560       include 'COMMON.GEO'
 561       include 'COMMON.VAR'
 562       include 'COMMON.LOCAL'
 563       include 'COMMON.CHAIN'
 564       include 'COMMON.DERIV'
 565       include 'COMMON.INTERACT'
 566       include 'COMMON.IOUNITS'
 567       include 'COMMON.NAMES'
 568       dimension gg(3)
 569       logical scheck
 570       integer icant
 571       external icant
 572 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 573       evdw=0.0D0
 574       do i=iatsc_s,iatsc_e
 575         itypi=itype(i)
 576         itypi1=itype(i+1)
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=itype(j)
 586             xj=c(1,nres+j)-xi
 587             yj=c(2,nres+j)-yi
 588             zj=c(3,nres+j)-zi
 589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 590             fac_augm=rrij**expon
 591             e_augm=augm(itypi,itypj)*fac_augm
 592             r_inv_ij=dsqrt(rrij)
 593             rij=1.0D0/r_inv_ij
 594             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 595             fac=r_shift_inv**expon
 596             e1=fac*fac*aa(itypi,itypj)
 597             e2=fac*bb(itypi,itypj)
 598             evdwij=e_augm+e1+e2
 599             ij=icant(itypi,itypj)
 600 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 601 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 602 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 603 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 604 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 605 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 606 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 607             evdw=evdw+evdwij
 608             if (calc_grad) then
 609 C
 610 C Calculate the components of the gradient in DC and X
 611 C
 612             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 613             gg(1)=xj*fac
 614             gg(2)=yj*fac
 615             gg(3)=zj*fac
 616             do k=1,3
 617               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 618               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 619             enddo
 620             do k=i,j-1
 621               do l=1,3
 622                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 623               enddo
 624             enddo
 625             endif
 626           enddo      ! j
 627         enddo        ! iint
 628       enddo          ! i
 629       if (calc_grad) then
 630       do i=1,nct
 631         do j=1,3
 632           gvdwc(j,i)=expon*gvdwc(j,i)
 633           gvdwx(j,i)=expon*gvdwx(j,i)
 634         enddo
 635       enddo
 636       endif
 637       return
 638       end
 639 C-----------------------------------------------------------------------------
 640       subroutine ebp(evdw)
 641 C
 642 C This subroutine calculates the interaction energy of nonbonded side chains
 643 C assuming the Berne-Pechukas potential of interaction.
 644 C
 645       implicit real*8 (a-h,o-z)
 646       include 'DIMENSIONS'
 647       include 'sizesclu.dat'
 648 c      include "DIMENSIONS.COMPAR"
 649       include 'COMMON.GEO'
 650       include 'COMMON.VAR'
 651       include 'COMMON.LOCAL'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.DERIV'
 654       include 'COMMON.NAMES'
 655       include 'COMMON.INTERACT'
 656       include 'COMMON.IOUNITS'
 657       include 'COMMON.CALC'
 658       common /srutu/ icall
 659 c     double precision rrsave(maxdim)
 660       logical lprn
 661       integer icant
 662       external icant
 663       evdw=0.0D0
 664 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 665       evdw=0.0D0
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=itype(i)
 674         itypi1=itype(i+1)
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678         dxi=dc_norm(1,nres+i)
 679         dyi=dc_norm(2,nres+i)
 680         dzi=dc_norm(3,nres+i)
 681         dsci_inv=vbld_inv(i+nres)
 682 C
 683 C Calculate SC interaction energy.
 684 C
 685         do iint=1,nint_gr(i)
 686           do j=istart(i,iint),iend(i,iint)
 687             ind=ind+1
 688             itypj=itype(j)
 689             dscj_inv=vbld_inv(j+nres)
 690             chi1=chi(itypi,itypj)
 691             chi2=chi(itypj,itypi)
 692             chi12=chi1*chi2
 693             chip1=chip(itypi)
 694             chip2=chip(itypj)
 695             chip12=chip1*chip2
 696             alf1=alp(itypi)
 697             alf2=alp(itypj)
 698             alf12=0.5D0*(alf1+alf2)
 699 C For diagnostics only!!!
 700 c           chi1=0.0D0
 701 c           chi2=0.0D0
 702 c           chi12=0.0D0
 703 c           chip1=0.0D0
 704 c           chip2=0.0D0
 705 c           chip12=0.0D0
 706 c           alf1=0.0D0
 707 c           alf2=0.0D0
 708 c           alf12=0.0D0
 709             xj=c(1,nres+j)-xi
 710             yj=c(2,nres+j)-yi
 711             zj=c(3,nres+j)-zi
 712             dxj=dc_norm(1,nres+j)
 713             dyj=dc_norm(2,nres+j)
 714             dzj=dc_norm(3,nres+j)
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716 cd          if (icall.eq.0) then
 717 cd            rrsave(ind)=rrij
 718 cd          else
 719 cd            rrij=rrsave(ind)
 720 cd          endif
 721             rij=dsqrt(rrij)
 722 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 723             call sc_angular
 724 C Calculate whole angle-dependent part of epsilon and contributions
 725 C to its derivatives
 726             fac=(rrij*sigsq)**expon2
 727             e1=fac*fac*aa(itypi,itypj)
 728             e2=fac*bb(itypi,itypj)
 729             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 730             eps2der=evdwij*eps3rt
 731             eps3der=evdwij*eps2rt
 732             evdwij=evdwij*eps2rt*eps3rt
 733             ij=icant(itypi,itypj)
 734             aux=eps1*eps2rt**2*eps3rt**2
 735             evdw=evdw+evdwij
 736             if (calc_grad) then
 737             if (lprn) then
 738             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 741 cd     &        restyp(itypi),i,restyp(itypj),j,
 742 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 743 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 744 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 745 cd     &        evdwij
 746             endif
 747 C Calculate gradient components.
 748             e1=e1*eps1*eps2rt**2*eps3rt**2
 749             fac=-expon*(e1+evdwij)
 750             sigder=fac/sigsq
 751             fac=rrij*fac
 752 C Calculate radial part of the gradient
 753             gg(1)=xj*fac
 754             gg(2)=yj*fac
 755             gg(3)=zj*fac
 756 C Calculate the angular part of the gradient and sum add the contributions
 757 C to the appropriate components of the Cartesian gradient.
 758             call sc_grad
 759             endif
 760           enddo      ! j
 761         enddo        ! iint
 762       enddo          ! i
 763 c     stop
 764       return
 765       end
 766 C-----------------------------------------------------------------------------
 767       subroutine egb(evdw)
 768 C
 769 C This subroutine calculates the interaction energy of nonbonded side chains
 770 C assuming the Gay-Berne potential of interaction.
 771 C
 772       implicit real*8 (a-h,o-z)
 773       include 'DIMENSIONS'
 774       include 'sizesclu.dat'
 775 c      include "DIMENSIONS.COMPAR"
 776       include 'COMMON.GEO'
 777       include 'COMMON.VAR'
 778       include 'COMMON.LOCAL'
 779       include 'COMMON.CHAIN'
 780       include 'COMMON.DERIV'
 781       include 'COMMON.NAMES'
 782       include 'COMMON.INTERACT'
 783       include 'COMMON.IOUNITS'
 784       include 'COMMON.CALC'
 785       include 'COMMON.SBRIDGE'
 786       logical lprn
 787       common /srutu/icall
 788       integer icant
 789       external icant
 790       evdw=0.0D0
 791 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 792       evdw=0.0D0
 793       lprn=.false.
 794 c      if (icall.gt.0) lprn=.true.
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=itype(i)
 798         itypi1=itype(i+1)
 799         xi=c(1,nres+i)
 800         yi=c(2,nres+i)
 801         zi=c(3,nres+i)
 802         dxi=dc_norm(1,nres+i)
 803         dyi=dc_norm(2,nres+i)
 804         dzi=dc_norm(3,nres+i)
 805         dsci_inv=vbld_inv(i+nres)
 806 C
 807 C Calculate SC interaction energy.
 808 C
 809         do iint=1,nint_gr(i)
 810           do j=istart(i,iint),iend(i,iint)
 811             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 812               call dyn_ssbond_ene(i,j,evdwij)
 813               evdw=evdw+evdwij
 814 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 815 c     &                        'evdw',i,j,evdwij,' ss'
 816             ELSE
 817             ind=ind+1
 818             itypj=itype(j)
 819             dscj_inv=vbld_inv(j+nres)
 820             sig0ij=sigma(itypi,itypj)
 821             chi1=chi(itypi,itypj)
 822             chi2=chi(itypj,itypi)
 823             chi12=chi1*chi2
 824             chip1=chip(itypi)
 825             chip2=chip(itypj)
 826             chip12=chip1*chip2
 827             alf1=alp(itypi)
 828             alf2=alp(itypj)
 829             alf12=0.5D0*(alf1+alf2)
 830 C For diagnostics only!!!
 831 c           chi1=0.0D0
 832 c           chi2=0.0D0
 833 c           chi12=0.0D0
 834 c           chip1=0.0D0
 835 c           chip2=0.0D0
 836 c           chip12=0.0D0
 837 c           alf1=0.0D0
 838 c           alf2=0.0D0
 839 c           alf12=0.0D0
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843             dxj=dc_norm(1,nres+j)
 844             dyj=dc_norm(2,nres+j)
 845             dzj=dc_norm(3,nres+j)
 846 c            write (iout,*) i,j,xj,yj,zj
 847             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 848             rij=dsqrt(rrij)
 849 C Calculate angle-dependent terms of energy and contributions to their
 850 C derivatives.
 851             call sc_angular
 852             sigsq=1.0D0/sigsq
 853             sig=sig0ij*dsqrt(sigsq)
 854             rij_shift=1.0D0/rij-sig+sig0ij
 855 C I hate to put IF's in the loops, but here don't have another choice!!!!
 856             if (rij_shift.le.0.0D0) then
 857               evdw=1.0D20
 858               return
 859             endif
 860             sigder=-sig*sigsq
 861 c---------------------------------------------------------------
 862             rij_shift=1.0D0/rij_shift
 863             fac=rij_shift**expon
 864             e1=fac*fac*aa(itypi,itypj)
 865             e2=fac*bb(itypi,itypj)
 866             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 867             eps2der=evdwij*eps3rt
 868             eps3der=evdwij*eps2rt
 869             evdwij=evdwij*eps2rt*eps3rt
 870             evdw=evdw+evdwij
 871             ij=icant(itypi,itypj)
 872             aux=eps1*eps2rt**2*eps3rt**2
 873 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 874 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 875 c     &         aux*e2/eps(itypi,itypj)
 876             if (lprn) then
 877             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 878             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 879             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 880      &        restyp(itypi),i,restyp(itypj),j,
 881      &        epsi,sigm,chi1,chi2,chip1,chip2,
 882      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 883      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 884      &        evdwij
 885             endif
 886             if (calc_grad) then
 887 C Calculate gradient components.
 888             e1=e1*eps1*eps2rt**2*eps3rt**2
 889             fac=-expon*(e1+evdwij)*rij_shift
 890             sigder=fac*sigder
 891             fac=rij*fac
 892 C Calculate the radial part of the gradient
 893             gg(1)=xj*fac
 894             gg(2)=yj*fac
 895             gg(3)=zj*fac
 896 C Calculate angular part of the gradient.
 897             call sc_grad
 898             endif
 899             ENDIF    ! SSBOND
 900           enddo      ! j
 901         enddo        ! iint
 902       enddo          ! i
 903       return
 904       end
 905 C-----------------------------------------------------------------------------
 906       subroutine egbv(evdw)
 907 C
 908 C This subroutine calculates the interaction energy of nonbonded side chains
 909 C assuming the Gay-Berne-Vorobjev potential of interaction.
 910 C
 911       implicit real*8 (a-h,o-z)
 912       include 'DIMENSIONS'
 913       include 'sizesclu.dat'
 914 c      include "DIMENSIONS.COMPAR"
 915       include 'COMMON.GEO'
 916       include 'COMMON.VAR'
 917       include 'COMMON.LOCAL'
 918       include 'COMMON.CHAIN'
 919       include 'COMMON.DERIV'
 920       include 'COMMON.NAMES'
 921       include 'COMMON.INTERACT'
 922       include 'COMMON.IOUNITS'
 923       include 'COMMON.CALC'
 924       include 'COMMON.SBRIDGE'
 925       common /srutu/ icall
 926       logical lprn
 927       integer icant
 928       external icant
 929       evdw=0.0D0
 930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 931       evdw=0.0D0
 932       lprn=.false.
 933 c      if (icall.gt.0) lprn=.true.
 934       ind=0
 935       do i=iatsc_s,iatsc_e
 936         itypi=itype(i)
 937         itypi1=itype(i+1)
 938         xi=c(1,nres+i)
 939         yi=c(2,nres+i)
 940         zi=c(3,nres+i)
 941         dxi=dc_norm(1,nres+i)
 942         dyi=dc_norm(2,nres+i)
 943         dzi=dc_norm(3,nres+i)
 944         dsci_inv=vbld_inv(i+nres)
 945 C
 946 C Calculate SC interaction energy.
 947 C
 948         do iint=1,nint_gr(i)
 949           do j=istart(i,iint),iend(i,iint)
 950 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 951             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 952               call dyn_ssbond_ene(i,j,evdwij)
 953               evdw=evdw+evdwij
 954 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 955 c     &                        'evdw',i,j,evdwij,' ss'
 956             ELSE
 957             ind=ind+1
 958             itypj=itype(j)
 959             dscj_inv=vbld_inv(j+nres)
 960             sig0ij=sigma(itypi,itypj)
 961             r0ij=r0(itypi,itypj)
 962             chi1=chi(itypi,itypj)
 963             chi2=chi(itypj,itypi)
 964             chi12=chi1*chi2
 965             chip1=chip(itypi)
 966             chip2=chip(itypj)
 967             chip12=chip1*chip2
 968             alf1=alp(itypi)
 969             alf2=alp(itypj)
 970             alf12=0.5D0*(alf1+alf2)
 971 C For diagnostics only!!!
 972 c           chi1=0.0D0
 973 c           chi2=0.0D0
 974 c           chi12=0.0D0
 975 c           chip1=0.0D0
 976 c           chip2=0.0D0
 977 c           chip12=0.0D0
 978 c           alf1=0.0D0
 979 c           alf2=0.0D0
 980 c           alf12=0.0D0
 981             xj=c(1,nres+j)-xi
 982             yj=c(2,nres+j)-yi
 983             zj=c(3,nres+j)-zi
 984             dxj=dc_norm(1,nres+j)
 985             dyj=dc_norm(2,nres+j)
 986             dzj=dc_norm(3,nres+j)
 987             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 988             rij=dsqrt(rrij)
 989 C Calculate angle-dependent terms of energy and contributions to their
 990 C derivatives.
 991             call sc_angular
 992             sigsq=1.0D0/sigsq
 993             sig=sig0ij*dsqrt(sigsq)
 994             rij_shift=1.0D0/rij-sig+r0ij
 995 C I hate to put IF's in the loops, but here don't have another choice!!!!
 996             if (rij_shift.le.0.0D0) then
 997               evdw=1.0D20
 998               return
 999             endif
1000             sigder=-sig*sigsq
1001 c---------------------------------------------------------------
1002             rij_shift=1.0D0/rij_shift
1003             fac=rij_shift**expon
1004             e1=fac*fac*aa(itypi,itypj)
1005             e2=fac*bb(itypi,itypj)
1006             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1007             eps2der=evdwij*eps3rt
1008             eps3der=evdwij*eps2rt
1009             fac_augm=rrij**expon
1010             e_augm=augm(itypi,itypj)*fac_augm
1011             evdwij=evdwij*eps2rt*eps3rt
1012             evdw=evdw+evdwij+e_augm
1013             ij=icant(itypi,itypj)
1014             aux=eps1*eps2rt**2*eps3rt**2
1015 c            if (lprn) then
1016 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1017 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1018 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1019 c     &        restyp(itypi),i,restyp(itypj),j,
1020 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1021 c     &        chi1,chi2,chip1,chip2,
1022 c     &        eps1,eps2rt**2,eps3rt**2,
1023 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1024 c     &        evdwij+e_augm
1025 c            endif
1026             if (calc_grad) then
1027 C Calculate gradient components.
1028             e1=e1*eps1*eps2rt**2*eps3rt**2
1029             fac=-expon*(e1+evdwij)*rij_shift
1030             sigder=fac*sigder
1031             fac=rij*fac-2*expon*rrij*e_augm
1032 C Calculate the radial part of the gradient
1033             gg(1)=xj*fac
1034             gg(2)=yj*fac
1035             gg(3)=zj*fac
1036 C Calculate angular part of the gradient.
1037             call sc_grad
1038             endif
1039             ENDIF    ! dyn_ss
1040           enddo      ! j
1041         enddo        ! iint
1042       enddo          ! i
1043       return
1044       end
1045 C-----------------------------------------------------------------------------
1046       subroutine sc_angular
1047 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1048 C om12. Called by ebp, egb, and egbv.
1049       implicit none
1050       include 'COMMON.CALC'
1051       erij(1)=xj*rij
1052       erij(2)=yj*rij
1053       erij(3)=zj*rij
1054       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1055       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1056       om12=dxi*dxj+dyi*dyj+dzi*dzj
1057       chiom12=chi12*om12
1058 C Calculate eps1(om12) and its derivative in om12
1059       faceps1=1.0D0-om12*chiom12
1060       faceps1_inv=1.0D0/faceps1
1061       eps1=dsqrt(faceps1_inv)
1062 C Following variable is eps1*deps1/dom12
1063       eps1_om12=faceps1_inv*chiom12
1064 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1065 C and om12.
1066       om1om2=om1*om2
1067       chiom1=chi1*om1
1068       chiom2=chi2*om2
1069       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1070       sigsq=1.0D0-facsig*faceps1_inv
1071       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1072       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1073       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1074 C Calculate eps2 and its derivatives in om1, om2, and om12.
1075       chipom1=chip1*om1
1076       chipom2=chip2*om2
1077       chipom12=chip12*om12
1078       facp=1.0D0-om12*chipom12
1079       facp_inv=1.0D0/facp
1080       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1081 C Following variable is the square root of eps2
1082       eps2rt=1.0D0-facp1*facp_inv
1083 C Following three variables are the derivatives of the square root of eps
1084 C in om1, om2, and om12.
1085       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1086       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1087       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1088 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1089       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1090 C Calculate whole angle-dependent part of epsilon and contributions
1091 C to its derivatives
1092       return
1093       end
1094 C----------------------------------------------------------------------------
1095       subroutine sc_grad
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       include 'sizesclu.dat'
1099       include 'COMMON.CHAIN'
1100       include 'COMMON.DERIV'
1101       include 'COMMON.CALC'
1102       double precision dcosom1(3),dcosom2(3)
1103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1104       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1105       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1106      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1107       do k=1,3
1108         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1109         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1110       enddo
1111       do k=1,3
1112         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1113       enddo
1114       do k=1,3
1115         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1117      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1118         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1119      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1120      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1121       enddo
1122 C
1123 C Calculate the components of the gradient in DC and X
1124 C
1125       do k=i,j-1
1126         do l=1,3
1127           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128         enddo
1129       enddo
1130       return
1131       end
1132 c------------------------------------------------------------------------------
1133       subroutine vec_and_deriv
1134       implicit real*8 (a-h,o-z)
1135       include 'DIMENSIONS'
1136       include 'sizesclu.dat'
1137       include 'COMMON.IOUNITS'
1138       include 'COMMON.GEO'
1139       include 'COMMON.VAR'
1140       include 'COMMON.LOCAL'
1141       include 'COMMON.CHAIN'
1142       include 'COMMON.VECTORS'
1143       include 'COMMON.DERIV'
1144       include 'COMMON.INTERACT'
1145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1146 C Compute the local reference systems. For reference system (i), the
1147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1149       do i=1,nres-1
1150 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1151           if (i.eq.nres-1) then
1152 C Case of the last full residue
1153 C Compute the Z-axis
1154             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1155             costh=dcos(pi-theta(nres))
1156             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1157             do k=1,3
1158               uz(k,i)=fac*uz(k,i)
1159             enddo
1160             if (calc_grad) then
1161 C Compute the derivatives of uz
1162             uzder(1,1,1)= 0.0d0
1163             uzder(2,1,1)=-dc_norm(3,i-1)
1164             uzder(3,1,1)= dc_norm(2,i-1)
1165             uzder(1,2,1)= dc_norm(3,i-1)
1166             uzder(2,2,1)= 0.0d0
1167             uzder(3,2,1)=-dc_norm(1,i-1)
1168             uzder(1,3,1)=-dc_norm(2,i-1)
1169             uzder(2,3,1)= dc_norm(1,i-1)
1170             uzder(3,3,1)= 0.0d0
1171             uzder(1,1,2)= 0.0d0
1172             uzder(2,1,2)= dc_norm(3,i)
1173             uzder(3,1,2)=-dc_norm(2,i)
1174             uzder(1,2,2)=-dc_norm(3,i)
1175             uzder(2,2,2)= 0.0d0
1176             uzder(3,2,2)= dc_norm(1,i)
1177             uzder(1,3,2)= dc_norm(2,i)
1178             uzder(2,3,2)=-dc_norm(1,i)
1179             uzder(3,3,2)= 0.0d0
1180             endif
1181 C Compute the Y-axis
1182             facy=fac
1183             do k=1,3
1184               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1185             enddo
1186             if (calc_grad) then
1187 C Compute the derivatives of uy
1188             do j=1,3
1189               do k=1,3
1190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1193               enddo
1194               uyder(j,j,1)=uyder(j,j,1)-costh
1195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1196             enddo
1197             do j=1,2
1198               do k=1,3
1199                 do l=1,3
1200                   uygrad(l,k,j,i)=uyder(l,k,j)
1201                   uzgrad(l,k,j,i)=uzder(l,k,j)
1202                 enddo
1203               enddo
1204             enddo
1205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1209             endif
1210           else
1211 C Other residues
1212 C Compute the Z-axis
1213             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1214             costh=dcos(pi-theta(i+2))
1215             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1216             do k=1,3
1217               uz(k,i)=fac*uz(k,i)
1218             enddo
1219             if (calc_grad) then
1220 C Compute the derivatives of uz
1221             uzder(1,1,1)= 0.0d0
1222             uzder(2,1,1)=-dc_norm(3,i+1)
1223             uzder(3,1,1)= dc_norm(2,i+1)
1224             uzder(1,2,1)= dc_norm(3,i+1)
1225             uzder(2,2,1)= 0.0d0
1226             uzder(3,2,1)=-dc_norm(1,i+1)
1227             uzder(1,3,1)=-dc_norm(2,i+1)
1228             uzder(2,3,1)= dc_norm(1,i+1)
1229             uzder(3,3,1)= 0.0d0
1230             uzder(1,1,2)= 0.0d0
1231             uzder(2,1,2)= dc_norm(3,i)
1232             uzder(3,1,2)=-dc_norm(2,i)
1233             uzder(1,2,2)=-dc_norm(3,i)
1234             uzder(2,2,2)= 0.0d0
1235             uzder(3,2,2)= dc_norm(1,i)
1236             uzder(1,3,2)= dc_norm(2,i)
1237             uzder(2,3,2)=-dc_norm(1,i)
1238             uzder(3,3,2)= 0.0d0
1239             endif
1240 C Compute the Y-axis
1241             facy=fac
1242             do k=1,3
1243               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1244             enddo
1245             if (calc_grad) then
1246 C Compute the derivatives of uy
1247             do j=1,3
1248               do k=1,3
1249                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1250      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1251                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1252               enddo
1253               uyder(j,j,1)=uyder(j,j,1)-costh
1254               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1255             enddo
1256             do j=1,2
1257               do k=1,3
1258                 do l=1,3
1259                   uygrad(l,k,j,i)=uyder(l,k,j)
1260                   uzgrad(l,k,j,i)=uzder(l,k,j)
1261                 enddo
1262               enddo
1263             enddo
1264             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1265             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1266             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1267             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1268           endif
1269           endif
1270       enddo
1271       if (calc_grad) then
1272       do i=1,nres-1
1273         vbld_inv_temp(1)=vbld_inv(i+1)
1274         if (i.lt.nres-1) then
1275           vbld_inv_temp(2)=vbld_inv(i+2)
1276         else
1277           vbld_inv_temp(2)=vbld_inv(i)
1278         endif
1279         do j=1,2
1280           do k=1,3
1281             do l=1,3
1282               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1283               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1284             enddo
1285           enddo
1286         enddo
1287       enddo
1288       endif
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine vec_and_deriv_test
1293       implicit real*8 (a-h,o-z)
1294       include 'DIMENSIONS'
1295       include 'sizesclu.dat'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.VECTORS'
1302       dimension uyder(3,3,2),uzder(3,3,2)
1303 C Compute the local reference systems. For reference system (i), the
1304 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1305 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1306       do i=1,nres-1
1307           if (i.eq.nres-1) then
1308 C Case of the last full residue
1309 C Compute the Z-axis
1310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1311             costh=dcos(pi-theta(nres))
1312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1313 c            write (iout,*) 'fac',fac,
1314 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1315             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1316             do k=1,3
1317               uz(k,i)=fac*uz(k,i)
1318             enddo
1319 C Compute the derivatives of uz
1320             uzder(1,1,1)= 0.0d0
1321             uzder(2,1,1)=-dc_norm(3,i-1)
1322             uzder(3,1,1)= dc_norm(2,i-1)
1323             uzder(1,2,1)= dc_norm(3,i-1)
1324             uzder(2,2,1)= 0.0d0
1325             uzder(3,2,1)=-dc_norm(1,i-1)
1326             uzder(1,3,1)=-dc_norm(2,i-1)
1327             uzder(2,3,1)= dc_norm(1,i-1)
1328             uzder(3,3,1)= 0.0d0
1329             uzder(1,1,2)= 0.0d0
1330             uzder(2,1,2)= dc_norm(3,i)
1331             uzder(3,1,2)=-dc_norm(2,i)
1332             uzder(1,2,2)=-dc_norm(3,i)
1333             uzder(2,2,2)= 0.0d0
1334             uzder(3,2,2)= dc_norm(1,i)
1335             uzder(1,3,2)= dc_norm(2,i)
1336             uzder(2,3,2)=-dc_norm(1,i)
1337             uzder(3,3,2)= 0.0d0
1338 C Compute the Y-axis
1339             do k=1,3
1340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1341             enddo
1342             facy=fac
1343             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1344      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1345      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1346             do k=1,3
1347 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348               uy(k,i)=
1349 c     &        facy*(
1350      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1351      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1352 c     &        )
1353             enddo
1354 c            write (iout,*) 'facy',facy,
1355 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1356             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1357             do k=1,3
1358               uy(k,i)=facy*uy(k,i)
1359             enddo
1360 C Compute the derivatives of uy
1361             do j=1,3
1362               do k=1,3
1363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1366               enddo
1367 c              uyder(j,j,1)=uyder(j,j,1)-costh
1368 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1369               uyder(j,j,1)=uyder(j,j,1)
1370      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1371               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1372      &          +uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386           else
1387 C Other residues
1388 C Compute the Z-axis
1389             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1390             costh=dcos(pi-theta(i+2))
1391             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i+1)
1399             uzder(3,1,1)= dc_norm(2,i+1)
1400             uzder(1,2,1)= dc_norm(3,i+1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i+1)
1403             uzder(1,3,1)=-dc_norm(2,i+1)
1404             uzder(2,3,1)= dc_norm(1,i+1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             facy=fac
1417             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1418      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1419      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1420             do k=1,3
1421 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1422               uy(k,i)=
1423 c     &        facy*(
1424      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1425      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1426 c     &        )
1427             enddo
1428 c            write (iout,*) 'facy',facy,
1429 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1430             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1431             do k=1,3
1432               uy(k,i)=facy*uy(k,i)
1433             enddo
1434 C Compute the derivatives of uy
1435             do j=1,3
1436               do k=1,3
1437                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1438      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1439                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1440               enddo
1441 c              uyder(j,j,1)=uyder(j,j,1)-costh
1442 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1443               uyder(j,j,1)=uyder(j,j,1)
1444      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1445               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1446      &          +uyder(j,j,2)
1447             enddo
1448             do j=1,2
1449               do k=1,3
1450                 do l=1,3
1451                   uygrad(l,k,j,i)=uyder(l,k,j)
1452                   uzgrad(l,k,j,i)=uzder(l,k,j)
1453                 enddo
1454               enddo
1455             enddo
1456             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1457             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1458             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1459             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1460           endif
1461       enddo
1462       do i=1,nres-1
1463         do j=1,2
1464           do k=1,3
1465             do l=1,3
1466               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1467               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1468             enddo
1469           enddo
1470         enddo
1471       enddo
1472       return
1473       end
1474 C-----------------------------------------------------------------------------
1475       subroutine check_vecgrad
1476       implicit real*8 (a-h,o-z)
1477       include 'DIMENSIONS'
1478       include 'sizesclu.dat'
1479       include 'COMMON.IOUNITS'
1480       include 'COMMON.GEO'
1481       include 'COMMON.VAR'
1482       include 'COMMON.LOCAL'
1483       include 'COMMON.CHAIN'
1484       include 'COMMON.VECTORS'
1485       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1486       dimension uyt(3,maxres),uzt(3,maxres)
1487       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1488       double precision delta /1.0d-7/
1489       call vec_and_deriv
1490 cd      do i=1,nres
1491 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1492 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1493 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1494 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1495 cd     &     (dc_norm(if90,i),if90=1,3)
1496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1497 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1498 cd          write(iout,'(a)')
1499 cd      enddo
1500       do i=1,nres
1501         do j=1,2
1502           do k=1,3
1503             do l=1,3
1504               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1505               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1506             enddo
1507           enddo
1508         enddo
1509       enddo
1510       call vec_and_deriv
1511       do i=1,nres
1512         do j=1,3
1513           uyt(j,i)=uy(j,i)
1514           uzt(j,i)=uz(j,i)
1515         enddo
1516       enddo
1517       do i=1,nres
1518 cd        write (iout,*) 'i=',i
1519         do k=1,3
1520           erij(k)=dc_norm(k,i)
1521         enddo
1522         do j=1,3
1523           do k=1,3
1524             dc_norm(k,i)=erij(k)
1525           enddo
1526           dc_norm(j,i)=dc_norm(j,i)+delta
1527 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1528 c          do k=1,3
1529 c            dc_norm(k,i)=dc_norm(k,i)/fac
1530 c          enddo
1531 c          write (iout,*) (dc_norm(k,i),k=1,3)
1532 c          write (iout,*) (erij(k),k=1,3)
1533           call vec_and_deriv
1534           do k=1,3
1535             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1536             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1537             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1538             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1539           enddo
1540 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1541 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1542 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1543         enddo
1544         do k=1,3
1545           dc_norm(k,i)=erij(k)
1546         enddo
1547 cd        do k=1,3
1548 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1549 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1550 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1551 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1552 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1553 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1554 cd          write (iout,'(a)')
1555 cd        enddo
1556       enddo
1557       return
1558       end
1559 C--------------------------------------------------------------------------
1560       subroutine set_matrices
1561       implicit real*8 (a-h,o-z)
1562       include 'DIMENSIONS'
1563       include 'sizesclu.dat'
1564       include 'COMMON.IOUNITS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.CONTACTS'
1572       include 'COMMON.TORSION'
1573       include 'COMMON.VECTORS'
1574       include 'COMMON.FFIELD'
1575       double precision auxvec(2),auxmat(2,2)
1576 C
1577 C Compute the virtual-bond-torsional-angle dependent quantities needed
1578 C to calculate the el-loc multibody terms of various order.
1579 C
1580       do i=3,nres+1
1581         if (i .lt. nres+1) then
1582           sin1=dsin(phi(i))
1583           cos1=dcos(phi(i))
1584           sintab(i-2)=sin1
1585           costab(i-2)=cos1
1586           obrot(1,i-2)=cos1
1587           obrot(2,i-2)=sin1
1588           sin2=dsin(2*phi(i))
1589           cos2=dcos(2*phi(i))
1590           sintab2(i-2)=sin2
1591           costab2(i-2)=cos2
1592           obrot2(1,i-2)=cos2
1593           obrot2(2,i-2)=sin2
1594           Ug(1,1,i-2)=-cos1
1595           Ug(1,2,i-2)=-sin1
1596           Ug(2,1,i-2)=-sin1
1597           Ug(2,2,i-2)= cos1
1598           Ug2(1,1,i-2)=-cos2
1599           Ug2(1,2,i-2)=-sin2
1600           Ug2(2,1,i-2)=-sin2
1601           Ug2(2,2,i-2)= cos2
1602         else
1603           costab(i-2)=1.0d0
1604           sintab(i-2)=0.0d0
1605           obrot(1,i-2)=1.0d0
1606           obrot(2,i-2)=0.0d0
1607           obrot2(1,i-2)=0.0d0
1608           obrot2(2,i-2)=0.0d0
1609           Ug(1,1,i-2)=1.0d0
1610           Ug(1,2,i-2)=0.0d0
1611           Ug(2,1,i-2)=0.0d0
1612           Ug(2,2,i-2)=1.0d0
1613           Ug2(1,1,i-2)=0.0d0
1614           Ug2(1,2,i-2)=0.0d0
1615           Ug2(2,1,i-2)=0.0d0
1616           Ug2(2,2,i-2)=0.0d0
1617         endif
1618         if (i .gt. 3 .and. i .lt. nres+1) then
1619           obrot_der(1,i-2)=-sin1
1620           obrot_der(2,i-2)= cos1
1621           Ugder(1,1,i-2)= sin1
1622           Ugder(1,2,i-2)=-cos1
1623           Ugder(2,1,i-2)=-cos1
1624           Ugder(2,2,i-2)=-sin1
1625           dwacos2=cos2+cos2
1626           dwasin2=sin2+sin2
1627           obrot2_der(1,i-2)=-dwasin2
1628           obrot2_der(2,i-2)= dwacos2
1629           Ug2der(1,1,i-2)= dwasin2
1630           Ug2der(1,2,i-2)=-dwacos2
1631           Ug2der(2,1,i-2)=-dwacos2
1632           Ug2der(2,2,i-2)=-dwasin2
1633         else
1634           obrot_der(1,i-2)=0.0d0
1635           obrot_der(2,i-2)=0.0d0
1636           Ugder(1,1,i-2)=0.0d0
1637           Ugder(1,2,i-2)=0.0d0
1638           Ugder(2,1,i-2)=0.0d0
1639           Ugder(2,2,i-2)=0.0d0
1640           obrot2_der(1,i-2)=0.0d0
1641           obrot2_der(2,i-2)=0.0d0
1642           Ug2der(1,1,i-2)=0.0d0
1643           Ug2der(1,2,i-2)=0.0d0
1644           Ug2der(2,1,i-2)=0.0d0
1645           Ug2der(2,2,i-2)=0.0d0
1646         endif
1647         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1648           iti = itortyp(itype(i-2))
1649         else
1650           iti=ntortyp+1
1651         endif
1652         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1653           iti1 = itortyp(itype(i-1))
1654         else
1655           iti1=ntortyp+1
1656         endif
1657 cd        write (iout,*) '*******i',i,' iti1',iti
1658 cd        write (iout,*) 'b1',b1(:,iti)
1659 cd        write (iout,*) 'b2',b2(:,iti)
1660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1661         if (i .gt. iatel_s+2) then
1662           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1663           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1664           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1665           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1666           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1667           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1668           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1669         else
1670           do k=1,2
1671             Ub2(k,i-2)=0.0d0
1672             Ctobr(k,i-2)=0.0d0
1673             Dtobr2(k,i-2)=0.0d0
1674             do l=1,2
1675               EUg(l,k,i-2)=0.0d0
1676               CUg(l,k,i-2)=0.0d0
1677               DUg(l,k,i-2)=0.0d0
1678               DtUg2(l,k,i-2)=0.0d0
1679             enddo
1680           enddo
1681         endif
1682         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1683         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1684         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1685         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1686         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1687         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1688         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1689         do k=1,2
1690           muder(k,i-2)=Ub2der(k,i-2)
1691         enddo
1692         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1693           iti1 = itortyp(itype(i-1))
1694         else
1695           iti1=ntortyp+1
1696         endif
1697         do k=1,2
1698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1699         enddo
1700 C Vectors and matrices dependent on a single virtual-bond dihedral.
1701         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1702         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1703         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1704         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1705         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1706         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1707         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1708         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1709         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1710 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1711 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1712       enddo
1713 C Matrices dependent on two consecutive virtual-bond dihedrals.
1714 C The order of matrices is from left to right.
1715       do i=2,nres-1
1716         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1717         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1718         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1719         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1720         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1721         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1722         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1723         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1724       enddo
1725 cd      do i=1,nres
1726 cd        iti = itortyp(itype(i))
1727 cd        write (iout,*) i
1728 cd        do j=1,2
1729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1731 cd        enddo
1732 cd      enddo
1733       return
1734       end
1735 C--------------------------------------------------------------------------
1736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1737 C
1738 C This subroutine calculates the average interaction energy and its gradient
1739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1741 C The potential depends both on the distance of peptide-group centers and on
1742 C the orientation of the CA-CA virtual bonds.
1743 C
1744       implicit real*8 (a-h,o-z)
1745       include 'DIMENSIONS'
1746       include 'sizesclu.dat'
1747       include 'COMMON.CONTROL'
1748       include 'COMMON.IOUNITS'
1749       include 'COMMON.GEO'
1750       include 'COMMON.VAR'
1751       include 'COMMON.LOCAL'
1752       include 'COMMON.CHAIN'
1753       include 'COMMON.DERIV'
1754       include 'COMMON.INTERACT'
1755       include 'COMMON.CONTACTS'
1756       include 'COMMON.TORSION'
1757       include 'COMMON.VECTORS'
1758       include 'COMMON.FFIELD'
1759       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1760      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1761       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1765       double precision scal_el /0.5d0/
1766 C 12/13/98
1767 C 13-go grudnia roku pamietnego...
1768       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1769      &                   0.0d0,1.0d0,0.0d0,
1770      &                   0.0d0,0.0d0,1.0d0/
1771 cd      write(iout,*) 'In EELEC'
1772 cd      do i=1,nloctyp
1773 cd        write(iout,*) 'Type',i
1774 cd        write(iout,*) 'B1',B1(:,i)
1775 cd        write(iout,*) 'B2',B2(:,i)
1776 cd        write(iout,*) 'CC',CC(:,:,i)
1777 cd        write(iout,*) 'DD',DD(:,:,i)
1778 cd        write(iout,*) 'EE',EE(:,:,i)
1779 cd      enddo
1780 cd      call check_vecgrad
1781 cd      stop
1782       if (icheckgrad.eq.1) then
1783         do i=1,nres-1
1784           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1785           do k=1,3
1786             dc_norm(k,i)=dc(k,i)*fac
1787           enddo
1788 c          write (iout,*) 'i',i,' fac',fac
1789         enddo
1790       endif
1791       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1792      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1793      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1794 cd      if (wel_loc.gt.0.0d0) then
1795         if (icheckgrad.eq.1) then
1796         call vec_and_deriv_test
1797         else
1798         call vec_and_deriv
1799         endif
1800         call set_matrices
1801       endif
1802 cd      do i=1,nres-1
1803 cd        write (iout,*) 'i=',i
1804 cd        do k=1,3
1805 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1806 cd        enddo
1807 cd        do k=1,3
1808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1810 cd        enddo
1811 cd      enddo
1812       num_conti_hb=0
1813       ees=0.0D0
1814       evdw1=0.0D0
1815       eel_loc=0.0d0
1816       eello_turn3=0.0d0
1817       eello_turn4=0.0d0
1818       ind=0
1819       do i=1,nres
1820         num_cont_hb(i)=0
1821       enddo
1822 cd      print '(a)','Enter EELEC'
1823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1824       do i=1,nres
1825         gel_loc_loc(i)=0.0d0
1826         gcorr_loc(i)=0.0d0
1827       enddo
1828       do i=iatel_s,iatel_e
1829         if (itel(i).eq.0) goto 1215
1830         dxi=dc(1,i)
1831         dyi=dc(2,i)
1832         dzi=dc(3,i)
1833         dx_normi=dc_norm(1,i)
1834         dy_normi=dc_norm(2,i)
1835         dz_normi=dc_norm(3,i)
1836         xmedi=c(1,i)+0.5d0*dxi
1837         ymedi=c(2,i)+0.5d0*dyi
1838         zmedi=c(3,i)+0.5d0*dzi
1839         num_conti=0
1840 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1841         do j=ielstart(i),ielend(i)
1842           if (itel(j).eq.0) goto 1216
1843           ind=ind+1
1844           iteli=itel(i)
1845           itelj=itel(j)
1846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1847           aaa=app(iteli,itelj)
1848           bbb=bpp(iteli,itelj)
1849 C Diagnostics only!!!
1850 c         aaa=0.0D0
1851 c         bbb=0.0D0
1852 c         ael6i=0.0D0
1853 c         ael3i=0.0D0
1854 C End diagnostics
1855           ael6i=ael6(iteli,itelj)
1856           ael3i=ael3(iteli,itelj)
1857           dxj=dc(1,j)
1858           dyj=dc(2,j)
1859           dzj=dc(3,j)
1860           dx_normj=dc_norm(1,j)
1861           dy_normj=dc_norm(2,j)
1862           dz_normj=dc_norm(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           rrmij=1.0D0/rij
1868           rij=dsqrt(rij)
1869           rmij=1.0D0/rij
1870           r3ij=rrmij*rmij
1871           r6ij=r3ij*r3ij
1872           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1873           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1874           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1875           fac=cosa-3.0D0*cosb*cosg
1876           ev1=aaa*r6ij*r6ij
1877 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1878           if (j.eq.i+2) ev1=scal_el*ev1
1879           ev2=bbb*r6ij
1880           fac3=ael6i*r6ij
1881           fac4=ael3i*r3ij
1882           evdwij=ev1+ev2
1883           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1884           el2=fac4*fac
1885           eesij=el1+el2
1886 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1887 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1888           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1889           ees=ees+eesij
1890           evdw1=evdw1+evdwij
1891 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1892 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1893 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1894 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1895 C
1896 C Calculate contributions to the Cartesian gradient.
1897 C
1898 #ifdef SPLITELE
1899           facvdw=-6*rrmij*(ev1+evdwij)
1900           facel=-3*rrmij*(el1+eesij)
1901           fac1=fac
1902           erij(1)=xj*rmij
1903           erij(2)=yj*rmij
1904           erij(3)=zj*rmij
1905           if (calc_grad) then
1906 *
1907 * Radial derivatives. First process both termini of the fragment (i,j)
1908 *
1909           ggg(1)=facel*xj
1910           ggg(2)=facel*yj
1911           ggg(3)=facel*zj
1912           do k=1,3
1913             ghalf=0.5D0*ggg(k)
1914             gelc(k,i)=gelc(k,i)+ghalf
1915             gelc(k,j)=gelc(k,j)+ghalf
1916           enddo
1917 *
1918 * Loop over residues i+1 thru j-1.
1919 *
1920           do k=i+1,j-1
1921             do l=1,3
1922               gelc(l,k)=gelc(l,k)+ggg(l)
1923             enddo
1924           enddo
1925           ggg(1)=facvdw*xj
1926           ggg(2)=facvdw*yj
1927           ggg(3)=facvdw*zj
1928           do k=1,3
1929             ghalf=0.5D0*ggg(k)
1930             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1931             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1932           enddo
1933 *
1934 * Loop over residues i+1 thru j-1.
1935 *
1936           do k=i+1,j-1
1937             do l=1,3
1938               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1939             enddo
1940           enddo
1941 #else
1942           facvdw=ev1+evdwij
1943           facel=el1+eesij
1944           fac1=fac
1945           fac=-3*rrmij*(facvdw+facvdw+facel)
1946           erij(1)=xj*rmij
1947           erij(2)=yj*rmij
1948           erij(3)=zj*rmij
1949           if (calc_grad) then
1950 *
1951 * Radial derivatives. First process both termini of the fragment (i,j)
1952 *
1953           ggg(1)=fac*xj
1954           ggg(2)=fac*yj
1955           ggg(3)=fac*zj
1956           do k=1,3
1957             ghalf=0.5D0*ggg(k)
1958             gelc(k,i)=gelc(k,i)+ghalf
1959             gelc(k,j)=gelc(k,j)+ghalf
1960           enddo
1961 *
1962 * Loop over residues i+1 thru j-1.
1963 *
1964           do k=i+1,j-1
1965             do l=1,3
1966               gelc(l,k)=gelc(l,k)+ggg(l)
1967             enddo
1968           enddo
1969 #endif
1970 *
1971 * Angular part
1972 *
1973           ecosa=2.0D0*fac3*fac1+fac4
1974           fac4=-3.0D0*fac4
1975           fac3=-6.0D0*fac3
1976           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1977           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1978           do k=1,3
1979             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1980             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1981           enddo
1982 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1983 cd   &          (dcosg(k),k=1,3)
1984           do k=1,3
1985             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1986           enddo
1987           do k=1,3
1988             ghalf=0.5D0*ggg(k)
1989             gelc(k,i)=gelc(k,i)+ghalf
1990      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1991      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1992             gelc(k,j)=gelc(k,j)+ghalf
1993      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1994      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1995           enddo
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           endif
2002
2003           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2004      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2005      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2006 C
2007 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2008 C   energy of a peptide unit is assumed in the form of a second-order
2009 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2010 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2011 C   are computed for EVERY pair of non-contiguous peptide groups.
2012 C
2013           if (j.lt.nres-1) then
2014             j1=j+1
2015             j2=j-1
2016           else
2017             j1=j-1
2018             j2=j-2
2019           endif
2020           kkk=0
2021           do k=1,2
2022             do l=1,2
2023               kkk=kkk+1
2024               muij(kkk)=mu(k,i)*mu(l,j)
2025             enddo
2026           enddo
2027 cd         write (iout,*) 'EELEC: i',i,' j',j
2028 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2029 cd          write(iout,*) 'muij',muij
2030           ury=scalar(uy(1,i),erij)
2031           urz=scalar(uz(1,i),erij)
2032           vry=scalar(uy(1,j),erij)
2033           vrz=scalar(uz(1,j),erij)
2034           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2035           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2036           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2037           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2038 C For diagnostics only
2039 cd          a22=1.0d0
2040 cd          a23=1.0d0
2041 cd          a32=1.0d0
2042 cd          a33=1.0d0
2043           fac=dsqrt(-ael6i)*r3ij
2044 cd          write (2,*) 'fac=',fac
2045 C For diagnostics only
2046 cd          fac=1.0d0
2047           a22=a22*fac
2048           a23=a23*fac
2049           a32=a32*fac
2050           a33=a33*fac
2051 cd          write (iout,'(4i5,4f10.5)')
2052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2055 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2056 cd          write (iout,'(4f10.5)')
2057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2060 cd           write (iout,'(2i3,9f10.5/)') i,j,
2061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2062           if (calc_grad) then
2063 C Derivatives of the elements of A in virtual-bond vectors
2064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2065 cd          do k=1,3
2066 cd            do l=1,3
2067 cd              erder(k,l)=0.0d0
2068 cd            enddo
2069 cd          enddo
2070           do k=1,3
2071             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2072             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2073             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2074             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2075             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2076             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2077             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2078             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2079             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2080             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2081             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2082             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2083           enddo
2084 cd          do k=1,3
2085 cd            do l=1,3
2086 cd              uryg(k,l)=0.0d0
2087 cd              urzg(k,l)=0.0d0
2088 cd              vryg(k,l)=0.0d0
2089 cd              vrzg(k,l)=0.0d0
2090 cd            enddo
2091 cd          enddo
2092 C Compute radial contributions to the gradient
2093           facr=-3.0d0*rrmij
2094           a22der=a22*facr
2095           a23der=a23*facr
2096           a32der=a32*facr
2097           a33der=a33*facr
2098 cd          a22der=0.0d0
2099 cd          a23der=0.0d0
2100 cd          a32der=0.0d0
2101 cd          a33der=0.0d0
2102           agg(1,1)=a22der*xj
2103           agg(2,1)=a22der*yj
2104           agg(3,1)=a22der*zj
2105           agg(1,2)=a23der*xj
2106           agg(2,2)=a23der*yj
2107           agg(3,2)=a23der*zj
2108           agg(1,3)=a32der*xj
2109           agg(2,3)=a32der*yj
2110           agg(3,3)=a32der*zj
2111           agg(1,4)=a33der*xj
2112           agg(2,4)=a33der*yj
2113           agg(3,4)=a33der*zj
2114 C Add the contributions coming from er
2115           fac3=-3.0d0*fac
2116           do k=1,3
2117             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2118             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2119             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2120             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2121           enddo
2122           do k=1,3
2123 C Derivatives in DC(i)
2124             ghalf1=0.5d0*agg(k,1)
2125             ghalf2=0.5d0*agg(k,2)
2126             ghalf3=0.5d0*agg(k,3)
2127             ghalf4=0.5d0*agg(k,4)
2128             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2129      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2130             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2131      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2132             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2133      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2134             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2135      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2136 C Derivatives in DC(i+1)
2137             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2138      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2139             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2140      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2141             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2142      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2143             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2144      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2145 C Derivatives in DC(j)
2146             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2147      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2148             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2149      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2150             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2151      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2152             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2153      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2154 C Derivatives in DC(j+1) or DC(nres-1)
2155             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2156      &      -3.0d0*vryg(k,3)*ury)
2157             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2158      &      -3.0d0*vrzg(k,3)*ury)
2159             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2160      &      -3.0d0*vryg(k,3)*urz)
2161             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2162      &      -3.0d0*vrzg(k,3)*urz)
2163 cd            aggi(k,1)=ghalf1
2164 cd            aggi(k,2)=ghalf2
2165 cd            aggi(k,3)=ghalf3
2166 cd            aggi(k,4)=ghalf4
2167 C Derivatives in DC(i+1)
2168 cd            aggi1(k,1)=agg(k,1)
2169 cd            aggi1(k,2)=agg(k,2)
2170 cd            aggi1(k,3)=agg(k,3)
2171 cd            aggi1(k,4)=agg(k,4)
2172 C Derivatives in DC(j)
2173 cd            aggj(k,1)=ghalf1
2174 cd            aggj(k,2)=ghalf2
2175 cd            aggj(k,3)=ghalf3
2176 cd            aggj(k,4)=ghalf4
2177 C Derivatives in DC(j+1)
2178 cd            aggj1(k,1)=0.0d0
2179 cd            aggj1(k,2)=0.0d0
2180 cd            aggj1(k,3)=0.0d0
2181 cd            aggj1(k,4)=0.0d0
2182             if (j.eq.nres-1 .and. i.lt.j-2) then
2183               do l=1,4
2184                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2185 cd                aggj1(k,l)=agg(k,l)
2186               enddo
2187             endif
2188           enddo
2189           endif
2190 c          goto 11111
2191 C Check the loc-el terms by numerical integration
2192           acipa(1,1)=a22
2193           acipa(1,2)=a23
2194           acipa(2,1)=a32
2195           acipa(2,2)=a33
2196           a22=-a22
2197           a23=-a23
2198           do l=1,2
2199             do k=1,3
2200               agg(k,l)=-agg(k,l)
2201               aggi(k,l)=-aggi(k,l)
2202               aggi1(k,l)=-aggi1(k,l)
2203               aggj(k,l)=-aggj(k,l)
2204               aggj1(k,l)=-aggj1(k,l)
2205             enddo
2206           enddo
2207           if (j.lt.nres-1) then
2208             a22=-a22
2209             a32=-a32
2210             do l=1,3,2
2211               do k=1,3
2212                 agg(k,l)=-agg(k,l)
2213                 aggi(k,l)=-aggi(k,l)
2214                 aggi1(k,l)=-aggi1(k,l)
2215                 aggj(k,l)=-aggj(k,l)
2216                 aggj1(k,l)=-aggj1(k,l)
2217               enddo
2218             enddo
2219           else
2220             a22=-a22
2221             a23=-a23
2222             a32=-a32
2223             a33=-a33
2224             do l=1,4
2225               do k=1,3
2226                 agg(k,l)=-agg(k,l)
2227                 aggi(k,l)=-aggi(k,l)
2228                 aggi1(k,l)=-aggi1(k,l)
2229                 aggj(k,l)=-aggj(k,l)
2230                 aggj1(k,l)=-aggj1(k,l)
2231               enddo
2232             enddo
2233           endif
2234           ENDIF ! WCORR
2235 11111     continue
2236           IF (wel_loc.gt.0.0d0) THEN
2237 C Contribution to the local-electrostatic energy coming from the i-j pair
2238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2239      &     +a33*muij(4)
2240 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2241 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2242           eel_loc=eel_loc+eel_loc_ij
2243 C Partial derivatives in virtual-bond dihedral angles gamma
2244           if (calc_grad) then
2245           if (i.gt.1)
2246      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2247      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2248      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2249           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2250      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2251      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2252 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2253 cd          write(iout,*) 'agg  ',agg
2254 cd          write(iout,*) 'aggi ',aggi
2255 cd          write(iout,*) 'aggi1',aggi1
2256 cd          write(iout,*) 'aggj ',aggj
2257 cd          write(iout,*) 'aggj1',aggj1
2258
2259 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2260           do l=1,3
2261             ggg(l)=agg(l,1)*muij(1)+
2262      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2263           enddo
2264           do k=i+2,j2
2265             do l=1,3
2266               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2267             enddo
2268           enddo
2269 C Remaining derivatives of eello
2270           do l=1,3
2271             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2272      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2273             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2274      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2275             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2276      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2277             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2278      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2279           enddo
2280           endif
2281           ENDIF
2282           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2283 C Contributions from turns
2284             a_temp(1,1)=a22
2285             a_temp(1,2)=a23
2286             a_temp(2,1)=a32
2287             a_temp(2,2)=a33
2288             call eturn34(i,j,eello_turn3,eello_turn4)
2289           endif
2290 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2291           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2292 C
2293 C Calculate the contact function. The ith column of the array JCONT will
2294 C contain the numbers of atoms that make contacts with the atom I (of numbers
2295 C greater than I). The arrays FACONT and GACONT will contain the values of
2296 C the contact function and its derivative.
2297 c           r0ij=1.02D0*rpp(iteli,itelj)
2298 c           r0ij=1.11D0*rpp(iteli,itelj)
2299             r0ij=2.20D0*rpp(iteli,itelj)
2300 c           r0ij=1.55D0*rpp(iteli,itelj)
2301             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2302             if (fcont.gt.0.0D0) then
2303               num_conti=num_conti+1
2304               if (num_conti.gt.maxconts) then
2305                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2306      &                         ' will skip next contacts for this conf.'
2307               else
2308                 jcont_hb(num_conti,i)=j
2309                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2310      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2311 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2312 C  terms.
2313                 d_cont(num_conti,i)=rij
2314 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2315 C     --- Electrostatic-interaction matrix ---
2316                 a_chuj(1,1,num_conti,i)=a22
2317                 a_chuj(1,2,num_conti,i)=a23
2318                 a_chuj(2,1,num_conti,i)=a32
2319                 a_chuj(2,2,num_conti,i)=a33
2320 C     --- Gradient of rij
2321                 do kkk=1,3
2322                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2323                 enddo
2324 c             if (i.eq.1) then
2325 c                a_chuj(1,1,num_conti,i)=-0.61d0
2326 c                a_chuj(1,2,num_conti,i)= 0.4d0
2327 c                a_chuj(2,1,num_conti,i)= 0.65d0
2328 c                a_chuj(2,2,num_conti,i)= 0.50d0
2329 c             else if (i.eq.2) then
2330 c                a_chuj(1,1,num_conti,i)= 0.0d0
2331 c                a_chuj(1,2,num_conti,i)= 0.0d0
2332 c                a_chuj(2,1,num_conti,i)= 0.0d0
2333 c                a_chuj(2,2,num_conti,i)= 0.0d0
2334 c             endif
2335 C     --- and its gradients
2336 cd                write (iout,*) 'i',i,' j',j
2337 cd                do kkk=1,3
2338 cd                write (iout,*) 'iii 1 kkk',kkk
2339 cd                write (iout,*) agg(kkk,:)
2340 cd                enddo
2341 cd                do kkk=1,3
2342 cd                write (iout,*) 'iii 2 kkk',kkk
2343 cd                write (iout,*) aggi(kkk,:)
2344 cd                enddo
2345 cd                do kkk=1,3
2346 cd                write (iout,*) 'iii 3 kkk',kkk
2347 cd                write (iout,*) aggi1(kkk,:)
2348 cd                enddo
2349 cd                do kkk=1,3
2350 cd                write (iout,*) 'iii 4 kkk',kkk
2351 cd                write (iout,*) aggj(kkk,:)
2352 cd                enddo
2353 cd                do kkk=1,3
2354 cd                write (iout,*) 'iii 5 kkk',kkk
2355 cd                write (iout,*) aggj1(kkk,:)
2356 cd                enddo
2357                 kkll=0
2358                 do k=1,2
2359                   do l=1,2
2360                     kkll=kkll+1
2361                     do m=1,3
2362                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2363                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2364                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2365                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2366                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2367 c                      do mm=1,5
2368 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2369 c                      enddo
2370                     enddo
2371                   enddo
2372                 enddo
2373                 ENDIF
2374                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2375 C Calculate contact energies
2376                 cosa4=4.0D0*cosa
2377                 wij=cosa-3.0D0*cosb*cosg
2378                 cosbg1=cosb+cosg
2379                 cosbg2=cosb-cosg
2380 c               fac3=dsqrt(-ael6i)/r0ij**3
2381                 fac3=dsqrt(-ael6i)*r3ij
2382                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2383                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2384 c               ees0mij=0.0D0
2385                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2386                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2387 C Diagnostics. Comment out or remove after debugging!
2388 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2389 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2390 c               ees0m(num_conti,i)=0.0D0
2391 C End diagnostics.
2392 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2393 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2394                 facont_hb(num_conti,i)=fcont
2395                 if (calc_grad) then
2396 C Angular derivatives of the contact function
2397                 ees0pij1=fac3/ees0pij
2398                 ees0mij1=fac3/ees0mij
2399                 fac3p=-3.0D0*fac3*rrmij
2400                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2401                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2402 c               ees0mij1=0.0D0
2403                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2404                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2405                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2406                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2407                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2408                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2409                 ecosap=ecosa1+ecosa2
2410                 ecosbp=ecosb1+ecosb2
2411                 ecosgp=ecosg1+ecosg2
2412                 ecosam=ecosa1-ecosa2
2413                 ecosbm=ecosb1-ecosb2
2414                 ecosgm=ecosg1-ecosg2
2415 C Diagnostics
2416 c               ecosap=ecosa1
2417 c               ecosbp=ecosb1
2418 c               ecosgp=ecosg1
2419 c               ecosam=0.0D0
2420 c               ecosbm=0.0D0
2421 c               ecosgm=0.0D0
2422 C End diagnostics
2423                 fprimcont=fprimcont/rij
2424 cd              facont_hb(num_conti,i)=1.0D0
2425 C Following line is for diagnostics.
2426 cd              fprimcont=0.0D0
2427                 do k=1,3
2428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2430                 enddo
2431                 do k=1,3
2432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2434                 enddo
2435                 gggp(1)=gggp(1)+ees0pijp*xj
2436                 gggp(2)=gggp(2)+ees0pijp*yj
2437                 gggp(3)=gggp(3)+ees0pijp*zj
2438                 gggm(1)=gggm(1)+ees0mijp*xj
2439                 gggm(2)=gggm(2)+ees0mijp*yj
2440                 gggm(3)=gggm(3)+ees0mijp*zj
2441 C Derivatives due to the contact function
2442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2445                 do k=1,3
2446                   ghalfp=0.5D0*gggp(k)
2447                   ghalfm=0.5D0*gggm(k)
2448                   gacontp_hb1(k,num_conti,i)=ghalfp
2449      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2450      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2451                   gacontp_hb2(k,num_conti,i)=ghalfp
2452      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2453      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2454                   gacontp_hb3(k,num_conti,i)=gggp(k)
2455                   gacontm_hb1(k,num_conti,i)=ghalfm
2456      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2457      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2458                   gacontm_hb2(k,num_conti,i)=ghalfm
2459      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2460      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2461                   gacontm_hb3(k,num_conti,i)=gggm(k)
2462                 enddo
2463                 endif
2464 C Diagnostics. Comment out or remove after debugging!
2465 cdiag           do k=1,3
2466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2472 cdiag           enddo
2473               ENDIF ! wcorr
2474               endif  ! num_conti.le.maxconts
2475             endif  ! fcont.gt.0
2476           endif    ! j.gt.i+1
2477  1216     continue
2478         enddo ! j
2479         num_cont_hb(i)=num_conti
2480  1215   continue
2481       enddo   ! i
2482 cd      do i=1,nres
2483 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2484 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2485 cd      enddo
2486 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2487 ccc      eel_loc=eel_loc+eello_turn3
2488       return
2489       end
2490 C-----------------------------------------------------------------------------
2491       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2492 C Third- and fourth-order contributions from turns
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'sizesclu.dat'
2496       include 'COMMON.IOUNITS'
2497       include 'COMMON.GEO'
2498       include 'COMMON.VAR'
2499       include 'COMMON.LOCAL'
2500       include 'COMMON.CHAIN'
2501       include 'COMMON.DERIV'
2502       include 'COMMON.INTERACT'
2503       include 'COMMON.CONTACTS'
2504       include 'COMMON.TORSION'
2505       include 'COMMON.VECTORS'
2506       include 'COMMON.FFIELD'
2507       dimension ggg(3)
2508       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2509      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2510      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2511       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2512      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2514       if (j.eq.i+2) then
2515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2516 C
2517 C               Third-order contributions
2518 C
2519 C                 (i+2)o----(i+3)
2520 C                      | |
2521 C                      | |
2522 C                 (i+1)o----i
2523 C
2524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2525 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2526         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2527         call transpose2(auxmat(1,1),auxmat1(1,1))
2528         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2529         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2530 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2531 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2532 cd     &    ' eello_turn3_num',4*eello_turn3_num
2533         if (calc_grad) then
2534 C Derivatives in gamma(i)
2535         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2536         call transpose2(auxmat2(1,1),pizda(1,1))
2537         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2538         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2539 C Derivatives in gamma(i+1)
2540         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2541         call transpose2(auxmat2(1,1),pizda(1,1))
2542         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2543         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2544      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2545 C Cartesian derivatives
2546         do l=1,3
2547           a_temp(1,1)=aggi(l,1)
2548           a_temp(1,2)=aggi(l,2)
2549           a_temp(2,1)=aggi(l,3)
2550           a_temp(2,2)=aggi(l,4)
2551           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2552           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2553      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2554           a_temp(1,1)=aggi1(l,1)
2555           a_temp(1,2)=aggi1(l,2)
2556           a_temp(2,1)=aggi1(l,3)
2557           a_temp(2,2)=aggi1(l,4)
2558           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2559           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2560      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2561           a_temp(1,1)=aggj(l,1)
2562           a_temp(1,2)=aggj(l,2)
2563           a_temp(2,1)=aggj(l,3)
2564           a_temp(2,2)=aggj(l,4)
2565           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2566           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2567      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2568           a_temp(1,1)=aggj1(l,1)
2569           a_temp(1,2)=aggj1(l,2)
2570           a_temp(2,1)=aggj1(l,3)
2571           a_temp(2,2)=aggj1(l,4)
2572           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2573           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2574      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2575         enddo
2576         endif
2577       else if (j.eq.i+3) then
2578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2579 C
2580 C               Fourth-order contributions
2581 C
2582 C                 (i+3)o----(i+4)
2583 C                     /  |
2584 C               (i+2)o   |
2585 C                     \  |
2586 C                 (i+1)o----i
2587 C
2588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2589 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2590         iti1=itortyp(itype(i+1))
2591         iti2=itortyp(itype(i+2))
2592         iti3=itortyp(itype(i+3))
2593         call transpose2(EUg(1,1,i+1),e1t(1,1))
2594         call transpose2(Eug(1,1,i+2),e2t(1,1))
2595         call transpose2(Eug(1,1,i+3),e3t(1,1))
2596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2597         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2598         s1=scalar2(b1(1,iti2),auxvec(1))
2599         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2601         s2=scalar2(b1(1,iti1),auxvec(1))
2602         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2603         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2604         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2605         eello_turn4=eello_turn4-(s1+s2+s3)
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2607 cd     &    ' eello_turn4_num',8*eello_turn4_num
2608 C Derivatives in gamma(i)
2609         if (calc_grad) then
2610         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2611         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2613         s1=scalar2(b1(1,iti2),auxvec(1))
2614         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2615         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2617 C Derivatives in gamma(i+1)
2618         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2619         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2620         s2=scalar2(b1(1,iti1),auxvec(1))
2621         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2622         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2623         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2624         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2625 C Derivatives in gamma(i+2)
2626         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2627         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2628         s1=scalar2(b1(1,iti2),auxvec(1))
2629         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2631         s2=scalar2(b1(1,iti1),auxvec(1))
2632         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2633         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2634         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2636 C Cartesian derivatives
2637 C Derivatives of this turn contributions in DC(i+2)
2638         if (j.lt.nres-1) then
2639           do l=1,3
2640             a_temp(1,1)=agg(l,1)
2641             a_temp(1,2)=agg(l,2)
2642             a_temp(2,1)=agg(l,3)
2643             a_temp(2,2)=agg(l,4)
2644             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2645             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2646             s1=scalar2(b1(1,iti2),auxvec(1))
2647             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2648             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2649             s2=scalar2(b1(1,iti1),auxvec(1))
2650             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2651             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2652             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653             ggg(l)=-(s1+s2+s3)
2654             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2655           enddo
2656         endif
2657 C Remaining derivatives of this turn contribution
2658         do l=1,3
2659           a_temp(1,1)=aggi(l,1)
2660           a_temp(1,2)=aggi(l,2)
2661           a_temp(2,1)=aggi(l,3)
2662           a_temp(2,2)=aggi(l,4)
2663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2665           s1=scalar2(b1(1,iti2),auxvec(1))
2666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2668           s2=scalar2(b1(1,iti1),auxvec(1))
2669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2672           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2673           a_temp(1,1)=aggi1(l,1)
2674           a_temp(1,2)=aggi1(l,2)
2675           a_temp(2,1)=aggi1(l,3)
2676           a_temp(2,2)=aggi1(l,4)
2677           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2678           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2679           s1=scalar2(b1(1,iti2),auxvec(1))
2680           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2681           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2682           s2=scalar2(b1(1,iti1),auxvec(1))
2683           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2684           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2685           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2686           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2687           a_temp(1,1)=aggj(l,1)
2688           a_temp(1,2)=aggj(l,2)
2689           a_temp(2,1)=aggj(l,3)
2690           a_temp(2,2)=aggj(l,4)
2691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2693           s1=scalar2(b1(1,iti2),auxvec(1))
2694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2696           s2=scalar2(b1(1,iti1),auxvec(1))
2697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2701           a_temp(1,1)=aggj1(l,1)
2702           a_temp(1,2)=aggj1(l,2)
2703           a_temp(2,1)=aggj1(l,3)
2704           a_temp(2,2)=aggj1(l,4)
2705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2707           s1=scalar2(b1(1,iti2),auxvec(1))
2708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2710           s2=scalar2(b1(1,iti1),auxvec(1))
2711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2714           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2715         enddo
2716         endif
2717       endif
2718       return
2719       end
2720 C-----------------------------------------------------------------------------
2721       subroutine vecpr(u,v,w)
2722       implicit real*8(a-h,o-z)
2723       dimension u(3),v(3),w(3)
2724       w(1)=u(2)*v(3)-u(3)*v(2)
2725       w(2)=-u(1)*v(3)+u(3)*v(1)
2726       w(3)=u(1)*v(2)-u(2)*v(1)
2727       return
2728       end
2729 C-----------------------------------------------------------------------------
2730       subroutine unormderiv(u,ugrad,unorm,ungrad)
2731 C This subroutine computes the derivatives of a normalized vector u, given
2732 C the derivatives computed without normalization conditions, ugrad. Returns
2733 C ungrad.
2734       implicit none
2735       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2736       double precision vec(3)
2737       double precision scalar
2738       integer i,j
2739 c      write (2,*) 'ugrad',ugrad
2740 c      write (2,*) 'u',u
2741       do i=1,3
2742         vec(i)=scalar(ugrad(1,i),u(1))
2743       enddo
2744 c      write (2,*) 'vec',vec
2745       do i=1,3
2746         do j=1,3
2747           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2748         enddo
2749       enddo
2750 c      write (2,*) 'ungrad',ungrad
2751       return
2752       end
2753 C-----------------------------------------------------------------------------
2754       subroutine escp(evdw2,evdw2_14)
2755 C
2756 C This subroutine calculates the excluded-volume interaction energy between
2757 C peptide-group centers and side chains and its gradient in virtual-bond and
2758 C side-chain vectors.
2759 C
2760       implicit real*8 (a-h,o-z)
2761       include 'DIMENSIONS'
2762       include 'sizesclu.dat'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.FFIELD'
2770       include 'COMMON.IOUNITS'
2771       dimension ggg(3)
2772       evdw2=0.0D0
2773       evdw2_14=0.0d0
2774 cd    print '(a)','Enter ESCP'
2775 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2776 c     &  ' scal14',scal14
2777       do i=iatscp_s,iatscp_e
2778         iteli=itel(i)
2779 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2780 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2781         if (iteli.eq.0) goto 1225
2782         xi=0.5D0*(c(1,i)+c(1,i+1))
2783         yi=0.5D0*(c(2,i)+c(2,i+1))
2784         zi=0.5D0*(c(3,i)+c(3,i+1))
2785
2786         do iint=1,nscp_gr(i)
2787
2788         do j=iscpstart(i,iint),iscpend(i,iint)
2789           itypj=itype(j)
2790 C Uncomment following three lines for SC-p interactions
2791 c         xj=c(1,nres+j)-xi
2792 c         yj=c(2,nres+j)-yi
2793 c         zj=c(3,nres+j)-zi
2794 C Uncomment following three lines for Ca-p interactions
2795           xj=c(1,j)-xi
2796           yj=c(2,j)-yi
2797           zj=c(3,j)-zi
2798           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2799           fac=rrij**expon2
2800           e1=fac*fac*aad(itypj,iteli)
2801           e2=fac*bad(itypj,iteli)
2802           if (iabs(j-i) .le. 2) then
2803             e1=scal14*e1
2804             e2=scal14*e2
2805             evdw2_14=evdw2_14+e1+e2
2806           endif
2807           evdwij=e1+e2
2808 c          write (iout,*) i,j,evdwij
2809           evdw2=evdw2+evdwij
2810           if (calc_grad) then
2811 C
2812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2813 C
2814           fac=-(evdwij+e1)*rrij
2815           ggg(1)=xj*fac
2816           ggg(2)=yj*fac
2817           ggg(3)=zj*fac
2818           if (j.lt.i) then
2819 cd          write (iout,*) 'j<i'
2820 C Uncomment following three lines for SC-p interactions
2821 c           do k=1,3
2822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2823 c           enddo
2824           else
2825 cd          write (iout,*) 'j>i'
2826             do k=1,3
2827               ggg(k)=-ggg(k)
2828 C Uncomment following line for SC-p interactions
2829 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2830             enddo
2831           endif
2832           do k=1,3
2833             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2834           enddo
2835           kstart=min0(i+1,j)
2836           kend=max0(i-1,j-1)
2837 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2838 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2839           do k=kstart,kend
2840             do l=1,3
2841               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2842             enddo
2843           enddo
2844           endif
2845         enddo
2846         enddo ! iint
2847  1225   continue
2848       enddo ! i
2849       do i=1,nct
2850         do j=1,3
2851           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2852           gradx_scp(j,i)=expon*gradx_scp(j,i)
2853         enddo
2854       enddo
2855 C******************************************************************************
2856 C
2857 C                              N O T E !!!
2858 C
2859 C To save time the factor EXPON has been extracted from ALL components
2860 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2861 C use!
2862 C
2863 C******************************************************************************
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine edis(ehpb)
2868 C
2869 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2870 C
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873       include 'COMMON.SBRIDGE'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.VAR'
2877       include 'COMMON.INTERACT'
2878       include 'COMMON.IOUNITS'
2879       dimension ggg(3)
2880       ehpb=0.0D0
2881 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2882 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2883       if (link_end.eq.0) return
2884       do i=link_start,link_end
2885 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2886 C CA-CA distance used in regularization of structure.
2887         ii=ihpb(i)
2888         jj=jhpb(i)
2889 C iii and jjj point to the residues for which the distance is assigned.
2890         if (ii.gt.nres) then
2891           iii=ii-nres
2892           jjj=jj-nres
2893         else
2894           iii=ii
2895           jjj=jj
2896         endif
2897 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2898 c     &    dhpb(i),dhpb1(i),forcon(i)
2899 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2900 C    distance and angle dependent SS bond potential.
2901         if (.not.dyn_ss .and. i.le.nss) then
2902 C 15/02/13 CC dynamic SSbond - additional check
2903         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2904           call ssbond_ene(iii,jjj,eij)
2905           ehpb=ehpb+2*eij
2906 cd          write (iout,*) "eij",eij
2907         endif
2908         else if (ii.gt.nres .and. jj.gt.nres) then
2909 c Restraints from contact prediction
2910           dd=dist(ii,jj)
2911           if (dhpb1(i).gt.0.0d0) then
2912             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2913             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2914 c            write (iout,*) "beta nmr",
2915 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2916           else
2917             dd=dist(ii,jj)
2918             rdis=dd-dhpb(i)
2919 C Get the force constant corresponding to this distance.
2920             waga=forcon(i)
2921 C Calculate the contribution to energy.
2922             ehpb=ehpb+waga*rdis*rdis
2923 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2924 C
2925 C Evaluate gradient.
2926 C
2927             fac=waga*rdis/dd
2928           endif
2929           do j=1,3
2930             ggg(j)=fac*(c(j,jj)-c(j,ii))
2931           enddo
2932           do j=1,3
2933             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2934             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2935           enddo
2936           do k=1,3
2937             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2938             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2939           enddo
2940         else
2941 C Calculate the distance between the two points and its difference from the
2942 C target distance.
2943           dd=dist(ii,jj)
2944           if (dhpb1(i).gt.0.0d0) then
2945             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2946             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2947 c            write (iout,*) "alph nmr",
2948 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2949           else
2950             rdis=dd-dhpb(i)
2951 C Get the force constant corresponding to this distance.
2952             waga=forcon(i)
2953 C Calculate the contribution to energy.
2954             ehpb=ehpb+waga*rdis*rdis
2955 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2956 C
2957 C Evaluate gradient.
2958 C
2959             fac=waga*rdis/dd
2960           endif
2961 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2962 cd   &   ' waga=',waga,' fac=',fac
2963             do j=1,3
2964               ggg(j)=fac*(c(j,jj)-c(j,ii))
2965             enddo
2966 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2967 C If this is a SC-SC distance, we need to calculate the contributions to the
2968 C Cartesian gradient in the SC vectors (ghpbx).
2969           if (iii.lt.ii) then
2970           do j=1,3
2971             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2972             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2973           enddo
2974           endif
2975           do k=1,3
2976             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2977             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2978           enddo
2979         endif
2980       enddo
2981       ehpb=0.5D0*ehpb
2982       return
2983       end
2984 C--------------------------------------------------------------------------
2985       subroutine ssbond_ene(i,j,eij)
2986 C
2987 C Calculate the distance and angle dependent SS-bond potential energy
2988 C using a free-energy function derived based on RHF/6-31G** ab initio
2989 C calculations of diethyl disulfide.
2990 C
2991 C A. Liwo and U. Kozlowska, 11/24/03
2992 C
2993       implicit real*8 (a-h,o-z)
2994       include 'DIMENSIONS'
2995       include 'sizesclu.dat'
2996       include 'COMMON.SBRIDGE'
2997       include 'COMMON.CHAIN'
2998       include 'COMMON.DERIV'
2999       include 'COMMON.LOCAL'
3000       include 'COMMON.INTERACT'
3001       include 'COMMON.VAR'
3002       include 'COMMON.IOUNITS'
3003       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3004       itypi=itype(i)
3005       xi=c(1,nres+i)
3006       yi=c(2,nres+i)
3007       zi=c(3,nres+i)
3008       dxi=dc_norm(1,nres+i)
3009       dyi=dc_norm(2,nres+i)
3010       dzi=dc_norm(3,nres+i)
3011       dsci_inv=dsc_inv(itypi)
3012       itypj=itype(j)
3013       dscj_inv=dsc_inv(itypj)
3014       xj=c(1,nres+j)-xi
3015       yj=c(2,nres+j)-yi
3016       zj=c(3,nres+j)-zi
3017       dxj=dc_norm(1,nres+j)
3018       dyj=dc_norm(2,nres+j)
3019       dzj=dc_norm(3,nres+j)
3020       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3021       rij=dsqrt(rrij)
3022       erij(1)=xj*rij
3023       erij(2)=yj*rij
3024       erij(3)=zj*rij
3025       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3026       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3027       om12=dxi*dxj+dyi*dyj+dzi*dzj
3028       do k=1,3
3029         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3030         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3031       enddo
3032       rij=1.0d0/rij
3033       deltad=rij-d0cm
3034       deltat1=1.0d0-om1
3035       deltat2=1.0d0+om2
3036       deltat12=om2-om1+2.0d0
3037       cosphi=om12-om1*om2
3038       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3039      &  +akct*deltad*deltat12+ebr
3040      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3041 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3042 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3043 c     &  " deltat12",deltat12," eij",eij
3044       ed=2*akcm*deltad+akct*deltat12
3045       pom1=akct*deltad
3046       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3047       eom1=-2*akth*deltat1-pom1-om2*pom2
3048       eom2= 2*akth*deltat2+pom1-om1*pom2
3049       eom12=pom2
3050       do k=1,3
3051         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3052       enddo
3053       do k=1,3
3054         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3055      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3056         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3057      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3058       enddo
3059 C
3060 C Calculate the components of the gradient in DC and X
3061 C
3062       do k=i,j-1
3063         do l=1,3
3064           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3065         enddo
3066       enddo
3067       return
3068       end
3069
3070 C--------------------------------------------------------------------------
3071
3072
3073 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3074       subroutine e_modeller(ehomology_constr)
3075       implicit real*8 (a-h,o-z)
3076
3077       include 'DIMENSIONS'
3078
3079       integer nnn, i, j, k, ki, irec, l
3080       integer katy, odleglosci, test7
3081       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3082       real*8 distance(max_template),distancek(max_template),
3083      &    min_odl,godl(max_template),dih_diff(max_template)
3084
3085 c
3086 c     FP - 30/10/2014 Temporary specifications for homology restraints
3087 c
3088       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3089      &                 sgtheta
3090       double precision, dimension (maxres) :: guscdiff,usc_diff
3091       double precision, dimension (max_template) ::
3092      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3093      &           theta_diff
3094
3095       include 'COMMON.SBRIDGE'
3096       include 'COMMON.CHAIN'
3097       include 'COMMON.GEO'
3098       include 'COMMON.DERIV'
3099       include 'COMMON.LOCAL'
3100       include 'COMMON.INTERACT'
3101       include 'COMMON.VAR'
3102       include 'COMMON.IOUNITS'
3103       include 'COMMON.CONTROL'
3104       include 'COMMON.HOMRESTR'
3105 c
3106       include 'COMMON.SETUP'
3107       include 'COMMON.NAMES'
3108
3109       do i=1,max_template
3110         distancek(i)=9999999.9
3111       enddo
3112
3113       odleg=0.0d0
3114
3115 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3116 c function)
3117 C AL 5/2/14 - Introduce list of restraints
3118 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3119 #ifdef DEBUG
3120       write(iout,*) "------- dist restrs start -------"
3121       write (iout,*) "link_start_homo",link_start_homo,
3122      &    " link_end_homo",link_end_homo
3123 #endif
3124       do ii = link_start_homo,link_end_homo
3125          i = ires_homo(ii)
3126          j = jres_homo(ii)
3127          dij=dist(i,j)
3128 c        write (iout,*) "dij(",i,j,") =",dij
3129          do k=1,constr_homology
3130            if(.not.l_homo(k,ii)) cycle
3131            distance(k)=odl(k,ii)-dij
3132 c          write (iout,*) "distance(",k,") =",distance(k)
3133 c
3134 c          For Gaussian-type Urestr
3135 c
3136            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3137 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3138 c          write (iout,*) "distancek(",k,") =",distancek(k)
3139 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3140 c
3141 c          For Lorentzian-type Urestr
3142 c
3143            if (waga_dist.lt.0.0d0) then
3144               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3145               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3146      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3147            endif
3148          enddo
3149
3150 c         min_odl=minval(distancek)
3151          do kk=1,constr_homology
3152           if(l_homo(kk,ii)) then
3153             min_odl=distancek(kk)
3154             exit
3155           endif
3156          enddo
3157          do kk=1,constr_homology
3158           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3159      &              min_odl=distancek(kk)
3160          enddo
3161 c        write (iout,* )"min_odl",min_odl
3162 #ifdef DEBUG
3163          write (iout,*) "ij dij",i,j,dij
3164          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3165          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3166          write (iout,* )"min_odl",min_odl
3167 #endif
3168          odleg2=0.0d0
3169          do k=1,constr_homology
3170 c Nie wiem po co to liczycie jeszcze raz!
3171 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3172 c     &              (2*(sigma_odl(i,j,k))**2))
3173            if(.not.l_homo(k,ii)) cycle
3174            if (waga_dist.ge.0.0d0) then
3175 c
3176 c          For Gaussian-type Urestr
3177 c
3178             godl(k)=dexp(-distancek(k)+min_odl)
3179             odleg2=odleg2+godl(k)
3180 c
3181 c          For Lorentzian-type Urestr
3182 c
3183            else
3184             odleg2=odleg2+distancek(k)
3185            endif
3186
3187 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3188 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3189 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3190 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3191
3192          enddo
3193 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3194 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3195 #ifdef DEBUG
3196          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3197          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3198 #endif
3199            if (waga_dist.ge.0.0d0) then
3200 c
3201 c          For Gaussian-type Urestr
3202 c
3203               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3204 c
3205 c          For Lorentzian-type Urestr
3206 c
3207            else
3208               odleg=odleg+odleg2/constr_homology
3209            endif
3210 c
3211 #ifdef GRAD
3212 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3213 c Gradient
3214 c
3215 c          For Gaussian-type Urestr
3216 c
3217          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3218          sum_sgodl=0.0d0
3219          do k=1,constr_homology
3220 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3221 c     &           *waga_dist)+min_odl
3222 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3223 c
3224          if(.not.l_homo(k,ii)) cycle
3225          if (waga_dist.ge.0.0d0) then
3226 c          For Gaussian-type Urestr
3227 c
3228            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3229 c
3230 c          For Lorentzian-type Urestr
3231 c
3232          else
3233            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3234      &           sigma_odlir(k,ii)**2)**2)
3235          endif
3236            sum_sgodl=sum_sgodl+sgodl
3237
3238 c            sgodl2=sgodl2+sgodl
3239 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3240 c      write(iout,*) "constr_homology=",constr_homology
3241 c      write(iout,*) i, j, k, "TEST K"
3242          enddo
3243          if (waga_dist.ge.0.0d0) then
3244 c
3245 c          For Gaussian-type Urestr
3246 c
3247             grad_odl3=waga_homology(iset)*waga_dist
3248      &                *sum_sgodl/(sum_godl*dij)
3249 c
3250 c          For Lorentzian-type Urestr
3251 c
3252          else
3253 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3254 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3255             grad_odl3=-waga_homology(iset)*waga_dist*
3256      &                sum_sgodl/(constr_homology*dij)
3257          endif
3258 c
3259 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3260
3261
3262 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3263 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3264 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3265
3266 ccc      write(iout,*) godl, sgodl, grad_odl3
3267
3268 c          grad_odl=grad_odl+grad_odl3
3269
3270          do jik=1,3
3271             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3272 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3273 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3274 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3275             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3276             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3277 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3278 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3279 c         if (i.eq.25.and.j.eq.27) then
3280 c         write(iout,*) "jik",jik,"i",i,"j",j
3281 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3282 c         write(iout,*) "grad_odl3",grad_odl3
3283 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3284 c         write(iout,*) "ggodl",ggodl
3285 c         write(iout,*) "ghpbc(",jik,i,")",
3286 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3287 c     &                 ghpbc(jik,j)
3288 c         endif
3289          enddo
3290 #endif
3291 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3292 ccc     & dLOG(odleg2),"-odleg=", -odleg
3293
3294       enddo ! ii-loop for dist
3295 #ifdef DEBUG
3296       write(iout,*) "------- dist restrs end -------"
3297 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3298 c    &     waga_d.eq.1.0d0) call sum_gradient
3299 #endif
3300 c Pseudo-energy and gradient from dihedral-angle restraints from
3301 c homology templates
3302 c      write (iout,*) "End of distance loop"
3303 c      call flush(iout)
3304       kat=0.0d0
3305 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3306 #ifdef DEBUG
3307       write(iout,*) "------- dih restrs start -------"
3308       do i=idihconstr_start_homo,idihconstr_end_homo
3309         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3310       enddo
3311 #endif
3312       do i=idihconstr_start_homo,idihconstr_end_homo
3313         kat2=0.0d0
3314 c        betai=beta(i,i+1,i+2,i+3)
3315         betai = phi(i)
3316 c       write (iout,*) "betai =",betai
3317         do k=1,constr_homology
3318           dih_diff(k)=pinorm(dih(k,i)-betai)
3319 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3320 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3321 c     &                                   -(6.28318-dih_diff(i,k))
3322 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3323 c     &                                   6.28318+dih_diff(i,k)
3324
3325           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3326 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3327           gdih(k)=dexp(kat3)
3328           kat2=kat2+gdih(k)
3329 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3330 c          write(*,*)""
3331         enddo
3332 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3333 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3334 #ifdef DEBUG
3335         write (iout,*) "i",i," betai",betai," kat2",kat2
3336         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3337 #endif
3338         if (kat2.le.1.0d-14) cycle
3339         kat=kat-dLOG(kat2/constr_homology)
3340 c       write (iout,*) "kat",kat ! sum of -ln-s
3341
3342 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3343 ccc     & dLOG(kat2), "-kat=", -kat
3344
3345 #ifdef GRAD
3346 c ----------------------------------------------------------------------
3347 c Gradient
3348 c ----------------------------------------------------------------------
3349
3350         sum_gdih=kat2
3351         sum_sgdih=0.0d0
3352         do k=1,constr_homology
3353           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3354 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3355           sum_sgdih=sum_sgdih+sgdih
3356         enddo
3357 c       grad_dih3=sum_sgdih/sum_gdih
3358         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3359
3360 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3361 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3362 ccc     & gloc(nphi+i-3,icg)
3363         gloc(i,icg)=gloc(i,icg)+grad_dih3
3364 c        if (i.eq.25) then
3365 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3366 c        endif
3367 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3368 ccc     & gloc(nphi+i-3,icg)
3369 #endif
3370       enddo ! i-loop for dih
3371 #ifdef DEBUG
3372       write(iout,*) "------- dih restrs end -------"
3373 #endif
3374
3375 c Pseudo-energy and gradient for theta angle restraints from
3376 c homology templates
3377 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3378 c adapted
3379
3380 c
3381 c     For constr_homology reference structures (FP)
3382 c
3383 c     Uconst_back_tot=0.0d0
3384       Eval=0.0d0
3385       Erot=0.0d0
3386 c     Econstr_back legacy
3387 #ifdef GRAD
3388       do i=1,nres
3389 c     do i=ithet_start,ithet_end
3390        dutheta(i)=0.0d0
3391 c     enddo
3392 c     do i=loc_start,loc_end
3393         do j=1,3
3394           duscdiff(j,i)=0.0d0
3395           duscdiffx(j,i)=0.0d0
3396         enddo
3397       enddo
3398 #endif
3399 c
3400 c     do iref=1,nref
3401 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3402 c     write (iout,*) "waga_theta",waga_theta
3403       if (waga_theta.gt.0.0d0) then
3404 #ifdef DEBUG
3405       write (iout,*) "usampl",usampl
3406       write(iout,*) "------- theta restrs start -------"
3407 c     do i=ithet_start,ithet_end
3408 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3409 c     enddo
3410 #endif
3411 c     write (iout,*) "maxres",maxres,"nres",nres
3412
3413       do i=ithet_start,ithet_end
3414 c
3415 c     do i=1,nfrag_back
3416 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3417 c
3418 c Deviation of theta angles wrt constr_homology ref structures
3419 c
3420         utheta_i=0.0d0 ! argument of Gaussian for single k
3421         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3422 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3423 c       over residues in a fragment
3424 c       write (iout,*) "theta(",i,")=",theta(i)
3425         do k=1,constr_homology
3426 c
3427 c         dtheta_i=theta(j)-thetaref(j,iref)
3428 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3429           theta_diff(k)=thetatpl(k,i)-theta(i)
3430 c
3431           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3432 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3433           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3434           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3435 c         Gradient for single Gaussian restraint in subr Econstr_back
3436 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3437 c
3438         enddo
3439 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3440 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3441
3442 c
3443 #ifdef GRAD
3444 c         Gradient for multiple Gaussian restraint
3445         sum_gtheta=gutheta_i
3446         sum_sgtheta=0.0d0
3447         do k=1,constr_homology
3448 c        New generalized expr for multiple Gaussian from Econstr_back
3449          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3450 c
3451 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3452           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3453         enddo
3454 c
3455 c       Final value of gradient using same var as in Econstr_back
3456         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3457      &               *waga_homology(iset)
3458 c       dutheta(i)=sum_sgtheta/sum_gtheta
3459 c
3460 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3461 #endif
3462         Eval=Eval-dLOG(gutheta_i/constr_homology)
3463 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3464 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3465 c       Uconst_back=Uconst_back+utheta(i)
3466       enddo ! (i-loop for theta)
3467 #ifdef DEBUG
3468       write(iout,*) "------- theta restrs end -------"
3469 #endif
3470       endif
3471 c
3472 c Deviation of local SC geometry
3473 c
3474 c Separation of two i-loops (instructed by AL - 11/3/2014)
3475 c
3476 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3477 c     write (iout,*) "waga_d",waga_d
3478
3479 #ifdef DEBUG
3480       write(iout,*) "------- SC restrs start -------"
3481       write (iout,*) "Initial duscdiff,duscdiffx"
3482       do i=loc_start,loc_end
3483         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3484      &                 (duscdiffx(jik,i),jik=1,3)
3485       enddo
3486 #endif
3487       do i=loc_start,loc_end
3488         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3489         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3490 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3491 c       write(iout,*) "xxtab, yytab, zztab"
3492 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3493         do k=1,constr_homology
3494 c
3495           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3496 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3497           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3498           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3499 c         write(iout,*) "dxx, dyy, dzz"
3500 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3501 c
3502           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3503 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3504 c         uscdiffk(k)=usc_diff(i)
3505           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3506           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3507 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3508 c     &      xxref(j),yyref(j),zzref(j)
3509         enddo
3510 c
3511 c       Gradient
3512 c
3513 c       Generalized expression for multiple Gaussian acc to that for a single
3514 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3515 c
3516 c       Original implementation
3517 c       sum_guscdiff=guscdiff(i)
3518 c
3519 c       sum_sguscdiff=0.0d0
3520 c       do k=1,constr_homology
3521 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3522 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3523 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3524 c       enddo
3525 c
3526 c       Implementation of new expressions for gradient (Jan. 2015)
3527 c
3528 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3529 #ifdef GRAD
3530         do k=1,constr_homology
3531 c
3532 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3533 c       before. Now the drivatives should be correct
3534 c
3535           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3536 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3537           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3538           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3539 c
3540 c         New implementation
3541 c
3542           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3543      &                 sigma_d(k,i) ! for the grad wrt r'
3544 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3545 c
3546 c
3547 c        New implementation
3548          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3549          do jik=1,3
3550             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3551      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3552      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3553             duscdiff(jik,i)=duscdiff(jik,i)+
3554      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3555      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3556             duscdiffx(jik,i)=duscdiffx(jik,i)+
3557      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3558      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3559 c
3560 #ifdef DEBUG
3561              write(iout,*) "jik",jik,"i",i
3562              write(iout,*) "dxx, dyy, dzz"
3563              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3564              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3565 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3566 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3567 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3568 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3569 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3570 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3571 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3572 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3573 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3574 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3575 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3576 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3577 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3578 c            endif
3579 #endif
3580          enddo
3581         enddo
3582 #endif
3583 c
3584 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3585 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3586 c
3587 c        write (iout,*) i," uscdiff",uscdiff(i)
3588 c
3589 c Put together deviations from local geometry
3590
3591 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3592 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3593         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3594 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3595 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3596 c       Uconst_back=Uconst_back+usc_diff(i)
3597 c
3598 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3599 c
3600 c     New implment: multiplied by sum_sguscdiff
3601 c
3602
3603       enddo ! (i-loop for dscdiff)
3604
3605 c      endif
3606
3607 #ifdef DEBUG
3608       write(iout,*) "------- SC restrs end -------"
3609         write (iout,*) "------ After SC loop in e_modeller ------"
3610         do i=loc_start,loc_end
3611          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3612          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3613         enddo
3614       if (waga_theta.eq.1.0d0) then
3615       write (iout,*) "in e_modeller after SC restr end: dutheta"
3616       do i=ithet_start,ithet_end
3617         write (iout,*) i,dutheta(i)
3618       enddo
3619       endif
3620       if (waga_d.eq.1.0d0) then
3621       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3622       do i=1,nres
3623         write (iout,*) i,(duscdiff(j,i),j=1,3)
3624         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3625       enddo
3626       endif
3627 #endif
3628
3629 c Total energy from homology restraints
3630 #ifdef DEBUG
3631       write (iout,*) "odleg",odleg," kat",kat
3632       write (iout,*) "odleg",odleg," kat",kat
3633       write (iout,*) "Eval",Eval," Erot",Erot
3634       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3635       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3636       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3637       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3638 #endif
3639 c
3640 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3641 c
3642 c     ehomology_constr=odleg+kat
3643 c
3644 c     For Lorentzian-type Urestr
3645 c
3646
3647       if (waga_dist.ge.0.0d0) then
3648 c
3649 c          For Gaussian-type Urestr
3650 c
3651         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3652      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3653 c     write (iout,*) "ehomology_constr=",ehomology_constr
3654       else
3655 c
3656 c          For Lorentzian-type Urestr
3657 c
3658         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3659      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3660 c     write (iout,*) "ehomology_constr=",ehomology_constr
3661       endif
3662 #ifdef DEBUG
3663       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
3664       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3665      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
3666       write (iout,*) "ehomology_constr",ehomology_constr
3667 #endif
3668       return
3669
3670   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3671   747 format(a12,i4,i4,i4,f8.3,f8.3)
3672   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3673   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3674   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3675      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3676       end
3677 C--------------------------------------------------------------------------
3678       subroutine ebond(estr)
3679 c
3680 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3681 c
3682       implicit real*8 (a-h,o-z)
3683       include 'DIMENSIONS'
3684       include 'COMMON.LOCAL'
3685       include 'COMMON.GEO'
3686       include 'COMMON.INTERACT'
3687       include 'COMMON.DERIV'
3688       include 'COMMON.VAR'
3689       include 'COMMON.CHAIN'
3690       include 'COMMON.IOUNITS'
3691       include 'COMMON.NAMES'
3692       include 'COMMON.FFIELD'
3693       include 'COMMON.CONTROL'
3694       double precision u(3),ud(3)
3695       estr=0.0d0
3696       do i=nnt+1,nct
3697         diff = vbld(i)-vbldp0
3698 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3699         estr=estr+diff*diff
3700         do j=1,3
3701           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3702         enddo
3703       enddo
3704       estr=0.5d0*AKP*estr
3705 c
3706 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3707 c
3708       do i=nnt,nct
3709         iti=itype(i)
3710         if (iti.ne.10) then
3711           nbi=nbondterm(iti)
3712           if (nbi.eq.1) then
3713             diff=vbld(i+nres)-vbldsc0(1,iti)
3714 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3715 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3716             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3717             do j=1,3
3718               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3719             enddo
3720           else
3721             do j=1,nbi
3722               diff=vbld(i+nres)-vbldsc0(j,iti)
3723               ud(j)=aksc(j,iti)*diff
3724               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3725             enddo
3726             uprod=u(1)
3727             do j=2,nbi
3728               uprod=uprod*u(j)
3729             enddo
3730             usum=0.0d0
3731             usumsqder=0.0d0
3732             do j=1,nbi
3733               uprod1=1.0d0
3734               uprod2=1.0d0
3735               do k=1,nbi
3736                 if (k.ne.j) then
3737                   uprod1=uprod1*u(k)
3738                   uprod2=uprod2*u(k)*u(k)
3739                 endif
3740               enddo
3741               usum=usum+uprod1
3742               usumsqder=usumsqder+ud(j)*uprod2
3743             enddo
3744 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3745 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3746             estr=estr+uprod/usum
3747             do j=1,3
3748              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3749             enddo
3750           endif
3751         endif
3752       enddo
3753       return
3754       end
3755 #ifdef CRYST_THETA
3756 C--------------------------------------------------------------------------
3757       subroutine ebend(etheta)
3758 C
3759 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3760 C angles gamma and its derivatives in consecutive thetas and gammas.
3761 C
3762       implicit real*8 (a-h,o-z)
3763       include 'DIMENSIONS'
3764       include 'sizesclu.dat'
3765       include 'COMMON.LOCAL'
3766       include 'COMMON.GEO'
3767       include 'COMMON.INTERACT'
3768       include 'COMMON.DERIV'
3769       include 'COMMON.VAR'
3770       include 'COMMON.CHAIN'
3771       include 'COMMON.IOUNITS'
3772       include 'COMMON.NAMES'
3773       include 'COMMON.FFIELD'
3774       common /calcthet/ term1,term2,termm,diffak,ratak,
3775      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3776      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3777       double precision y(2),z(2)
3778       delta=0.02d0*pi
3779       time11=dexp(-2*time)
3780       time12=1.0d0
3781       etheta=0.0D0
3782 c      write (iout,*) "nres",nres
3783 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3784 c      write (iout,*) ithet_start,ithet_end
3785       do i=ithet_start,ithet_end
3786 C Zero the energy function and its derivative at 0 or pi.
3787         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3788         it=itype(i-1)
3789 c        if (i.gt.ithet_start .and.
3790 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3791 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3792 c          phii=phi(i)
3793 c          y(1)=dcos(phii)
3794 c          y(2)=dsin(phii)
3795 c        else
3796 c          y(1)=0.0D0
3797 c          y(2)=0.0D0
3798 c        endif
3799 c        if (i.lt.nres .and. itel(i).ne.0) then
3800 c          phii1=phi(i+1)
3801 c          z(1)=dcos(phii1)
3802 c          z(2)=dsin(phii1)
3803 c        else
3804 c          z(1)=0.0D0
3805 c          z(2)=0.0D0
3806 c        endif
3807         if (i.gt.3) then
3808 #ifdef OSF
3809           phii=phi(i)
3810           icrc=0
3811           call proc_proc(phii,icrc)
3812           if (icrc.eq.1) phii=150.0
3813 #else
3814           phii=phi(i)
3815 #endif
3816           y(1)=dcos(phii)
3817           y(2)=dsin(phii)
3818         else
3819           y(1)=0.0D0
3820           y(2)=0.0D0
3821         endif
3822         if (i.lt.nres) then
3823 #ifdef OSF
3824           phii1=phi(i+1)
3825           icrc=0
3826           call proc_proc(phii1,icrc)
3827           if (icrc.eq.1) phii1=150.0
3828           phii1=pinorm(phii1)
3829           z(1)=cos(phii1)
3830 #else
3831           phii1=phi(i+1)
3832           z(1)=dcos(phii1)
3833 #endif
3834           z(2)=dsin(phii1)
3835         else
3836           z(1)=0.0D0
3837           z(2)=0.0D0
3838         endif
3839 C Calculate the "mean" value of theta from the part of the distribution
3840 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3841 C In following comments this theta will be referred to as t_c.
3842         thet_pred_mean=0.0d0
3843         do k=1,2
3844           athetk=athet(k,it)
3845           bthetk=bthet(k,it)
3846           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3847         enddo
3848 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3849         dthett=thet_pred_mean*ssd
3850         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3851 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3852 C Derivatives of the "mean" values in gamma1 and gamma2.
3853         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3854         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3855         if (theta(i).gt.pi-delta) then
3856           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3857      &         E_tc0)
3858           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3859           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3860           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3861      &        E_theta)
3862           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3863      &        E_tc)
3864         else if (theta(i).lt.delta) then
3865           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3866           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3867           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3868      &        E_theta)
3869           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3870           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3871      &        E_tc)
3872         else
3873           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3874      &        E_theta,E_tc)
3875         endif
3876         etheta=etheta+ethetai
3877 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3878 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3879         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3880         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3881         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3882  1215   continue
3883       enddo
3884 C Ufff.... We've done all this!!!
3885       return
3886       end
3887 C---------------------------------------------------------------------------
3888       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3889      &     E_tc)
3890       implicit real*8 (a-h,o-z)
3891       include 'DIMENSIONS'
3892       include 'COMMON.LOCAL'
3893       include 'COMMON.IOUNITS'
3894       common /calcthet/ term1,term2,termm,diffak,ratak,
3895      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3896      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3897 C Calculate the contributions to both Gaussian lobes.
3898 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3899 C The "polynomial part" of the "standard deviation" of this part of
3900 C the distribution.
3901         sig=polthet(3,it)
3902         do j=2,0,-1
3903           sig=sig*thet_pred_mean+polthet(j,it)
3904         enddo
3905 C Derivative of the "interior part" of the "standard deviation of the"
3906 C gamma-dependent Gaussian lobe in t_c.
3907         sigtc=3*polthet(3,it)
3908         do j=2,1,-1
3909           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3910         enddo
3911         sigtc=sig*sigtc
3912 C Set the parameters of both Gaussian lobes of the distribution.
3913 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3914         fac=sig*sig+sigc0(it)
3915         sigcsq=fac+fac
3916         sigc=1.0D0/sigcsq
3917 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3918         sigsqtc=-4.0D0*sigcsq*sigtc
3919 c       print *,i,sig,sigtc,sigsqtc
3920 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3921         sigtc=-sigtc/(fac*fac)
3922 C Following variable is sigma(t_c)**(-2)
3923         sigcsq=sigcsq*sigcsq
3924         sig0i=sig0(it)
3925         sig0inv=1.0D0/sig0i**2
3926         delthec=thetai-thet_pred_mean
3927         delthe0=thetai-theta0i
3928         term1=-0.5D0*sigcsq*delthec*delthec
3929         term2=-0.5D0*sig0inv*delthe0*delthe0
3930 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3931 C NaNs in taking the logarithm. We extract the largest exponent which is added
3932 C to the energy (this being the log of the distribution) at the end of energy
3933 C term evaluation for this virtual-bond angle.
3934         if (term1.gt.term2) then
3935           termm=term1
3936           term2=dexp(term2-termm)
3937           term1=1.0d0
3938         else
3939           termm=term2
3940           term1=dexp(term1-termm)
3941           term2=1.0d0
3942         endif
3943 C The ratio between the gamma-independent and gamma-dependent lobes of
3944 C the distribution is a Gaussian function of thet_pred_mean too.
3945         diffak=gthet(2,it)-thet_pred_mean
3946         ratak=diffak/gthet(3,it)**2
3947         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3948 C Let's differentiate it in thet_pred_mean NOW.
3949         aktc=ak*ratak
3950 C Now put together the distribution terms to make complete distribution.
3951         termexp=term1+ak*term2
3952         termpre=sigc+ak*sig0i
3953 C Contribution of the bending energy from this theta is just the -log of
3954 C the sum of the contributions from the two lobes and the pre-exponential
3955 C factor. Simple enough, isn't it?
3956         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3957 C NOW the derivatives!!!
3958 C 6/6/97 Take into account the deformation.
3959         E_theta=(delthec*sigcsq*term1
3960      &       +ak*delthe0*sig0inv*term2)/termexp
3961         E_tc=((sigtc+aktc*sig0i)/termpre
3962      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3963      &       aktc*term2)/termexp)
3964       return
3965       end
3966 c-----------------------------------------------------------------------------
3967       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3968       implicit real*8 (a-h,o-z)
3969       include 'DIMENSIONS'
3970       include 'COMMON.LOCAL'
3971       include 'COMMON.IOUNITS'
3972       common /calcthet/ term1,term2,termm,diffak,ratak,
3973      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3974      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3975       delthec=thetai-thet_pred_mean
3976       delthe0=thetai-theta0i
3977 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3978       t3 = thetai-thet_pred_mean
3979       t6 = t3**2
3980       t9 = term1
3981       t12 = t3*sigcsq
3982       t14 = t12+t6*sigsqtc
3983       t16 = 1.0d0
3984       t21 = thetai-theta0i
3985       t23 = t21**2
3986       t26 = term2
3987       t27 = t21*t26
3988       t32 = termexp
3989       t40 = t32**2
3990       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3991      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3992      & *(-t12*t9-ak*sig0inv*t27)
3993       return
3994       end
3995 #else
3996 C--------------------------------------------------------------------------
3997       subroutine ebend(etheta)
3998 C
3999 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4000 C angles gamma and its derivatives in consecutive thetas and gammas.
4001 C ab initio-derived potentials from
4002 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4003 C
4004       implicit real*8 (a-h,o-z)
4005       include 'DIMENSIONS'
4006       include 'COMMON.LOCAL'
4007       include 'COMMON.GEO'
4008       include 'COMMON.INTERACT'
4009       include 'COMMON.DERIV'
4010       include 'COMMON.VAR'
4011       include 'COMMON.CHAIN'
4012       include 'COMMON.IOUNITS'
4013       include 'COMMON.NAMES'
4014       include 'COMMON.FFIELD'
4015       include 'COMMON.CONTROL'
4016       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4017      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4018      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4019      & sinph1ph2(maxdouble,maxdouble)
4020       logical lprn /.false./, lprn1 /.false./
4021       etheta=0.0D0
4022       do i=ithet_start,ithet_end
4023         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4024      &    (itype(i).eq.ntyp1)) cycle
4025         dethetai=0.0d0
4026         dephii=0.0d0
4027         dephii1=0.0d0
4028         theti2=0.5d0*theta(i)
4029         ityp2=ithetyp(itype(i-1))
4030         do k=1,nntheterm
4031           coskt(k)=dcos(k*theti2)
4032           sinkt(k)=dsin(k*theti2)
4033         enddo
4034         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4035 #ifdef OSF
4036           phii=phi(i)
4037           if (phii.ne.phii) phii=150.0
4038 #else
4039           phii=phi(i)
4040 #endif
4041           ityp1=ithetyp(itype(i-2))
4042           do k=1,nsingle
4043             cosph1(k)=dcos(k*phii)
4044             sinph1(k)=dsin(k*phii)
4045           enddo
4046         else
4047           phii=0.0d0
4048           ityp1=ithetyp(itype(i-2))
4049           do k=1,nsingle
4050             cosph1(k)=0.0d0
4051             sinph1(k)=0.0d0
4052           enddo
4053         endif
4054         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4055 #ifdef OSF
4056           phii1=phi(i+1)
4057           if (phii1.ne.phii1) phii1=150.0
4058           phii1=pinorm(phii1)
4059 #else
4060           phii1=phi(i+1)
4061 #endif
4062           ityp3=ithetyp(itype(i))
4063           do k=1,nsingle
4064             cosph2(k)=dcos(k*phii1)
4065             sinph2(k)=dsin(k*phii1)
4066           enddo
4067         else
4068           phii1=0.0d0
4069           ityp3=ithetyp(itype(i))
4070           do k=1,nsingle
4071             cosph2(k)=0.0d0
4072             sinph2(k)=0.0d0
4073           enddo
4074         endif
4075 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4076 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4077 c        call flush(iout)
4078         ethetai=aa0thet(ityp1,ityp2,ityp3)
4079         do k=1,ndouble
4080           do l=1,k-1
4081             ccl=cosph1(l)*cosph2(k-l)
4082             ssl=sinph1(l)*sinph2(k-l)
4083             scl=sinph1(l)*cosph2(k-l)
4084             csl=cosph1(l)*sinph2(k-l)
4085             cosph1ph2(l,k)=ccl-ssl
4086             cosph1ph2(k,l)=ccl+ssl
4087             sinph1ph2(l,k)=scl+csl
4088             sinph1ph2(k,l)=scl-csl
4089           enddo
4090         enddo
4091         if (lprn) then
4092         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4093      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4094         write (iout,*) "coskt and sinkt"
4095         do k=1,nntheterm
4096           write (iout,*) k,coskt(k),sinkt(k)
4097         enddo
4098         endif
4099         do k=1,ntheterm
4100           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4101           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4102      &      *coskt(k)
4103           if (lprn)
4104      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4105      &     " ethetai",ethetai
4106         enddo
4107         if (lprn) then
4108         write (iout,*) "cosph and sinph"
4109         do k=1,nsingle
4110           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4111         enddo
4112         write (iout,*) "cosph1ph2 and sinph2ph2"
4113         do k=2,ndouble
4114           do l=1,k-1
4115             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4116      &         sinph1ph2(l,k),sinph1ph2(k,l)
4117           enddo
4118         enddo
4119         write(iout,*) "ethetai",ethetai
4120         endif
4121         do m=1,ntheterm2
4122           do k=1,nsingle
4123             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4124      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4125      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4126      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4127             ethetai=ethetai+sinkt(m)*aux
4128             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4129             dephii=dephii+k*sinkt(m)*(
4130      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4131      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4132             dephii1=dephii1+k*sinkt(m)*(
4133      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4134      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4135             if (lprn)
4136      &      write (iout,*) "m",m," k",k," bbthet",
4137      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4138      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4139      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4140      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4141           enddo
4142         enddo
4143         if (lprn)
4144      &  write(iout,*) "ethetai",ethetai
4145         do m=1,ntheterm3
4146           do k=2,ndouble
4147             do l=1,k-1
4148               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4149      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4150      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4151      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4152               ethetai=ethetai+sinkt(m)*aux
4153               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4154               dephii=dephii+l*sinkt(m)*(
4155      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4156      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4157      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4158      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4159               dephii1=dephii1+(k-l)*sinkt(m)*(
4160      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4161      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4162      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4163      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4164               if (lprn) then
4165               write (iout,*) "m",m," k",k," l",l," ffthet",
4166      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4167      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4168      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4169      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4170               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4171      &            cosph1ph2(k,l)*sinkt(m),
4172      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4173               endif
4174             enddo
4175           enddo
4176         enddo
4177 10      continue
4178 c        lprn1=.true.
4179         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4180      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4181      &   phii1*rad2deg,ethetai
4182 c        lprn1=.false.
4183         etheta=etheta+ethetai
4184
4185         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4186         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4187         gloc(nphi+i-2,icg)=wang*dethetai
4188       enddo
4189       return
4190       end
4191 #endif
4192 #ifdef CRYST_SC
4193 c-----------------------------------------------------------------------------
4194       subroutine esc(escloc)
4195 C Calculate the local energy of a side chain and its derivatives in the
4196 C corresponding virtual-bond valence angles THETA and the spherical angles
4197 C ALPHA and OMEGA.
4198       implicit real*8 (a-h,o-z)
4199       include 'DIMENSIONS'
4200       include 'sizesclu.dat'
4201       include 'COMMON.GEO'
4202       include 'COMMON.LOCAL'
4203       include 'COMMON.VAR'
4204       include 'COMMON.INTERACT'
4205       include 'COMMON.DERIV'
4206       include 'COMMON.CHAIN'
4207       include 'COMMON.IOUNITS'
4208       include 'COMMON.NAMES'
4209       include 'COMMON.FFIELD'
4210       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4211      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4212       common /sccalc/ time11,time12,time112,theti,it,nlobit
4213       delta=0.02d0*pi
4214       escloc=0.0D0
4215 c     write (iout,'(a)') 'ESC'
4216       do i=loc_start,loc_end
4217         it=itype(i)
4218         if (it.eq.10) goto 1
4219         nlobit=nlob(it)
4220 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4221 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4222         theti=theta(i+1)-pipol
4223         x(1)=dtan(theti)
4224         x(2)=alph(i)
4225         x(3)=omeg(i)
4226 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4227
4228         if (x(2).gt.pi-delta) then
4229           xtemp(1)=x(1)
4230           xtemp(2)=pi-delta
4231           xtemp(3)=x(3)
4232           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4233           xtemp(2)=pi
4234           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4235           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4236      &        escloci,dersc(2))
4237           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4238      &        ddersc0(1),dersc(1))
4239           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4240      &        ddersc0(3),dersc(3))
4241           xtemp(2)=pi-delta
4242           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4243           xtemp(2)=pi
4244           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4245           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4246      &            dersc0(2),esclocbi,dersc02)
4247           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4248      &            dersc12,dersc01)
4249           call splinthet(x(2),0.5d0*delta,ss,ssd)
4250           dersc0(1)=dersc01
4251           dersc0(2)=dersc02
4252           dersc0(3)=0.0d0
4253           do k=1,3
4254             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4255           enddo
4256           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4257 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4258 c    &             esclocbi,ss,ssd
4259           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4260 c         escloci=esclocbi
4261 c         write (iout,*) escloci
4262         else if (x(2).lt.delta) then
4263           xtemp(1)=x(1)
4264           xtemp(2)=delta
4265           xtemp(3)=x(3)
4266           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4267           xtemp(2)=0.0d0
4268           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4269           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4270      &        escloci,dersc(2))
4271           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4272      &        ddersc0(1),dersc(1))
4273           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4274      &        ddersc0(3),dersc(3))
4275           xtemp(2)=delta
4276           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4277           xtemp(2)=0.0d0
4278           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4279           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4280      &            dersc0(2),esclocbi,dersc02)
4281           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4282      &            dersc12,dersc01)
4283           dersc0(1)=dersc01
4284           dersc0(2)=dersc02
4285           dersc0(3)=0.0d0
4286           call splinthet(x(2),0.5d0*delta,ss,ssd)
4287           do k=1,3
4288             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4289           enddo
4290           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4291 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4292 c    &             esclocbi,ss,ssd
4293           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4294 c         write (iout,*) escloci
4295         else
4296           call enesc(x,escloci,dersc,ddummy,.false.)
4297         endif
4298
4299         escloc=escloc+escloci
4300 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4301
4302         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4303      &   wscloc*dersc(1)
4304         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4305         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4306     1   continue
4307       enddo
4308       return
4309       end
4310 C---------------------------------------------------------------------------
4311       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4312       implicit real*8 (a-h,o-z)
4313       include 'DIMENSIONS'
4314       include 'COMMON.GEO'
4315       include 'COMMON.LOCAL'
4316       include 'COMMON.IOUNITS'
4317       common /sccalc/ time11,time12,time112,theti,it,nlobit
4318       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4319       double precision contr(maxlob,-1:1)
4320       logical mixed
4321 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4322         escloc_i=0.0D0
4323         do j=1,3
4324           dersc(j)=0.0D0
4325           if (mixed) ddersc(j)=0.0d0
4326         enddo
4327         x3=x(3)
4328
4329 C Because of periodicity of the dependence of the SC energy in omega we have
4330 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4331 C To avoid underflows, first compute & store the exponents.
4332
4333         do iii=-1,1
4334
4335           x(3)=x3+iii*dwapi
4336
4337           do j=1,nlobit
4338             do k=1,3
4339               z(k)=x(k)-censc(k,j,it)
4340             enddo
4341             do k=1,3
4342               Axk=0.0D0
4343               do l=1,3
4344                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4345               enddo
4346               Ax(k,j,iii)=Axk
4347             enddo
4348             expfac=0.0D0
4349             do k=1,3
4350               expfac=expfac+Ax(k,j,iii)*z(k)
4351             enddo
4352             contr(j,iii)=expfac
4353           enddo ! j
4354
4355         enddo ! iii
4356
4357         x(3)=x3
4358 C As in the case of ebend, we want to avoid underflows in exponentiation and
4359 C subsequent NaNs and INFs in energy calculation.
4360 C Find the largest exponent
4361         emin=contr(1,-1)
4362         do iii=-1,1
4363           do j=1,nlobit
4364             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4365           enddo
4366         enddo
4367         emin=0.5D0*emin
4368 cd      print *,'it=',it,' emin=',emin
4369
4370 C Compute the contribution to SC energy and derivatives
4371         do iii=-1,1
4372
4373           do j=1,nlobit
4374             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4375 cd          print *,'j=',j,' expfac=',expfac
4376             escloc_i=escloc_i+expfac
4377             do k=1,3
4378               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4379             enddo
4380             if (mixed) then
4381               do k=1,3,2
4382                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4383      &            +gaussc(k,2,j,it))*expfac
4384               enddo
4385             endif
4386           enddo
4387
4388         enddo ! iii
4389
4390         dersc(1)=dersc(1)/cos(theti)**2
4391         ddersc(1)=ddersc(1)/cos(theti)**2
4392         ddersc(3)=ddersc(3)
4393
4394         escloci=-(dlog(escloc_i)-emin)
4395         do j=1,3
4396           dersc(j)=dersc(j)/escloc_i
4397         enddo
4398         if (mixed) then
4399           do j=1,3,2
4400             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4401           enddo
4402         endif
4403       return
4404       end
4405 C------------------------------------------------------------------------------
4406       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4407       implicit real*8 (a-h,o-z)
4408       include 'DIMENSIONS'
4409       include 'COMMON.GEO'
4410       include 'COMMON.LOCAL'
4411       include 'COMMON.IOUNITS'
4412       common /sccalc/ time11,time12,time112,theti,it,nlobit
4413       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4414       double precision contr(maxlob)
4415       logical mixed
4416
4417       escloc_i=0.0D0
4418
4419       do j=1,3
4420         dersc(j)=0.0D0
4421       enddo
4422
4423       do j=1,nlobit
4424         do k=1,2
4425           z(k)=x(k)-censc(k,j,it)
4426         enddo
4427         z(3)=dwapi
4428         do k=1,3
4429           Axk=0.0D0
4430           do l=1,3
4431             Axk=Axk+gaussc(l,k,j,it)*z(l)
4432           enddo
4433           Ax(k,j)=Axk
4434         enddo
4435         expfac=0.0D0
4436         do k=1,3
4437           expfac=expfac+Ax(k,j)*z(k)
4438         enddo
4439         contr(j)=expfac
4440       enddo ! j
4441
4442 C As in the case of ebend, we want to avoid underflows in exponentiation and
4443 C subsequent NaNs and INFs in energy calculation.
4444 C Find the largest exponent
4445       emin=contr(1)
4446       do j=1,nlobit
4447         if (emin.gt.contr(j)) emin=contr(j)
4448       enddo
4449       emin=0.5D0*emin
4450
4451 C Compute the contribution to SC energy and derivatives
4452
4453       dersc12=0.0d0
4454       do j=1,nlobit
4455         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4456         escloc_i=escloc_i+expfac
4457         do k=1,2
4458           dersc(k)=dersc(k)+Ax(k,j)*expfac
4459         enddo
4460         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4461      &            +gaussc(1,2,j,it))*expfac
4462         dersc(3)=0.0d0
4463       enddo
4464
4465       dersc(1)=dersc(1)/cos(theti)**2
4466       dersc12=dersc12/cos(theti)**2
4467       escloci=-(dlog(escloc_i)-emin)
4468       do j=1,2
4469         dersc(j)=dersc(j)/escloc_i
4470       enddo
4471       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4472       return
4473       end
4474 #else
4475 c----------------------------------------------------------------------------------
4476       subroutine esc(escloc)
4477 C Calculate the local energy of a side chain and its derivatives in the
4478 C corresponding virtual-bond valence angles THETA and the spherical angles
4479 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4480 C added by Urszula Kozlowska. 07/11/2007
4481 C
4482       implicit real*8 (a-h,o-z)
4483       include 'DIMENSIONS'
4484       include 'COMMON.GEO'
4485       include 'COMMON.LOCAL'
4486       include 'COMMON.VAR'
4487       include 'COMMON.SCROT'
4488       include 'COMMON.INTERACT'
4489       include 'COMMON.DERIV'
4490       include 'COMMON.CHAIN'
4491       include 'COMMON.IOUNITS'
4492       include 'COMMON.NAMES'
4493       include 'COMMON.FFIELD'
4494       include 'COMMON.CONTROL'
4495       include 'COMMON.VECTORS'
4496       double precision x_prime(3),y_prime(3),z_prime(3)
4497      &    , sumene,dsc_i,dp2_i,x(65),
4498      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4499      &    de_dxx,de_dyy,de_dzz,de_dt
4500       double precision s1_t,s1_6_t,s2_t,s2_6_t
4501       double precision
4502      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4503      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4504      & dt_dCi(3),dt_dCi1(3)
4505       common /sccalc/ time11,time12,time112,theti,it,nlobit
4506       delta=0.02d0*pi
4507       escloc=0.0D0
4508       do i=loc_start,loc_end
4509         costtab(i+1) =dcos(theta(i+1))
4510         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4511         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4512         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4513         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4514         cosfac=dsqrt(cosfac2)
4515         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4516         sinfac=dsqrt(sinfac2)
4517         it=itype(i)
4518         if (it.eq.10) goto 1
4519 c
4520 C  Compute the axes of tghe local cartesian coordinates system; store in
4521 c   x_prime, y_prime and z_prime
4522 c
4523         do j=1,3
4524           x_prime(j) = 0.00
4525           y_prime(j) = 0.00
4526           z_prime(j) = 0.00
4527         enddo
4528 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4529 C     &   dc_norm(3,i+nres)
4530         do j = 1,3
4531           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4532           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4533         enddo
4534         do j = 1,3
4535           z_prime(j) = -uz(j,i-1)
4536         enddo
4537 c       write (2,*) "i",i
4538 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4539 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4540 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4541 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4542 c      & " xy",scalar(x_prime(1),y_prime(1)),
4543 c      & " xz",scalar(x_prime(1),z_prime(1)),
4544 c      & " yy",scalar(y_prime(1),y_prime(1)),
4545 c      & " yz",scalar(y_prime(1),z_prime(1)),
4546 c      & " zz",scalar(z_prime(1),z_prime(1))
4547 c
4548 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4549 C to local coordinate system. Store in xx, yy, zz.
4550 c
4551         xx=0.0d0
4552         yy=0.0d0
4553         zz=0.0d0
4554         do j = 1,3
4555           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4556           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4557           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4558         enddo
4559
4560         xxtab(i)=xx
4561         yytab(i)=yy
4562         zztab(i)=zz
4563 C
4564 C Compute the energy of the ith side cbain
4565 C
4566 c        write (2,*) "xx",xx," yy",yy," zz",zz
4567         it=itype(i)
4568         do j = 1,65
4569           x(j) = sc_parmin(j,it)
4570         enddo
4571 #ifdef CHECK_COORD
4572 Cc diagnostics - remove later
4573         xx1 = dcos(alph(2))
4574         yy1 = dsin(alph(2))*dcos(omeg(2))
4575         zz1 = -dsin(alph(2))*dsin(omeg(2))
4576         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4577      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4578      &    xx1,yy1,zz1
4579 C,"  --- ", xx_w,yy_w,zz_w
4580 c end diagnostics
4581 #endif
4582         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4583      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4584      &   + x(10)*yy*zz
4585         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4586      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4587      & + x(20)*yy*zz
4588         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4589      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4590      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4591      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4592      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4593      &  +x(40)*xx*yy*zz
4594         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4595      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4596      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4597      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4598      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4599      &  +x(60)*xx*yy*zz
4600         dsc_i   = 0.743d0+x(61)
4601         dp2_i   = 1.9d0+x(62)
4602         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4603      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4604         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4605      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4606         s1=(1+x(63))/(0.1d0 + dscp1)
4607         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4608         s2=(1+x(65))/(0.1d0 + dscp2)
4609         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4610         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4611      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4612 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4613 c     &   sumene4,
4614 c     &   dscp1,dscp2,sumene
4615 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4616         escloc = escloc + sumene
4617 c        write (2,*) "escloc",escloc
4618         if (.not. calc_grad) goto 1
4619 #ifdef DEBUG
4620 C
4621 C This section to check the numerical derivatives of the energy of ith side
4622 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4623 C #define DEBUG in the code to turn it on.
4624 C
4625         write (2,*) "sumene               =",sumene
4626         aincr=1.0d-7
4627         xxsave=xx
4628         xx=xx+aincr
4629         write (2,*) xx,yy,zz
4630         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4631         de_dxx_num=(sumenep-sumene)/aincr
4632         xx=xxsave
4633         write (2,*) "xx+ sumene from enesc=",sumenep
4634         yysave=yy
4635         yy=yy+aincr
4636         write (2,*) xx,yy,zz
4637         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4638         de_dyy_num=(sumenep-sumene)/aincr
4639         yy=yysave
4640         write (2,*) "yy+ sumene from enesc=",sumenep
4641         zzsave=zz
4642         zz=zz+aincr
4643         write (2,*) xx,yy,zz
4644         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4645         de_dzz_num=(sumenep-sumene)/aincr
4646         zz=zzsave
4647         write (2,*) "zz+ sumene from enesc=",sumenep
4648         costsave=cost2tab(i+1)
4649         sintsave=sint2tab(i+1)
4650         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4651         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4652         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4653         de_dt_num=(sumenep-sumene)/aincr
4654         write (2,*) " t+ sumene from enesc=",sumenep
4655         cost2tab(i+1)=costsave
4656         sint2tab(i+1)=sintsave
4657 C End of diagnostics section.
4658 #endif
4659 C
4660 C Compute the gradient of esc
4661 C
4662         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4663         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4664         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4665         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4666         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4667         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4668         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4669         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4670         pom1=(sumene3*sint2tab(i+1)+sumene1)
4671      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4672         pom2=(sumene4*cost2tab(i+1)+sumene2)
4673      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4674         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4675         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4676      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4677      &  +x(40)*yy*zz
4678         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4679         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4680      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4681      &  +x(60)*yy*zz
4682         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4683      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4684      &        +(pom1+pom2)*pom_dx
4685 #ifdef DEBUG
4686         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4687 #endif
4688 C
4689         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4690         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4691      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4692      &  +x(40)*xx*zz
4693         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4694         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4695      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4696      &  +x(59)*zz**2 +x(60)*xx*zz
4697         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4698      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4699      &        +(pom1-pom2)*pom_dy
4700 #ifdef DEBUG
4701         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4702 #endif
4703 C
4704         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4705      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4706      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4707      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4708      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4709      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4710      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4711      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4712 #ifdef DEBUG
4713         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4714 #endif
4715 C
4716         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4717      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4718      &  +pom1*pom_dt1+pom2*pom_dt2
4719 #ifdef DEBUG
4720         write(2,*), "de_dt = ", de_dt,de_dt_num
4721 #endif
4722 c
4723 C
4724        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4725        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4726        cosfac2xx=cosfac2*xx
4727        sinfac2yy=sinfac2*yy
4728        do k = 1,3
4729          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4730      &      vbld_inv(i+1)
4731          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4732      &      vbld_inv(i)
4733          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4734          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4735 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4736 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4737 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4738 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4739          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4740          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4741          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4742          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4743          dZZ_Ci1(k)=0.0d0
4744          dZZ_Ci(k)=0.0d0
4745          do j=1,3
4746            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4747            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4748          enddo
4749
4750          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4751          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4752          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4753 c
4754          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4755          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4756        enddo
4757
4758        do k=1,3
4759          dXX_Ctab(k,i)=dXX_Ci(k)
4760          dXX_C1tab(k,i)=dXX_Ci1(k)
4761          dYY_Ctab(k,i)=dYY_Ci(k)
4762          dYY_C1tab(k,i)=dYY_Ci1(k)
4763          dZZ_Ctab(k,i)=dZZ_Ci(k)
4764          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4765          dXX_XYZtab(k,i)=dXX_XYZ(k)
4766          dYY_XYZtab(k,i)=dYY_XYZ(k)
4767          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4768        enddo
4769
4770        do k = 1,3
4771 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4772 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4773 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4774 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4775 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4776 c     &    dt_dci(k)
4777 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4778 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4779          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4780      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4781          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4782      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4783          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4784      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4785        enddo
4786 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4787 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4788
4789 C to check gradient call subroutine check_grad
4790
4791     1 continue
4792       enddo
4793       return
4794       end
4795 #endif
4796 c------------------------------------------------------------------------------
4797       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4798 C
4799 C This procedure calculates two-body contact function g(rij) and its derivative:
4800 C
4801 C           eps0ij                                     !       x < -1
4802 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4803 C            0                                         !       x > 1
4804 C
4805 C where x=(rij-r0ij)/delta
4806 C
4807 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4808 C
4809       implicit none
4810       double precision rij,r0ij,eps0ij,fcont,fprimcont
4811       double precision x,x2,x4,delta
4812 c     delta=0.02D0*r0ij
4813 c      delta=0.2D0*r0ij
4814       x=(rij-r0ij)/delta
4815       if (x.lt.-1.0D0) then
4816         fcont=eps0ij
4817         fprimcont=0.0D0
4818       else if (x.le.1.0D0) then
4819         x2=x*x
4820         x4=x2*x2
4821         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4822         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4823       else
4824         fcont=0.0D0
4825         fprimcont=0.0D0
4826       endif
4827       return
4828       end
4829 c------------------------------------------------------------------------------
4830       subroutine splinthet(theti,delta,ss,ssder)
4831       implicit real*8 (a-h,o-z)
4832       include 'DIMENSIONS'
4833       include 'sizesclu.dat'
4834       include 'COMMON.VAR'
4835       include 'COMMON.GEO'
4836       thetup=pi-delta
4837       thetlow=delta
4838       if (theti.gt.pipol) then
4839         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4840       else
4841         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4842         ssder=-ssder
4843       endif
4844       return
4845       end
4846 c------------------------------------------------------------------------------
4847       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4848       implicit none
4849       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4850       double precision ksi,ksi2,ksi3,a1,a2,a3
4851       a1=fprim0*delta/(f1-f0)
4852       a2=3.0d0-2.0d0*a1
4853       a3=a1-2.0d0
4854       ksi=(x-x0)/delta
4855       ksi2=ksi*ksi
4856       ksi3=ksi2*ksi
4857       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4858       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4859       return
4860       end
4861 c------------------------------------------------------------------------------
4862       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4863       implicit none
4864       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4865       double precision ksi,ksi2,ksi3,a1,a2,a3
4866       ksi=(x-x0)/delta
4867       ksi2=ksi*ksi
4868       ksi3=ksi2*ksi
4869       a1=fprim0x*delta
4870       a2=3*(f1x-f0x)-2*fprim0x*delta
4871       a3=fprim0x*delta-2*(f1x-f0x)
4872       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4873       return
4874       end
4875 C-----------------------------------------------------------------------------
4876 #ifdef CRYST_TOR
4877 C-----------------------------------------------------------------------------
4878       subroutine etor(etors,edihcnstr,fact)
4879       implicit real*8 (a-h,o-z)
4880       include 'DIMENSIONS'
4881       include 'sizesclu.dat'
4882       include 'COMMON.VAR'
4883       include 'COMMON.GEO'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.TORSION'
4886       include 'COMMON.INTERACT'
4887       include 'COMMON.DERIV'
4888       include 'COMMON.CHAIN'
4889       include 'COMMON.NAMES'
4890       include 'COMMON.IOUNITS'
4891       include 'COMMON.FFIELD'
4892       include 'COMMON.TORCNSTR'
4893       logical lprn
4894 C Set lprn=.true. for debugging
4895       lprn=.false.
4896 c      lprn=.true.
4897       etors=0.0D0
4898       do i=iphi_start,iphi_end
4899         itori=itortyp(itype(i-2))
4900         itori1=itortyp(itype(i-1))
4901         phii=phi(i)
4902         gloci=0.0D0
4903 C Proline-Proline pair is a special case...
4904         if (itori.eq.3 .and. itori1.eq.3) then
4905           if (phii.gt.-dwapi3) then
4906             cosphi=dcos(3*phii)
4907             fac=1.0D0/(1.0D0-cosphi)
4908             etorsi=v1(1,3,3)*fac
4909             etorsi=etorsi+etorsi
4910             etors=etors+etorsi-v1(1,3,3)
4911             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4912           endif
4913           do j=1,3
4914             v1ij=v1(j+1,itori,itori1)
4915             v2ij=v2(j+1,itori,itori1)
4916             cosphi=dcos(j*phii)
4917             sinphi=dsin(j*phii)
4918             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4919             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4920           enddo
4921         else
4922           do j=1,nterm_old
4923             v1ij=v1(j,itori,itori1)
4924             v2ij=v2(j,itori,itori1)
4925             cosphi=dcos(j*phii)
4926             sinphi=dsin(j*phii)
4927             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4928             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4929           enddo
4930         endif
4931         if (lprn)
4932      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4933      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4934      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4935         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4936 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4937       enddo
4938 ! 6/20/98 - dihedral angle constraints
4939       edihcnstr=0.0d0
4940       do i=1,ndih_constr
4941         itori=idih_constr(i)
4942         phii=phi(itori)
4943         difi=pinorm(phii-phi0(i))
4944         if (difi.gt.drange(i)) then
4945           difi=difi-drange(i)
4946           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4947           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4948         else if (difi.lt.-drange(i)) then
4949           difi=difi+drange(i)
4950           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4951           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4952         endif
4953 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4954 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4955       enddo
4956       write (iout,*) 'edihcnstr',edihcnstr
4957       return
4958       end
4959 c------------------------------------------------------------------------------
4960 #else
4961       subroutine etor(etors,edihcnstr,fact)
4962       implicit real*8 (a-h,o-z)
4963       include 'DIMENSIONS'
4964       include 'sizesclu.dat'
4965       include 'COMMON.VAR'
4966       include 'COMMON.GEO'
4967       include 'COMMON.LOCAL'
4968       include 'COMMON.TORSION'
4969       include 'COMMON.INTERACT'
4970       include 'COMMON.DERIV'
4971       include 'COMMON.CHAIN'
4972       include 'COMMON.NAMES'
4973       include 'COMMON.IOUNITS'
4974       include 'COMMON.FFIELD'
4975       include 'COMMON.TORCNSTR'
4976       logical lprn
4977 C Set lprn=.true. for debugging
4978       lprn=.false.
4979 c      lprn=.true.
4980       etors=0.0D0
4981       do i=iphi_start,iphi_end
4982         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4983         itori=itortyp(itype(i-2))
4984         itori1=itortyp(itype(i-1))
4985         phii=phi(i)
4986         gloci=0.0D0
4987 C Regular cosine and sine terms
4988         do j=1,nterm(itori,itori1)
4989           v1ij=v1(j,itori,itori1)
4990           v2ij=v2(j,itori,itori1)
4991           cosphi=dcos(j*phii)
4992           sinphi=dsin(j*phii)
4993           etors=etors+v1ij*cosphi+v2ij*sinphi
4994           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4995         enddo
4996 C Lorentz terms
4997 C                         v1
4998 C  E = SUM ----------------------------------- - v1
4999 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5000 C
5001         cosphi=dcos(0.5d0*phii)
5002         sinphi=dsin(0.5d0*phii)
5003         do j=1,nlor(itori,itori1)
5004           vl1ij=vlor1(j,itori,itori1)
5005           vl2ij=vlor2(j,itori,itori1)
5006           vl3ij=vlor3(j,itori,itori1)
5007           pom=vl2ij*cosphi+vl3ij*sinphi
5008           pom1=1.0d0/(pom*pom+1.0d0)
5009           etors=etors+vl1ij*pom1
5010           pom=-pom*pom1*pom1
5011           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5012         enddo
5013 C Subtract the constant term
5014         etors=etors-v0(itori,itori1)
5015         if (lprn)
5016      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5017      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5018      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5019         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5020 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5021  1215   continue
5022       enddo
5023 ! 6/20/98 - dihedral angle constraints
5024       edihcnstr=0.0d0
5025 c      write (iout,*) "Dihedral angle restraint energy"
5026       do i=1,ndih_constr
5027         itori=idih_constr(i)
5028         phii=phi(itori)
5029         difi=pinorm(phii-phi0(i))
5030 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5031 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5032         if (difi.gt.drange(i)) then
5033           difi=difi-drange(i)
5034           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5035           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5036 c          write (iout,*) 0.25d0*ftors*difi**4
5037         else if (difi.lt.-drange(i)) then
5038           difi=difi+drange(i)
5039           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5040           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5041 c          write (iout,*) 0.25d0*ftors*difi**4
5042         endif
5043       enddo
5044 c      write (iout,*) 'edihcnstr',edihcnstr
5045       return
5046       end
5047 c----------------------------------------------------------------------------
5048       subroutine etor_d(etors_d,fact2)
5049 C 6/23/01 Compute double torsional energy
5050       implicit real*8 (a-h,o-z)
5051       include 'DIMENSIONS'
5052       include 'sizesclu.dat'
5053       include 'COMMON.VAR'
5054       include 'COMMON.GEO'
5055       include 'COMMON.LOCAL'
5056       include 'COMMON.TORSION'
5057       include 'COMMON.INTERACT'
5058       include 'COMMON.DERIV'
5059       include 'COMMON.CHAIN'
5060       include 'COMMON.NAMES'
5061       include 'COMMON.IOUNITS'
5062       include 'COMMON.FFIELD'
5063       include 'COMMON.TORCNSTR'
5064       logical lprn
5065 C Set lprn=.true. for debugging
5066       lprn=.false.
5067 c     lprn=.true.
5068       etors_d=0.0D0
5069       do i=iphi_start,iphi_end-1
5070         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5071      &     goto 1215
5072         itori=itortyp(itype(i-2))
5073         itori1=itortyp(itype(i-1))
5074         itori2=itortyp(itype(i))
5075         phii=phi(i)
5076         phii1=phi(i+1)
5077         gloci1=0.0D0
5078         gloci2=0.0D0
5079 C Regular cosine and sine terms
5080         do j=1,ntermd_1(itori,itori1,itori2)
5081           v1cij=v1c(1,j,itori,itori1,itori2)
5082           v1sij=v1s(1,j,itori,itori1,itori2)
5083           v2cij=v1c(2,j,itori,itori1,itori2)
5084           v2sij=v1s(2,j,itori,itori1,itori2)
5085           cosphi1=dcos(j*phii)
5086           sinphi1=dsin(j*phii)
5087           cosphi2=dcos(j*phii1)
5088           sinphi2=dsin(j*phii1)
5089           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5090      &     v2cij*cosphi2+v2sij*sinphi2
5091           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5092           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5093         enddo
5094         do k=2,ntermd_2(itori,itori1,itori2)
5095           do l=1,k-1
5096             v1cdij = v2c(k,l,itori,itori1,itori2)
5097             v2cdij = v2c(l,k,itori,itori1,itori2)
5098             v1sdij = v2s(k,l,itori,itori1,itori2)
5099             v2sdij = v2s(l,k,itori,itori1,itori2)
5100             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5101             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5102             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5103             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5104             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5105      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5106             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5107      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5108             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5109      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5110           enddo
5111         enddo
5112         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5113         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5114  1215   continue
5115       enddo
5116       return
5117       end
5118 #endif
5119 c------------------------------------------------------------------------------
5120       subroutine eback_sc_corr(esccor,fact)
5121 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5122 c        conformational states; temporarily implemented as differences
5123 c        between UNRES torsional potentials (dependent on three types of
5124 c        residues) and the torsional potentials dependent on all 20 types
5125 c        of residues computed from AM1 energy surfaces of terminally-blocked
5126 c        amino-acid residues.
5127       implicit real*8 (a-h,o-z)
5128       include 'DIMENSIONS'
5129       include 'COMMON.VAR'
5130       include 'COMMON.GEO'
5131       include 'COMMON.LOCAL'
5132       include 'COMMON.TORSION'
5133       include 'COMMON.SCCOR'
5134       include 'COMMON.INTERACT'
5135       include 'COMMON.DERIV'
5136       include 'COMMON.CHAIN'
5137       include 'COMMON.NAMES'
5138       include 'COMMON.IOUNITS'
5139       include 'COMMON.FFIELD'
5140       include 'COMMON.CONTROL'
5141       logical lprn
5142 C Set lprn=.true. for debugging
5143       lprn=.false.
5144 c      lprn=.true.
5145 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5146       esccor=0.0D0
5147       do i=itau_start,itau_end
5148         esccor_ii=0.0D0
5149         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5150         isccori=isccortyp(itype(i-2))
5151         isccori1=isccortyp(itype(i-1))
5152         phii=phi(i)
5153 cccc  Added 9 May 2012
5154 cc Tauangle is torsional engle depending on the value of first digit
5155 c(see comment below)
5156 cc Omicron is flat angle depending on the value of first digit
5157 c(see comment below)
5158
5159
5160         do intertyp=1,3 !intertyp
5161 cc Added 09 May 2012 (Adasko)
5162 cc  Intertyp means interaction type of backbone mainchain correlation:
5163 c   1 = SC...Ca...Ca...Ca
5164 c   2 = Ca...Ca...Ca...SC
5165 c   3 = SC...Ca...Ca...SCi
5166         gloci=0.0D0
5167         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5168      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5169      &      (itype(i-1).eq.21)))
5170      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5171      &     .or.(itype(i-2).eq.21)))
5172      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5173      &      (itype(i-1).eq.21)))) cycle
5174         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5175         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5176      & cycle
5177         do j=1,nterm_sccor(isccori,isccori1)
5178           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5179           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5180           cosphi=dcos(j*tauangle(intertyp,i))
5181           sinphi=dsin(j*tauangle(intertyp,i))
5182           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5183 #ifdef DEBUG
5184           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5185 #endif
5186           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5187         enddo
5188         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5189 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5190 c     &gloc_sc(intertyp,i-3,icg)
5191         if (lprn)
5192      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5193      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5194      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5195      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5196         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5197        enddo !intertyp
5198 #ifdef DEBUG
5199        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5200 #endif
5201       enddo
5202
5203       return
5204       end
5205 c------------------------------------------------------------------------------
5206       subroutine multibody(ecorr)
5207 C This subroutine calculates multi-body contributions to energy following
5208 C the idea of Skolnick et al. If side chains I and J make a contact and
5209 C at the same time side chains I+1 and J+1 make a contact, an extra
5210 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5211       implicit real*8 (a-h,o-z)
5212       include 'DIMENSIONS'
5213       include 'COMMON.IOUNITS'
5214       include 'COMMON.DERIV'
5215       include 'COMMON.INTERACT'
5216       include 'COMMON.CONTACTS'
5217       double precision gx(3),gx1(3)
5218       logical lprn
5219
5220 C Set lprn=.true. for debugging
5221       lprn=.false.
5222
5223       if (lprn) then
5224         write (iout,'(a)') 'Contact function values:'
5225         do i=nnt,nct-2
5226           write (iout,'(i2,20(1x,i2,f10.5))')
5227      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5228         enddo
5229       endif
5230       ecorr=0.0D0
5231       do i=nnt,nct
5232         do j=1,3
5233           gradcorr(j,i)=0.0D0
5234           gradxorr(j,i)=0.0D0
5235         enddo
5236       enddo
5237       do i=nnt,nct-2
5238
5239         DO ISHIFT = 3,4
5240
5241         i1=i+ishift
5242         num_conti=num_cont(i)
5243         num_conti1=num_cont(i1)
5244         do jj=1,num_conti
5245           j=jcont(jj,i)
5246           do kk=1,num_conti1
5247             j1=jcont(kk,i1)
5248             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5249 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5250 cd   &                   ' ishift=',ishift
5251 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5252 C The system gains extra energy.
5253               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5254             endif   ! j1==j+-ishift
5255           enddo     ! kk
5256         enddo       ! jj
5257
5258         ENDDO ! ISHIFT
5259
5260       enddo         ! i
5261       return
5262       end
5263 c------------------------------------------------------------------------------
5264       double precision function esccorr(i,j,k,l,jj,kk)
5265       implicit real*8 (a-h,o-z)
5266       include 'DIMENSIONS'
5267       include 'COMMON.IOUNITS'
5268       include 'COMMON.DERIV'
5269       include 'COMMON.INTERACT'
5270       include 'COMMON.CONTACTS'
5271       double precision gx(3),gx1(3)
5272       logical lprn
5273       lprn=.false.
5274       eij=facont(jj,i)
5275       ekl=facont(kk,k)
5276 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5277 C Calculate the multi-body contribution to energy.
5278 C Calculate multi-body contributions to the gradient.
5279 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5280 cd   & k,l,(gacont(m,kk,k),m=1,3)
5281       do m=1,3
5282         gx(m) =ekl*gacont(m,jj,i)
5283         gx1(m)=eij*gacont(m,kk,k)
5284         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5285         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5286         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5287         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5288       enddo
5289       do m=i,j-1
5290         do ll=1,3
5291           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5292         enddo
5293       enddo
5294       do m=k,l-1
5295         do ll=1,3
5296           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5297         enddo
5298       enddo
5299       esccorr=-eij*ekl
5300       return
5301       end
5302 c------------------------------------------------------------------------------
5303 #ifdef MPL
5304       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5305       implicit real*8 (a-h,o-z)
5306       include 'DIMENSIONS'
5307       integer dimen1,dimen2,atom,indx
5308       double precision buffer(dimen1,dimen2)
5309       double precision zapas
5310       common /contacts_hb/ zapas(3,20,maxres,7),
5311      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5312      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5313       num_kont=num_cont_hb(atom)
5314       do i=1,num_kont
5315         do k=1,7
5316           do j=1,3
5317             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5318           enddo ! j
5319         enddo ! k
5320         buffer(i,indx+22)=facont_hb(i,atom)
5321         buffer(i,indx+23)=ees0p(i,atom)
5322         buffer(i,indx+24)=ees0m(i,atom)
5323         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5324       enddo ! i
5325       buffer(1,indx+26)=dfloat(num_kont)
5326       return
5327       end
5328 c------------------------------------------------------------------------------
5329       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5330       implicit real*8 (a-h,o-z)
5331       include 'DIMENSIONS'
5332       integer dimen1,dimen2,atom,indx
5333       double precision buffer(dimen1,dimen2)
5334       double precision zapas
5335       common /contacts_hb/ zapas(3,20,maxres,7),
5336      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5337      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5338       num_kont=buffer(1,indx+26)
5339       num_kont_old=num_cont_hb(atom)
5340       num_cont_hb(atom)=num_kont+num_kont_old
5341       do i=1,num_kont
5342         ii=i+num_kont_old
5343         do k=1,7
5344           do j=1,3
5345             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5346           enddo ! j
5347         enddo ! k
5348         facont_hb(ii,atom)=buffer(i,indx+22)
5349         ees0p(ii,atom)=buffer(i,indx+23)
5350         ees0m(ii,atom)=buffer(i,indx+24)
5351         jcont_hb(ii,atom)=buffer(i,indx+25)
5352       enddo ! i
5353       return
5354       end
5355 c------------------------------------------------------------------------------
5356 #endif
5357       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5358 C This subroutine calculates multi-body contributions to hydrogen-bonding
5359       implicit real*8 (a-h,o-z)
5360       include 'DIMENSIONS'
5361       include 'sizesclu.dat'
5362       include 'COMMON.IOUNITS'
5363 #ifdef MPL
5364       include 'COMMON.INFO'
5365 #endif
5366       include 'COMMON.FFIELD'
5367       include 'COMMON.DERIV'
5368       include 'COMMON.INTERACT'
5369       include 'COMMON.CONTACTS'
5370 #ifdef MPL
5371       parameter (max_cont=maxconts)
5372       parameter (max_dim=2*(8*3+2))
5373       parameter (msglen1=max_cont*max_dim*4)
5374       parameter (msglen2=2*msglen1)
5375       integer source,CorrelType,CorrelID,Error
5376       double precision buffer(max_cont,max_dim)
5377 #endif
5378       double precision gx(3),gx1(3)
5379       logical lprn,ldone
5380
5381 C Set lprn=.true. for debugging
5382       lprn=.false.
5383 #ifdef MPL
5384       n_corr=0
5385       n_corr1=0
5386       if (fgProcs.le.1) goto 30
5387       if (lprn) then
5388         write (iout,'(a)') 'Contact function values:'
5389         do i=nnt,nct-2
5390           write (iout,'(2i3,50(1x,i2,f5.2))')
5391      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5392      &    j=1,num_cont_hb(i))
5393         enddo
5394       endif
5395 C Caution! Following code assumes that electrostatic interactions concerning
5396 C a given atom are split among at most two processors!
5397       CorrelType=477
5398       CorrelID=MyID+1
5399       ldone=.false.
5400       do i=1,max_cont
5401         do j=1,max_dim
5402           buffer(i,j)=0.0D0
5403         enddo
5404       enddo
5405       mm=mod(MyRank,2)
5406 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5407       if (mm) 20,20,10
5408    10 continue
5409 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5410       if (MyRank.gt.0) then
5411 C Send correlation contributions to the preceding processor
5412         msglen=msglen1
5413         nn=num_cont_hb(iatel_s)
5414         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5415 cd      write (iout,*) 'The BUFFER array:'
5416 cd      do i=1,nn
5417 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5418 cd      enddo
5419         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5420           msglen=msglen2
5421             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5422 C Clear the contacts of the atom passed to the neighboring processor
5423         nn=num_cont_hb(iatel_s+1)
5424 cd      do i=1,nn
5425 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5426 cd      enddo
5427             num_cont_hb(iatel_s)=0
5428         endif
5429 cd      write (iout,*) 'Processor ',MyID,MyRank,
5430 cd   & ' is sending correlation contribution to processor',MyID-1,
5431 cd   & ' msglen=',msglen
5432 cd      write (*,*) 'Processor ',MyID,MyRank,
5433 cd   & ' is sending correlation contribution to processor',MyID-1,
5434 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5435         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5436 cd      write (iout,*) 'Processor ',MyID,
5437 cd   & ' has sent correlation contribution to processor',MyID-1,
5438 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5439 cd      write (*,*) 'Processor ',MyID,
5440 cd   & ' has sent correlation contribution to processor',MyID-1,
5441 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5442         msglen=msglen1
5443       endif ! (MyRank.gt.0)
5444       if (ldone) goto 30
5445       ldone=.true.
5446    20 continue
5447 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5448       if (MyRank.lt.fgProcs-1) then
5449 C Receive correlation contributions from the next processor
5450         msglen=msglen1
5451         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5452 cd      write (iout,*) 'Processor',MyID,
5453 cd   & ' is receiving correlation contribution from processor',MyID+1,
5454 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5455 cd      write (*,*) 'Processor',MyID,
5456 cd   & ' is receiving correlation contribution from processor',MyID+1,
5457 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5458         nbytes=-1
5459         do while (nbytes.le.0)
5460           call mp_probe(MyID+1,CorrelType,nbytes)
5461         enddo
5462 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5463         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5464 cd      write (iout,*) 'Processor',MyID,
5465 cd   & ' has received correlation contribution from processor',MyID+1,
5466 cd   & ' msglen=',msglen,' nbytes=',nbytes
5467 cd      write (iout,*) 'The received BUFFER array:'
5468 cd      do i=1,max_cont
5469 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5470 cd      enddo
5471         if (msglen.eq.msglen1) then
5472           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5473         else if (msglen.eq.msglen2)  then
5474           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5475           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5476         else
5477           write (iout,*)
5478      & 'ERROR!!!! message length changed while processing correlations.'
5479           write (*,*)
5480      & 'ERROR!!!! message length changed while processing correlations.'
5481           call mp_stopall(Error)
5482         endif ! msglen.eq.msglen1
5483       endif ! MyRank.lt.fgProcs-1
5484       if (ldone) goto 30
5485       ldone=.true.
5486       goto 10
5487    30 continue
5488 #endif
5489       if (lprn) then
5490         write (iout,'(a)') 'Contact function values:'
5491         do i=nnt,nct-2
5492           write (iout,'(2i3,50(1x,i2,f5.2))')
5493      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5494      &    j=1,num_cont_hb(i))
5495         enddo
5496       endif
5497       ecorr=0.0D0
5498 C Remove the loop below after debugging !!!
5499       do i=nnt,nct
5500         do j=1,3
5501           gradcorr(j,i)=0.0D0
5502           gradxorr(j,i)=0.0D0
5503         enddo
5504       enddo
5505 C Calculate the local-electrostatic correlation terms
5506       do i=iatel_s,iatel_e+1
5507         i1=i+1
5508         num_conti=num_cont_hb(i)
5509         num_conti1=num_cont_hb(i+1)
5510         do jj=1,num_conti
5511           j=jcont_hb(jj,i)
5512           do kk=1,num_conti1
5513             j1=jcont_hb(kk,i1)
5514 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5515 c     &         ' jj=',jj,' kk=',kk
5516             if (j1.eq.j+1 .or. j1.eq.j-1) then
5517 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5518 C The system gains extra energy.
5519               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5520               n_corr=n_corr+1
5521             else if (j1.eq.j) then
5522 C Contacts I-J and I-(J+1) occur simultaneously.
5523 C The system loses extra energy.
5524 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5525             endif
5526           enddo ! kk
5527           do kk=1,num_conti
5528             j1=jcont_hb(kk,i)
5529 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5530 c    &         ' jj=',jj,' kk=',kk
5531             if (j1.eq.j+1) then
5532 C Contacts I-J and (I+1)-J occur simultaneously.
5533 C The system loses extra energy.
5534 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5535             endif ! j1==j+1
5536           enddo ! kk
5537         enddo ! jj
5538       enddo ! i
5539       return
5540       end
5541 c------------------------------------------------------------------------------
5542       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5543      &  n_corr1)
5544 C This subroutine calculates multi-body contributions to hydrogen-bonding
5545       implicit real*8 (a-h,o-z)
5546       include 'DIMENSIONS'
5547       include 'sizesclu.dat'
5548       include 'COMMON.IOUNITS'
5549 #ifdef MPL
5550       include 'COMMON.INFO'
5551 #endif
5552       include 'COMMON.FFIELD'
5553       include 'COMMON.DERIV'
5554       include 'COMMON.INTERACT'
5555       include 'COMMON.CONTACTS'
5556 #ifdef MPL
5557       parameter (max_cont=maxconts)
5558       parameter (max_dim=2*(8*3+2))
5559       parameter (msglen1=max_cont*max_dim*4)
5560       parameter (msglen2=2*msglen1)
5561       integer source,CorrelType,CorrelID,Error
5562       double precision buffer(max_cont,max_dim)
5563 #endif
5564       double precision gx(3),gx1(3)
5565       logical lprn,ldone
5566
5567 C Set lprn=.true. for debugging
5568       lprn=.false.
5569       eturn6=0.0d0
5570       ecorr6=0.0d0
5571 #ifdef MPL
5572       n_corr=0
5573       n_corr1=0
5574       if (fgProcs.le.1) goto 30
5575       if (lprn) then
5576         write (iout,'(a)') 'Contact function values:'
5577         do i=nnt,nct-2
5578           write (iout,'(2i3,50(1x,i2,f5.2))')
5579      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5580      &    j=1,num_cont_hb(i))
5581         enddo
5582       endif
5583 C Caution! Following code assumes that electrostatic interactions concerning
5584 C a given atom are split among at most two processors!
5585       CorrelType=477
5586       CorrelID=MyID+1
5587       ldone=.false.
5588       do i=1,max_cont
5589         do j=1,max_dim
5590           buffer(i,j)=0.0D0
5591         enddo
5592       enddo
5593       mm=mod(MyRank,2)
5594 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5595       if (mm) 20,20,10
5596    10 continue
5597 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5598       if (MyRank.gt.0) then
5599 C Send correlation contributions to the preceding processor
5600         msglen=msglen1
5601         nn=num_cont_hb(iatel_s)
5602         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5603 cd      write (iout,*) 'The BUFFER array:'
5604 cd      do i=1,nn
5605 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5606 cd      enddo
5607         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5608           msglen=msglen2
5609             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5610 C Clear the contacts of the atom passed to the neighboring processor
5611         nn=num_cont_hb(iatel_s+1)
5612 cd      do i=1,nn
5613 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5614 cd      enddo
5615             num_cont_hb(iatel_s)=0
5616         endif
5617 cd      write (iout,*) 'Processor ',MyID,MyRank,
5618 cd   & ' is sending correlation contribution to processor',MyID-1,
5619 cd   & ' msglen=',msglen
5620 cd      write (*,*) 'Processor ',MyID,MyRank,
5621 cd   & ' is sending correlation contribution to processor',MyID-1,
5622 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5623         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5624 cd      write (iout,*) 'Processor ',MyID,
5625 cd   & ' has sent correlation contribution to processor',MyID-1,
5626 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5627 cd      write (*,*) 'Processor ',MyID,
5628 cd   & ' has sent correlation contribution to processor',MyID-1,
5629 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5630         msglen=msglen1
5631       endif ! (MyRank.gt.0)
5632       if (ldone) goto 30
5633       ldone=.true.
5634    20 continue
5635 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5636       if (MyRank.lt.fgProcs-1) then
5637 C Receive correlation contributions from the next processor
5638         msglen=msglen1
5639         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5640 cd      write (iout,*) 'Processor',MyID,
5641 cd   & ' is receiving correlation contribution from processor',MyID+1,
5642 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5643 cd      write (*,*) 'Processor',MyID,
5644 cd   & ' is receiving correlation contribution from processor',MyID+1,
5645 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5646         nbytes=-1
5647         do while (nbytes.le.0)
5648           call mp_probe(MyID+1,CorrelType,nbytes)
5649         enddo
5650 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5651         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5652 cd      write (iout,*) 'Processor',MyID,
5653 cd   & ' has received correlation contribution from processor',MyID+1,
5654 cd   & ' msglen=',msglen,' nbytes=',nbytes
5655 cd      write (iout,*) 'The received BUFFER array:'
5656 cd      do i=1,max_cont
5657 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5658 cd      enddo
5659         if (msglen.eq.msglen1) then
5660           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5661         else if (msglen.eq.msglen2)  then
5662           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5663           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5664         else
5665           write (iout,*)
5666      & 'ERROR!!!! message length changed while processing correlations.'
5667           write (*,*)
5668      & 'ERROR!!!! message length changed while processing correlations.'
5669           call mp_stopall(Error)
5670         endif ! msglen.eq.msglen1
5671       endif ! MyRank.lt.fgProcs-1
5672       if (ldone) goto 30
5673       ldone=.true.
5674       goto 10
5675    30 continue
5676 #endif
5677       if (lprn) then
5678         write (iout,'(a)') 'Contact function values:'
5679         do i=nnt,nct-2
5680           write (iout,'(2i3,50(1x,i2,f5.2))')
5681      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5682      &    j=1,num_cont_hb(i))
5683         enddo
5684       endif
5685       ecorr=0.0D0
5686       ecorr5=0.0d0
5687       ecorr6=0.0d0
5688 C Remove the loop below after debugging !!!
5689       do i=nnt,nct
5690         do j=1,3
5691           gradcorr(j,i)=0.0D0
5692           gradxorr(j,i)=0.0D0
5693         enddo
5694       enddo
5695 C Calculate the dipole-dipole interaction energies
5696       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5697       do i=iatel_s,iatel_e+1
5698         num_conti=num_cont_hb(i)
5699         do jj=1,num_conti
5700           j=jcont_hb(jj,i)
5701           call dipole(i,j,jj)
5702         enddo
5703       enddo
5704       endif
5705 C Calculate the local-electrostatic correlation terms
5706       do i=iatel_s,iatel_e+1
5707         i1=i+1
5708         num_conti=num_cont_hb(i)
5709         num_conti1=num_cont_hb(i+1)
5710         do jj=1,num_conti
5711           j=jcont_hb(jj,i)
5712           do kk=1,num_conti1
5713             j1=jcont_hb(kk,i1)
5714 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5715 c     &         ' jj=',jj,' kk=',kk
5716             if (j1.eq.j+1 .or. j1.eq.j-1) then
5717 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5718 C The system gains extra energy.
5719               n_corr=n_corr+1
5720               sqd1=dsqrt(d_cont(jj,i))
5721               sqd2=dsqrt(d_cont(kk,i1))
5722               sred_geom = sqd1*sqd2
5723               IF (sred_geom.lt.cutoff_corr) THEN
5724                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5725      &            ekont,fprimcont)
5726 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5727 c     &         ' jj=',jj,' kk=',kk
5728                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5729                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5730                 do l=1,3
5731                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5732                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5733                 enddo
5734                 n_corr1=n_corr1+1
5735 cd               write (iout,*) 'sred_geom=',sred_geom,
5736 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5737                 call calc_eello(i,j,i+1,j1,jj,kk)
5738                 if (wcorr4.gt.0.0d0)
5739      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5740                 if (wcorr5.gt.0.0d0)
5741      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5742 c                print *,"wcorr5",ecorr5
5743 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5744 cd                write(2,*)'ijkl',i,j,i+1,j1
5745                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5746      &               .or. wturn6.eq.0.0d0))then
5747 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5748 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5749 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5750 c     &            'ecorr6=',ecorr6, wcorr6
5751 cd                write (iout,'(4e15.5)') sred_geom,
5752 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5753 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5754 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5755                 else if (wturn6.gt.0.0d0
5756      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5757 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5758                   eturn6=eturn6+eello_turn6(i,jj,kk)
5759 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5760                 endif
5761               ENDIF
5762 1111          continue
5763             else if (j1.eq.j) then
5764 C Contacts I-J and I-(J+1) occur simultaneously.
5765 C The system loses extra energy.
5766 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5767             endif
5768           enddo ! kk
5769           do kk=1,num_conti
5770             j1=jcont_hb(kk,i)
5771 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5772 c    &         ' jj=',jj,' kk=',kk
5773             if (j1.eq.j+1) then
5774 C Contacts I-J and (I+1)-J occur simultaneously.
5775 C The system loses extra energy.
5776 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5777             endif ! j1==j+1
5778           enddo ! kk
5779         enddo ! jj
5780       enddo ! i
5781       return
5782       end
5783 c------------------------------------------------------------------------------
5784       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5785       implicit real*8 (a-h,o-z)
5786       include 'DIMENSIONS'
5787       include 'COMMON.IOUNITS'
5788       include 'COMMON.DERIV'
5789       include 'COMMON.INTERACT'
5790       include 'COMMON.CONTACTS'
5791       double precision gx(3),gx1(3)
5792       logical lprn
5793       lprn=.false.
5794       eij=facont_hb(jj,i)
5795       ekl=facont_hb(kk,k)
5796       ees0pij=ees0p(jj,i)
5797       ees0pkl=ees0p(kk,k)
5798       ees0mij=ees0m(jj,i)
5799       ees0mkl=ees0m(kk,k)
5800       ekont=eij*ekl
5801       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5802 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5803 C Following 4 lines for diagnostics.
5804 cd    ees0pkl=0.0D0
5805 cd    ees0pij=1.0D0
5806 cd    ees0mkl=0.0D0
5807 cd    ees0mij=1.0D0
5808 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5809 c    &   ' and',k,l
5810 c     write (iout,*)'Contacts have occurred for peptide groups',
5811 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5812 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5813 C Calculate the multi-body contribution to energy.
5814       ecorr=ecorr+ekont*ees
5815       if (calc_grad) then
5816 C Calculate multi-body contributions to the gradient.
5817       do ll=1,3
5818         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5819         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5820      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5821      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5822         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5823      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5824      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5825         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5826         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5827      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5828      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5829         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5830      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5831      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5832       enddo
5833       do m=i+1,j-1
5834         do ll=1,3
5835           gradcorr(ll,m)=gradcorr(ll,m)+
5836      &     ees*ekl*gacont_hbr(ll,jj,i)-
5837      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5838      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5839         enddo
5840       enddo
5841       do m=k+1,l-1
5842         do ll=1,3
5843           gradcorr(ll,m)=gradcorr(ll,m)+
5844      &     ees*eij*gacont_hbr(ll,kk,k)-
5845      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5846      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5847         enddo
5848       enddo
5849       endif
5850       ehbcorr=ekont*ees
5851       return
5852       end
5853 C---------------------------------------------------------------------------
5854       subroutine dipole(i,j,jj)
5855       implicit real*8 (a-h,o-z)
5856       include 'DIMENSIONS'
5857       include 'sizesclu.dat'
5858       include 'COMMON.IOUNITS'
5859       include 'COMMON.CHAIN'
5860       include 'COMMON.FFIELD'
5861       include 'COMMON.DERIV'
5862       include 'COMMON.INTERACT'
5863       include 'COMMON.CONTACTS'
5864       include 'COMMON.TORSION'
5865       include 'COMMON.VAR'
5866       include 'COMMON.GEO'
5867       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5868      &  auxmat(2,2)
5869       iti1 = itortyp(itype(i+1))
5870       if (j.lt.nres-1) then
5871         itj1 = itortyp(itype(j+1))
5872       else
5873         itj1=ntortyp+1
5874       endif
5875       do iii=1,2
5876         dipi(iii,1)=Ub2(iii,i)
5877         dipderi(iii)=Ub2der(iii,i)
5878         dipi(iii,2)=b1(iii,iti1)
5879         dipj(iii,1)=Ub2(iii,j)
5880         dipderj(iii)=Ub2der(iii,j)
5881         dipj(iii,2)=b1(iii,itj1)
5882       enddo
5883       kkk=0
5884       do iii=1,2
5885         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5886         do jjj=1,2
5887           kkk=kkk+1
5888           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5889         enddo
5890       enddo
5891       if (.not.calc_grad) return
5892       do kkk=1,5
5893         do lll=1,3
5894           mmm=0
5895           do iii=1,2
5896             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5897      &        auxvec(1))
5898             do jjj=1,2
5899               mmm=mmm+1
5900               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5901             enddo
5902           enddo
5903         enddo
5904       enddo
5905       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5906       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5907       do iii=1,2
5908         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5909       enddo
5910       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5911       do iii=1,2
5912         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5913       enddo
5914       return
5915       end
5916 C---------------------------------------------------------------------------
5917       subroutine calc_eello(i,j,k,l,jj,kk)
5918 C
5919 C This subroutine computes matrices and vectors needed to calculate
5920 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5921 C
5922       implicit real*8 (a-h,o-z)
5923       include 'DIMENSIONS'
5924       include 'sizesclu.dat'
5925       include 'COMMON.IOUNITS'
5926       include 'COMMON.CHAIN'
5927       include 'COMMON.DERIV'
5928       include 'COMMON.INTERACT'
5929       include 'COMMON.CONTACTS'
5930       include 'COMMON.TORSION'
5931       include 'COMMON.VAR'
5932       include 'COMMON.GEO'
5933       include 'COMMON.FFIELD'
5934       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5935      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5936       logical lprn
5937       common /kutas/ lprn
5938 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5939 cd     & ' jj=',jj,' kk=',kk
5940 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5941       do iii=1,2
5942         do jjj=1,2
5943           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5944           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5945         enddo
5946       enddo
5947       call transpose2(aa1(1,1),aa1t(1,1))
5948       call transpose2(aa2(1,1),aa2t(1,1))
5949       do kkk=1,5
5950         do lll=1,3
5951           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5952      &      aa1tder(1,1,lll,kkk))
5953           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5954      &      aa2tder(1,1,lll,kkk))
5955         enddo
5956       enddo
5957       if (l.eq.j+1) then
5958 C parallel orientation of the two CA-CA-CA frames.
5959         if (i.gt.1) then
5960           iti=itortyp(itype(i))
5961         else
5962           iti=ntortyp+1
5963         endif
5964         itk1=itortyp(itype(k+1))
5965         itj=itortyp(itype(j))
5966         if (l.lt.nres-1) then
5967           itl1=itortyp(itype(l+1))
5968         else
5969           itl1=ntortyp+1
5970         endif
5971 C A1 kernel(j+1) A2T
5972 cd        do iii=1,2
5973 cd          write (iout,'(3f10.5,5x,3f10.5)')
5974 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5975 cd        enddo
5976         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5977      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5978      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5979 C Following matrices are needed only for 6-th order cumulants
5980         IF (wcorr6.gt.0.0d0) THEN
5981         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5982      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5983      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5984         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5985      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5986      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5987      &   ADtEAderx(1,1,1,1,1,1))
5988         lprn=.false.
5989         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5990      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5991      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5992      &   ADtEA1derx(1,1,1,1,1,1))
5993         ENDIF
5994 C End 6-th order cumulants
5995 cd        lprn=.false.
5996 cd        if (lprn) then
5997 cd        write (2,*) 'In calc_eello6'
5998 cd        do iii=1,2
5999 cd          write (2,*) 'iii=',iii
6000 cd          do kkk=1,5
6001 cd            write (2,*) 'kkk=',kkk
6002 cd            do jjj=1,2
6003 cd              write (2,'(3(2f10.5),5x)')
6004 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6005 cd            enddo
6006 cd          enddo
6007 cd        enddo
6008 cd        endif
6009         call transpose2(EUgder(1,1,k),auxmat(1,1))
6010         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6011         call transpose2(EUg(1,1,k),auxmat(1,1))
6012         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6013         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6014         do iii=1,2
6015           do kkk=1,5
6016             do lll=1,3
6017               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6018      &          EAEAderx(1,1,lll,kkk,iii,1))
6019             enddo
6020           enddo
6021         enddo
6022 C A1T kernel(i+1) A2
6023         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6024      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6025      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6026 C Following matrices are needed only for 6-th order cumulants
6027         IF (wcorr6.gt.0.0d0) THEN
6028         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6029      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6030      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6031         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6032      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6033      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6034      &   ADtEAderx(1,1,1,1,1,2))
6035         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6036      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6037      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6038      &   ADtEA1derx(1,1,1,1,1,2))
6039         ENDIF
6040 C End 6-th order cumulants
6041         call transpose2(EUgder(1,1,l),auxmat(1,1))
6042         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6043         call transpose2(EUg(1,1,l),auxmat(1,1))
6044         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6045         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6046         do iii=1,2
6047           do kkk=1,5
6048             do lll=1,3
6049               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6050      &          EAEAderx(1,1,lll,kkk,iii,2))
6051             enddo
6052           enddo
6053         enddo
6054 C AEAb1 and AEAb2
6055 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6056 C They are needed only when the fifth- or the sixth-order cumulants are
6057 C indluded.
6058         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6059         call transpose2(AEA(1,1,1),auxmat(1,1))
6060         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6061         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6062         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6063         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6064         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6065         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6066         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6067         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6068         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6069         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6070         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6071         call transpose2(AEA(1,1,2),auxmat(1,1))
6072         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6073         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6074         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6075         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6076         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6077         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6078         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6079         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6080         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6081         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6082         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6083 C Calculate the Cartesian derivatives of the vectors.
6084         do iii=1,2
6085           do kkk=1,5
6086             do lll=1,3
6087               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6088               call matvec2(auxmat(1,1),b1(1,iti),
6089      &          AEAb1derx(1,lll,kkk,iii,1,1))
6090               call matvec2(auxmat(1,1),Ub2(1,i),
6091      &          AEAb2derx(1,lll,kkk,iii,1,1))
6092               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6093      &          AEAb1derx(1,lll,kkk,iii,2,1))
6094               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6095      &          AEAb2derx(1,lll,kkk,iii,2,1))
6096               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6097               call matvec2(auxmat(1,1),b1(1,itj),
6098      &          AEAb1derx(1,lll,kkk,iii,1,2))
6099               call matvec2(auxmat(1,1),Ub2(1,j),
6100      &          AEAb2derx(1,lll,kkk,iii,1,2))
6101               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6102      &          AEAb1derx(1,lll,kkk,iii,2,2))
6103               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6104      &          AEAb2derx(1,lll,kkk,iii,2,2))
6105             enddo
6106           enddo
6107         enddo
6108         ENDIF
6109 C End vectors
6110       else
6111 C Antiparallel orientation of the two CA-CA-CA frames.
6112         if (i.gt.1) then
6113           iti=itortyp(itype(i))
6114         else
6115           iti=ntortyp+1
6116         endif
6117         itk1=itortyp(itype(k+1))
6118         itl=itortyp(itype(l))
6119         itj=itortyp(itype(j))
6120         if (j.lt.nres-1) then
6121           itj1=itortyp(itype(j+1))
6122         else
6123           itj1=ntortyp+1
6124         endif
6125 C A2 kernel(j-1)T A1T
6126         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6127      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6128      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6129 C Following matrices are needed only for 6-th order cumulants
6130         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6131      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6133      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6134      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6135         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6136      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6137      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6138      &   ADtEAderx(1,1,1,1,1,1))
6139         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6140      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6141      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6142      &   ADtEA1derx(1,1,1,1,1,1))
6143         ENDIF
6144 C End 6-th order cumulants
6145         call transpose2(EUgder(1,1,k),auxmat(1,1))
6146         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6147         call transpose2(EUg(1,1,k),auxmat(1,1))
6148         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6149         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6150         do iii=1,2
6151           do kkk=1,5
6152             do lll=1,3
6153               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6154      &          EAEAderx(1,1,lll,kkk,iii,1))
6155             enddo
6156           enddo
6157         enddo
6158 C A2T kernel(i+1)T A1
6159         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6160      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6161      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6162 C Following matrices are needed only for 6-th order cumulants
6163         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6164      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6165         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6166      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6167      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6168         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6169      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6170      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6171      &   ADtEAderx(1,1,1,1,1,2))
6172         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6173      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6174      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6175      &   ADtEA1derx(1,1,1,1,1,2))
6176         ENDIF
6177 C End 6-th order cumulants
6178         call transpose2(EUgder(1,1,j),auxmat(1,1))
6179         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6180         call transpose2(EUg(1,1,j),auxmat(1,1))
6181         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6182         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6183         do iii=1,2
6184           do kkk=1,5
6185             do lll=1,3
6186               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6187      &          EAEAderx(1,1,lll,kkk,iii,2))
6188             enddo
6189           enddo
6190         enddo
6191 C AEAb1 and AEAb2
6192 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6193 C They are needed only when the fifth- or the sixth-order cumulants are
6194 C indluded.
6195         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6196      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6197         call transpose2(AEA(1,1,1),auxmat(1,1))
6198         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6199         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6200         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6201         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6202         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6203         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6204         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6205         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6206         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6207         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6208         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6209         call transpose2(AEA(1,1,2),auxmat(1,1))
6210         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6211         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6212         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6213         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6214         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6215         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6216         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6217         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6218         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6219         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6220         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6221 C Calculate the Cartesian derivatives of the vectors.
6222         do iii=1,2
6223           do kkk=1,5
6224             do lll=1,3
6225               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6226               call matvec2(auxmat(1,1),b1(1,iti),
6227      &          AEAb1derx(1,lll,kkk,iii,1,1))
6228               call matvec2(auxmat(1,1),Ub2(1,i),
6229      &          AEAb2derx(1,lll,kkk,iii,1,1))
6230               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6231      &          AEAb1derx(1,lll,kkk,iii,2,1))
6232               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6233      &          AEAb2derx(1,lll,kkk,iii,2,1))
6234               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6235               call matvec2(auxmat(1,1),b1(1,itl),
6236      &          AEAb1derx(1,lll,kkk,iii,1,2))
6237               call matvec2(auxmat(1,1),Ub2(1,l),
6238      &          AEAb2derx(1,lll,kkk,iii,1,2))
6239               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6240      &          AEAb1derx(1,lll,kkk,iii,2,2))
6241               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6242      &          AEAb2derx(1,lll,kkk,iii,2,2))
6243             enddo
6244           enddo
6245         enddo
6246         ENDIF
6247 C End vectors
6248       endif
6249       return
6250       end
6251 C---------------------------------------------------------------------------
6252       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6253      &  KK,KKderg,AKA,AKAderg,AKAderx)
6254       implicit none
6255       integer nderg
6256       logical transp
6257       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6258      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6259      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6260       integer iii,kkk,lll
6261       integer jjj,mmm
6262       logical lprn
6263       common /kutas/ lprn
6264       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6265       do iii=1,nderg
6266         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6267      &    AKAderg(1,1,iii))
6268       enddo
6269 cd      if (lprn) write (2,*) 'In kernel'
6270       do kkk=1,5
6271 cd        if (lprn) write (2,*) 'kkk=',kkk
6272         do lll=1,3
6273           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6274      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6275 cd          if (lprn) then
6276 cd            write (2,*) 'lll=',lll
6277 cd            write (2,*) 'iii=1'
6278 cd            do jjj=1,2
6279 cd              write (2,'(3(2f10.5),5x)')
6280 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6281 cd            enddo
6282 cd          endif
6283           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6284      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6285 cd          if (lprn) then
6286 cd            write (2,*) 'lll=',lll
6287 cd            write (2,*) 'iii=2'
6288 cd            do jjj=1,2
6289 cd              write (2,'(3(2f10.5),5x)')
6290 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6291 cd            enddo
6292 cd          endif
6293         enddo
6294       enddo
6295       return
6296       end
6297 C---------------------------------------------------------------------------
6298       double precision function eello4(i,j,k,l,jj,kk)
6299       implicit real*8 (a-h,o-z)
6300       include 'DIMENSIONS'
6301       include 'sizesclu.dat'
6302       include 'COMMON.IOUNITS'
6303       include 'COMMON.CHAIN'
6304       include 'COMMON.DERIV'
6305       include 'COMMON.INTERACT'
6306       include 'COMMON.CONTACTS'
6307       include 'COMMON.TORSION'
6308       include 'COMMON.VAR'
6309       include 'COMMON.GEO'
6310       double precision pizda(2,2),ggg1(3),ggg2(3)
6311 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6312 cd        eello4=0.0d0
6313 cd        return
6314 cd      endif
6315 cd      print *,'eello4:',i,j,k,l,jj,kk
6316 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6317 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6318 cold      eij=facont_hb(jj,i)
6319 cold      ekl=facont_hb(kk,k)
6320 cold      ekont=eij*ekl
6321       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6322       if (calc_grad) then
6323 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6324       gcorr_loc(k-1)=gcorr_loc(k-1)
6325      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6326       if (l.eq.j+1) then
6327         gcorr_loc(l-1)=gcorr_loc(l-1)
6328      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6329       else
6330         gcorr_loc(j-1)=gcorr_loc(j-1)
6331      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6332       endif
6333       do iii=1,2
6334         do kkk=1,5
6335           do lll=1,3
6336             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6337      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6338 cd            derx(lll,kkk,iii)=0.0d0
6339           enddo
6340         enddo
6341       enddo
6342 cd      gcorr_loc(l-1)=0.0d0
6343 cd      gcorr_loc(j-1)=0.0d0
6344 cd      gcorr_loc(k-1)=0.0d0
6345 cd      eel4=1.0d0
6346 cd      write (iout,*)'Contacts have occurred for peptide groups',
6347 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6348 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6349       if (j.lt.nres-1) then
6350         j1=j+1
6351         j2=j-1
6352       else
6353         j1=j-1
6354         j2=j-2
6355       endif
6356       if (l.lt.nres-1) then
6357         l1=l+1
6358         l2=l-1
6359       else
6360         l1=l-1
6361         l2=l-2
6362       endif
6363       do ll=1,3
6364 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6365         ggg1(ll)=eel4*g_contij(ll,1)
6366         ggg2(ll)=eel4*g_contij(ll,2)
6367         ghalf=0.5d0*ggg1(ll)
6368 cd        ghalf=0.0d0
6369         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6370         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6371         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6372         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6373 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6374         ghalf=0.5d0*ggg2(ll)
6375 cd        ghalf=0.0d0
6376         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6377         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6378         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6379         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6380       enddo
6381 cd      goto 1112
6382       do m=i+1,j-1
6383         do ll=1,3
6384 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6385           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6386         enddo
6387       enddo
6388       do m=k+1,l-1
6389         do ll=1,3
6390 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6391           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6392         enddo
6393       enddo
6394 1112  continue
6395       do m=i+2,j2
6396         do ll=1,3
6397           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6398         enddo
6399       enddo
6400       do m=k+2,l2
6401         do ll=1,3
6402           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6403         enddo
6404       enddo
6405 cd      do iii=1,nres-3
6406 cd        write (2,*) iii,gcorr_loc(iii)
6407 cd      enddo
6408       endif
6409       eello4=ekont*eel4
6410 cd      write (2,*) 'ekont',ekont
6411 cd      write (iout,*) 'eello4',ekont*eel4
6412       return
6413       end
6414 C---------------------------------------------------------------------------
6415       double precision function eello5(i,j,k,l,jj,kk)
6416       implicit real*8 (a-h,o-z)
6417       include 'DIMENSIONS'
6418       include 'sizesclu.dat'
6419       include 'COMMON.IOUNITS'
6420       include 'COMMON.CHAIN'
6421       include 'COMMON.DERIV'
6422       include 'COMMON.INTERACT'
6423       include 'COMMON.CONTACTS'
6424       include 'COMMON.TORSION'
6425       include 'COMMON.VAR'
6426       include 'COMMON.GEO'
6427       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6428       double precision ggg1(3),ggg2(3)
6429 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6430 C                                                                              C
6431 C                            Parallel chains                                   C
6432 C                                                                              C
6433 C          o             o                   o             o                   C
6434 C         /l\           / \             \   / \           / \   /              C
6435 C        /   \         /   \             \ /   \         /   \ /               C
6436 C       j| o |l1       | o |              o| o |         | o |o                C
6437 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6438 C      \i/   \         /   \ /             /   \         /   \                 C
6439 C       o    k1             o                                                  C
6440 C         (I)          (II)                (III)          (IV)                 C
6441 C                                                                              C
6442 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6443 C                                                                              C
6444 C                            Antiparallel chains                               C
6445 C                                                                              C
6446 C          o             o                   o             o                   C
6447 C         /j\           / \             \   / \           / \   /              C
6448 C        /   \         /   \             \ /   \         /   \ /               C
6449 C      j1| o |l        | o |              o| o |         | o |o                C
6450 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6451 C      \i/   \         /   \ /             /   \         /   \                 C
6452 C       o     k1            o                                                  C
6453 C         (I)          (II)                (III)          (IV)                 C
6454 C                                                                              C
6455 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6456 C                                                                              C
6457 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6458 C                                                                              C
6459 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6460 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6461 cd        eello5=0.0d0
6462 cd        return
6463 cd      endif
6464 cd      write (iout,*)
6465 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6466 cd     &   ' and',k,l
6467       itk=itortyp(itype(k))
6468       itl=itortyp(itype(l))
6469       itj=itortyp(itype(j))
6470       eello5_1=0.0d0
6471       eello5_2=0.0d0
6472       eello5_3=0.0d0
6473       eello5_4=0.0d0
6474 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6475 cd     &   eel5_3_num,eel5_4_num)
6476       do iii=1,2
6477         do kkk=1,5
6478           do lll=1,3
6479             derx(lll,kkk,iii)=0.0d0
6480           enddo
6481         enddo
6482       enddo
6483 cd      eij=facont_hb(jj,i)
6484 cd      ekl=facont_hb(kk,k)
6485 cd      ekont=eij*ekl
6486 cd      write (iout,*)'Contacts have occurred for peptide groups',
6487 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6488 cd      goto 1111
6489 C Contribution from the graph I.
6490 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6491 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6492       call transpose2(EUg(1,1,k),auxmat(1,1))
6493       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6494       vv(1)=pizda(1,1)-pizda(2,2)
6495       vv(2)=pizda(1,2)+pizda(2,1)
6496       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6497      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6498       if (calc_grad) then
6499 C Explicit gradient in virtual-dihedral angles.
6500       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6501      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6502      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6503       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6504       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6505       vv(1)=pizda(1,1)-pizda(2,2)
6506       vv(2)=pizda(1,2)+pizda(2,1)
6507       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6508      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6509      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6510       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6511       vv(1)=pizda(1,1)-pizda(2,2)
6512       vv(2)=pizda(1,2)+pizda(2,1)
6513       if (l.eq.j+1) then
6514         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6515      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6517       else
6518         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6519      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6520      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6521       endif
6522 C Cartesian gradient
6523       do iii=1,2
6524         do kkk=1,5
6525           do lll=1,3
6526             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6527      &        pizda(1,1))
6528             vv(1)=pizda(1,1)-pizda(2,2)
6529             vv(2)=pizda(1,2)+pizda(2,1)
6530             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6531      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6532      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6533           enddo
6534         enddo
6535       enddo
6536 c      goto 1112
6537       endif
6538 c1111  continue
6539 C Contribution from graph II
6540       call transpose2(EE(1,1,itk),auxmat(1,1))
6541       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6542       vv(1)=pizda(1,1)+pizda(2,2)
6543       vv(2)=pizda(2,1)-pizda(1,2)
6544       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6545      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6546       if (calc_grad) then
6547 C Explicit gradient in virtual-dihedral angles.
6548       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6549      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6550       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6551       vv(1)=pizda(1,1)+pizda(2,2)
6552       vv(2)=pizda(2,1)-pizda(1,2)
6553       if (l.eq.j+1) then
6554         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6555      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6556      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6557       else
6558         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6559      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6560      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6561       endif
6562 C Cartesian gradient
6563       do iii=1,2
6564         do kkk=1,5
6565           do lll=1,3
6566             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6567      &        pizda(1,1))
6568             vv(1)=pizda(1,1)+pizda(2,2)
6569             vv(2)=pizda(2,1)-pizda(1,2)
6570             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6571      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6572      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6573           enddo
6574         enddo
6575       enddo
6576 cd      goto 1112
6577       endif
6578 cd1111  continue
6579       if (l.eq.j+1) then
6580 cd        goto 1110
6581 C Parallel orientation
6582 C Contribution from graph III
6583         call transpose2(EUg(1,1,l),auxmat(1,1))
6584         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6585         vv(1)=pizda(1,1)-pizda(2,2)
6586         vv(2)=pizda(1,2)+pizda(2,1)
6587         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6588      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6589         if (calc_grad) then
6590 C Explicit gradient in virtual-dihedral angles.
6591         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6592      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6593      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6594         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6595         vv(1)=pizda(1,1)-pizda(2,2)
6596         vv(2)=pizda(1,2)+pizda(2,1)
6597         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6598      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6599      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6600         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6601         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6602         vv(1)=pizda(1,1)-pizda(2,2)
6603         vv(2)=pizda(1,2)+pizda(2,1)
6604         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6605      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6606      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6607 C Cartesian gradient
6608         do iii=1,2
6609           do kkk=1,5
6610             do lll=1,3
6611               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6612      &          pizda(1,1))
6613               vv(1)=pizda(1,1)-pizda(2,2)
6614               vv(2)=pizda(1,2)+pizda(2,1)
6615               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6616      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6617      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6618             enddo
6619           enddo
6620         enddo
6621 cd        goto 1112
6622         endif
6623 C Contribution from graph IV
6624 cd1110    continue
6625         call transpose2(EE(1,1,itl),auxmat(1,1))
6626         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6627         vv(1)=pizda(1,1)+pizda(2,2)
6628         vv(2)=pizda(2,1)-pizda(1,2)
6629         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6630      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6631         if (calc_grad) then
6632 C Explicit gradient in virtual-dihedral angles.
6633         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6634      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6635         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6636         vv(1)=pizda(1,1)+pizda(2,2)
6637         vv(2)=pizda(2,1)-pizda(1,2)
6638         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6639      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6640      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6641 C Cartesian gradient
6642         do iii=1,2
6643           do kkk=1,5
6644             do lll=1,3
6645               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6646      &          pizda(1,1))
6647               vv(1)=pizda(1,1)+pizda(2,2)
6648               vv(2)=pizda(2,1)-pizda(1,2)
6649               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6650      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6651      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6652             enddo
6653           enddo
6654         enddo
6655         endif
6656       else
6657 C Antiparallel orientation
6658 C Contribution from graph III
6659 c        goto 1110
6660         call transpose2(EUg(1,1,j),auxmat(1,1))
6661         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6662         vv(1)=pizda(1,1)-pizda(2,2)
6663         vv(2)=pizda(1,2)+pizda(2,1)
6664         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6665      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6666         if (calc_grad) then
6667 C Explicit gradient in virtual-dihedral angles.
6668         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6669      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6670      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6671         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6672         vv(1)=pizda(1,1)-pizda(2,2)
6673         vv(2)=pizda(1,2)+pizda(2,1)
6674         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6675      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6676      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6677         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6678         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6679         vv(1)=pizda(1,1)-pizda(2,2)
6680         vv(2)=pizda(1,2)+pizda(2,1)
6681         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6682      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6683      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6684 C Cartesian gradient
6685         do iii=1,2
6686           do kkk=1,5
6687             do lll=1,3
6688               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6689      &          pizda(1,1))
6690               vv(1)=pizda(1,1)-pizda(2,2)
6691               vv(2)=pizda(1,2)+pizda(2,1)
6692               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6693      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6694      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6695             enddo
6696           enddo
6697         enddo
6698 cd        goto 1112
6699         endif
6700 C Contribution from graph IV
6701 1110    continue
6702         call transpose2(EE(1,1,itj),auxmat(1,1))
6703         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6704         vv(1)=pizda(1,1)+pizda(2,2)
6705         vv(2)=pizda(2,1)-pizda(1,2)
6706         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6707      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6708         if (calc_grad) then
6709 C Explicit gradient in virtual-dihedral angles.
6710         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6711      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6712         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6713         vv(1)=pizda(1,1)+pizda(2,2)
6714         vv(2)=pizda(2,1)-pizda(1,2)
6715         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6716      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6717      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6718 C Cartesian gradient
6719         do iii=1,2
6720           do kkk=1,5
6721             do lll=1,3
6722               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6723      &          pizda(1,1))
6724               vv(1)=pizda(1,1)+pizda(2,2)
6725               vv(2)=pizda(2,1)-pizda(1,2)
6726               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6727      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6728      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6729             enddo
6730           enddo
6731         enddo
6732       endif
6733       endif
6734 1112  continue
6735       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6736 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6737 cd        write (2,*) 'ijkl',i,j,k,l
6738 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6739 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6740 cd      endif
6741 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6742 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6743 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6744 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6745       if (calc_grad) then
6746       if (j.lt.nres-1) then
6747         j1=j+1
6748         j2=j-1
6749       else
6750         j1=j-1
6751         j2=j-2
6752       endif
6753       if (l.lt.nres-1) then
6754         l1=l+1
6755         l2=l-1
6756       else
6757         l1=l-1
6758         l2=l-2
6759       endif
6760 cd      eij=1.0d0
6761 cd      ekl=1.0d0
6762 cd      ekont=1.0d0
6763 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6764       do ll=1,3
6765         ggg1(ll)=eel5*g_contij(ll,1)
6766         ggg2(ll)=eel5*g_contij(ll,2)
6767 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6768         ghalf=0.5d0*ggg1(ll)
6769 cd        ghalf=0.0d0
6770         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6771         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6772         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6773         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6774 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6775         ghalf=0.5d0*ggg2(ll)
6776 cd        ghalf=0.0d0
6777         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6778         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6779         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6780         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6781       enddo
6782 cd      goto 1112
6783       do m=i+1,j-1
6784         do ll=1,3
6785 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6786           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6787         enddo
6788       enddo
6789       do m=k+1,l-1
6790         do ll=1,3
6791 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6792           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6793         enddo
6794       enddo
6795 c1112  continue
6796       do m=i+2,j2
6797         do ll=1,3
6798           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6799         enddo
6800       enddo
6801       do m=k+2,l2
6802         do ll=1,3
6803           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6804         enddo
6805       enddo
6806 cd      do iii=1,nres-3
6807 cd        write (2,*) iii,g_corr5_loc(iii)
6808 cd      enddo
6809       endif
6810       eello5=ekont*eel5
6811 cd      write (2,*) 'ekont',ekont
6812 cd      write (iout,*) 'eello5',ekont*eel5
6813       return
6814       end
6815 c--------------------------------------------------------------------------
6816       double precision function eello6(i,j,k,l,jj,kk)
6817       implicit real*8 (a-h,o-z)
6818       include 'DIMENSIONS'
6819       include 'sizesclu.dat'
6820       include 'COMMON.IOUNITS'
6821       include 'COMMON.CHAIN'
6822       include 'COMMON.DERIV'
6823       include 'COMMON.INTERACT'
6824       include 'COMMON.CONTACTS'
6825       include 'COMMON.TORSION'
6826       include 'COMMON.VAR'
6827       include 'COMMON.GEO'
6828       include 'COMMON.FFIELD'
6829       double precision ggg1(3),ggg2(3)
6830 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6831 cd        eello6=0.0d0
6832 cd        return
6833 cd      endif
6834 cd      write (iout,*)
6835 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6836 cd     &   ' and',k,l
6837       eello6_1=0.0d0
6838       eello6_2=0.0d0
6839       eello6_3=0.0d0
6840       eello6_4=0.0d0
6841       eello6_5=0.0d0
6842       eello6_6=0.0d0
6843 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6844 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6845       do iii=1,2
6846         do kkk=1,5
6847           do lll=1,3
6848             derx(lll,kkk,iii)=0.0d0
6849           enddo
6850         enddo
6851       enddo
6852 cd      eij=facont_hb(jj,i)
6853 cd      ekl=facont_hb(kk,k)
6854 cd      ekont=eij*ekl
6855 cd      eij=1.0d0
6856 cd      ekl=1.0d0
6857 cd      ekont=1.0d0
6858       if (l.eq.j+1) then
6859         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6860         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6861         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6862         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6863         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6864         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6865       else
6866         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6867         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6868         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6869         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6870         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6871           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6872         else
6873           eello6_5=0.0d0
6874         endif
6875         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6876       endif
6877 C If turn contributions are considered, they will be handled separately.
6878       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6879 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6880 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6881 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6882 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6883 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6884 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6885 cd      goto 1112
6886       if (calc_grad) then
6887       if (j.lt.nres-1) then
6888         j1=j+1
6889         j2=j-1
6890       else
6891         j1=j-1
6892         j2=j-2
6893       endif
6894       if (l.lt.nres-1) then
6895         l1=l+1
6896         l2=l-1
6897       else
6898         l1=l-1
6899         l2=l-2
6900       endif
6901       do ll=1,3
6902         ggg1(ll)=eel6*g_contij(ll,1)
6903         ggg2(ll)=eel6*g_contij(ll,2)
6904 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6905         ghalf=0.5d0*ggg1(ll)
6906 cd        ghalf=0.0d0
6907         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6908         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6909         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6910         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6911         ghalf=0.5d0*ggg2(ll)
6912 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6913 cd        ghalf=0.0d0
6914         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6915         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6916         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6917         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6918       enddo
6919 cd      goto 1112
6920       do m=i+1,j-1
6921         do ll=1,3
6922 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6923           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6924         enddo
6925       enddo
6926       do m=k+1,l-1
6927         do ll=1,3
6928 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6929           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6930         enddo
6931       enddo
6932 1112  continue
6933       do m=i+2,j2
6934         do ll=1,3
6935           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6936         enddo
6937       enddo
6938       do m=k+2,l2
6939         do ll=1,3
6940           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6941         enddo
6942       enddo
6943 cd      do iii=1,nres-3
6944 cd        write (2,*) iii,g_corr6_loc(iii)
6945 cd      enddo
6946       endif
6947       eello6=ekont*eel6
6948 cd      write (2,*) 'ekont',ekont
6949 cd      write (iout,*) 'eello6',ekont*eel6
6950       return
6951       end
6952 c--------------------------------------------------------------------------
6953       double precision function eello6_graph1(i,j,k,l,imat,swap)
6954       implicit real*8 (a-h,o-z)
6955       include 'DIMENSIONS'
6956       include 'sizesclu.dat'
6957       include 'COMMON.IOUNITS'
6958       include 'COMMON.CHAIN'
6959       include 'COMMON.DERIV'
6960       include 'COMMON.INTERACT'
6961       include 'COMMON.CONTACTS'
6962       include 'COMMON.TORSION'
6963       include 'COMMON.VAR'
6964       include 'COMMON.GEO'
6965       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6966       logical swap
6967       logical lprn
6968       common /kutas/ lprn
6969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6970 C                                                                              C
6971 C      Parallel       Antiparallel                                             C
6972 C                                                                              C
6973 C          o             o                                                     C
6974 C         /l\           /j\                                                    C
6975 C        /   \         /   \                                                   C
6976 C       /| o |         | o |\                                                  C
6977 C     \ j|/k\|  /   \  |/k\|l /                                                C
6978 C      \ /   \ /     \ /   \ /                                                 C
6979 C       o     o       o     o                                                  C
6980 C       i             i                                                        C
6981 C                                                                              C
6982 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6983       itk=itortyp(itype(k))
6984       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6985       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6986       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6987       call transpose2(EUgC(1,1,k),auxmat(1,1))
6988       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6989       vv1(1)=pizda1(1,1)-pizda1(2,2)
6990       vv1(2)=pizda1(1,2)+pizda1(2,1)
6991       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6992       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6993       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6994       s5=scalar2(vv(1),Dtobr2(1,i))
6995 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6996       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6997       if (.not. calc_grad) return
6998       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6999      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7000      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7001      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7002      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7003      & +scalar2(vv(1),Dtobr2der(1,i)))
7004       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7005       vv1(1)=pizda1(1,1)-pizda1(2,2)
7006       vv1(2)=pizda1(1,2)+pizda1(2,1)
7007       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7008       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7009       if (l.eq.j+1) then
7010         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7011      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7012      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7013      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7014      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7015       else
7016         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7017      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7018      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7019      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7020      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7021       endif
7022       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7023       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7024       vv1(1)=pizda1(1,1)-pizda1(2,2)
7025       vv1(2)=pizda1(1,2)+pizda1(2,1)
7026       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7027      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7028      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7029      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7030       do iii=1,2
7031         if (swap) then
7032           ind=3-iii
7033         else
7034           ind=iii
7035         endif
7036         do kkk=1,5
7037           do lll=1,3
7038             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7039             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7040             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7041             call transpose2(EUgC(1,1,k),auxmat(1,1))
7042             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7043      &        pizda1(1,1))
7044             vv1(1)=pizda1(1,1)-pizda1(2,2)
7045             vv1(2)=pizda1(1,2)+pizda1(2,1)
7046             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7047             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7048      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7049             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7050      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7051             s5=scalar2(vv(1),Dtobr2(1,i))
7052             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7053           enddo
7054         enddo
7055       enddo
7056       return
7057       end
7058 c----------------------------------------------------------------------------
7059       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7060       implicit real*8 (a-h,o-z)
7061       include 'DIMENSIONS'
7062       include 'sizesclu.dat'
7063       include 'COMMON.IOUNITS'
7064       include 'COMMON.CHAIN'
7065       include 'COMMON.DERIV'
7066       include 'COMMON.INTERACT'
7067       include 'COMMON.CONTACTS'
7068       include 'COMMON.TORSION'
7069       include 'COMMON.VAR'
7070       include 'COMMON.GEO'
7071       logical swap
7072       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7073      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7074       logical lprn
7075       common /kutas/ lprn
7076 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7077 C                                                                              C
7078 C      Parallel       Antiparallel                                             C
7079 C                                                                              C
7080 C          o             o                                                     C
7081 C     \   /l\           /j\   /                                                C
7082 C      \ /   \         /   \ /                                                 C
7083 C       o| o |         | o |o                                                  C
7084 C     \ j|/k\|      \  |/k\|l                                                  C
7085 C      \ /   \       \ /   \                                                   C
7086 C       o             o                                                        C
7087 C       i             i                                                        C
7088 C                                                                              C
7089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7090 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7091 C AL 7/4/01 s1 would occur in the sixth-order moment,
7092 C           but not in a cluster cumulant
7093 #ifdef MOMENT
7094       s1=dip(1,jj,i)*dip(1,kk,k)
7095 #endif
7096       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7097       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7098       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7099       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7100       call transpose2(EUg(1,1,k),auxmat(1,1))
7101       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7102       vv(1)=pizda(1,1)-pizda(2,2)
7103       vv(2)=pizda(1,2)+pizda(2,1)
7104       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7105 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7106 #ifdef MOMENT
7107       eello6_graph2=-(s1+s2+s3+s4)
7108 #else
7109       eello6_graph2=-(s2+s3+s4)
7110 #endif
7111 c      eello6_graph2=-s3
7112       if (.not. calc_grad) return
7113 C Derivatives in gamma(i-1)
7114       if (i.gt.1) then
7115 #ifdef MOMENT
7116         s1=dipderg(1,jj,i)*dip(1,kk,k)
7117 #endif
7118         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7119         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7120         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7121         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7122 #ifdef MOMENT
7123         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7124 #else
7125         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7126 #endif
7127 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7128       endif
7129 C Derivatives in gamma(k-1)
7130 #ifdef MOMENT
7131       s1=dip(1,jj,i)*dipderg(1,kk,k)
7132 #endif
7133       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7134       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7135       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7136       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7137       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7138       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7139       vv(1)=pizda(1,1)-pizda(2,2)
7140       vv(2)=pizda(1,2)+pizda(2,1)
7141       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7142 #ifdef MOMENT
7143       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7144 #else
7145       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7146 #endif
7147 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7148 C Derivatives in gamma(j-1) or gamma(l-1)
7149       if (j.gt.1) then
7150 #ifdef MOMENT
7151         s1=dipderg(3,jj,i)*dip(1,kk,k)
7152 #endif
7153         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7154         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7155         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7156         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7157         vv(1)=pizda(1,1)-pizda(2,2)
7158         vv(2)=pizda(1,2)+pizda(2,1)
7159         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7160 #ifdef MOMENT
7161         if (swap) then
7162           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7163         else
7164           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7165         endif
7166 #endif
7167         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7168 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7169       endif
7170 C Derivatives in gamma(l-1) or gamma(j-1)
7171       if (l.gt.1) then
7172 #ifdef MOMENT
7173         s1=dip(1,jj,i)*dipderg(3,kk,k)
7174 #endif
7175         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7176         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7177         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7178         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7179         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7180         vv(1)=pizda(1,1)-pizda(2,2)
7181         vv(2)=pizda(1,2)+pizda(2,1)
7182         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7183 #ifdef MOMENT
7184         if (swap) then
7185           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7186         else
7187           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7188         endif
7189 #endif
7190         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7191 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7192       endif
7193 C Cartesian derivatives.
7194       if (lprn) then
7195         write (2,*) 'In eello6_graph2'
7196         do iii=1,2
7197           write (2,*) 'iii=',iii
7198           do kkk=1,5
7199             write (2,*) 'kkk=',kkk
7200             do jjj=1,2
7201               write (2,'(3(2f10.5),5x)')
7202      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7203             enddo
7204           enddo
7205         enddo
7206       endif
7207       do iii=1,2
7208         do kkk=1,5
7209           do lll=1,3
7210 #ifdef MOMENT
7211             if (iii.eq.1) then
7212               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7213             else
7214               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7215             endif
7216 #endif
7217             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7218      &        auxvec(1))
7219             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7220             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7221      &        auxvec(1))
7222             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7223             call transpose2(EUg(1,1,k),auxmat(1,1))
7224             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7225      &        pizda(1,1))
7226             vv(1)=pizda(1,1)-pizda(2,2)
7227             vv(2)=pizda(1,2)+pizda(2,1)
7228             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7229 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7230 #ifdef MOMENT
7231             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7232 #else
7233             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7234 #endif
7235             if (swap) then
7236               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7237             else
7238               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7239             endif
7240           enddo
7241         enddo
7242       enddo
7243       return
7244       end
7245 c----------------------------------------------------------------------------
7246       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7247       implicit real*8 (a-h,o-z)
7248       include 'DIMENSIONS'
7249       include 'sizesclu.dat'
7250       include 'COMMON.IOUNITS'
7251       include 'COMMON.CHAIN'
7252       include 'COMMON.DERIV'
7253       include 'COMMON.INTERACT'
7254       include 'COMMON.CONTACTS'
7255       include 'COMMON.TORSION'
7256       include 'COMMON.VAR'
7257       include 'COMMON.GEO'
7258       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7259       logical swap
7260 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7261 C                                                                              C
7262 C      Parallel       Antiparallel                                             C
7263 C                                                                              C
7264 C          o             o                                                     C
7265 C         /l\   /   \   /j\                                                    C
7266 C        /   \ /     \ /   \                                                   C
7267 C       /| o |o       o| o |\                                                  C
7268 C       j|/k\|  /      |/k\|l /                                                C
7269 C        /   \ /       /   \ /                                                 C
7270 C       /     o       /     o                                                  C
7271 C       i             i                                                        C
7272 C                                                                              C
7273 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7274 C
7275 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7276 C           energy moment and not to the cluster cumulant.
7277       iti=itortyp(itype(i))
7278       if (j.lt.nres-1) then
7279         itj1=itortyp(itype(j+1))
7280       else
7281         itj1=ntortyp+1
7282       endif
7283       itk=itortyp(itype(k))
7284       itk1=itortyp(itype(k+1))
7285       if (l.lt.nres-1) then
7286         itl1=itortyp(itype(l+1))
7287       else
7288         itl1=ntortyp+1
7289       endif
7290 #ifdef MOMENT
7291       s1=dip(4,jj,i)*dip(4,kk,k)
7292 #endif
7293       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7294       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7295       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7296       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7297       call transpose2(EE(1,1,itk),auxmat(1,1))
7298       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7299       vv(1)=pizda(1,1)+pizda(2,2)
7300       vv(2)=pizda(2,1)-pizda(1,2)
7301       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7302 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7303 #ifdef MOMENT
7304       eello6_graph3=-(s1+s2+s3+s4)
7305 #else
7306       eello6_graph3=-(s2+s3+s4)
7307 #endif
7308 c      eello6_graph3=-s4
7309       if (.not. calc_grad) return
7310 C Derivatives in gamma(k-1)
7311       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7312       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7313       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7314       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7315 C Derivatives in gamma(l-1)
7316       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7317       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7318       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7319       vv(1)=pizda(1,1)+pizda(2,2)
7320       vv(2)=pizda(2,1)-pizda(1,2)
7321       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7322       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7323 C Cartesian derivatives.
7324       do iii=1,2
7325         do kkk=1,5
7326           do lll=1,3
7327 #ifdef MOMENT
7328             if (iii.eq.1) then
7329               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7330             else
7331               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7332             endif
7333 #endif
7334             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7335      &        auxvec(1))
7336             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7337             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7338      &        auxvec(1))
7339             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7340             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7341      &        pizda(1,1))
7342             vv(1)=pizda(1,1)+pizda(2,2)
7343             vv(2)=pizda(2,1)-pizda(1,2)
7344             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7345 #ifdef MOMENT
7346             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7347 #else
7348             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7349 #endif
7350             if (swap) then
7351               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7352             else
7353               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7354             endif
7355 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7356           enddo
7357         enddo
7358       enddo
7359       return
7360       end
7361 c----------------------------------------------------------------------------
7362       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7363       implicit real*8 (a-h,o-z)
7364       include 'DIMENSIONS'
7365       include 'sizesclu.dat'
7366       include 'COMMON.IOUNITS'
7367       include 'COMMON.CHAIN'
7368       include 'COMMON.DERIV'
7369       include 'COMMON.INTERACT'
7370       include 'COMMON.CONTACTS'
7371       include 'COMMON.TORSION'
7372       include 'COMMON.VAR'
7373       include 'COMMON.GEO'
7374       include 'COMMON.FFIELD'
7375       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7376      & auxvec1(2),auxmat1(2,2)
7377       logical swap
7378 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7379 C                                                                              C
7380 C      Parallel       Antiparallel                                             C
7381 C                                                                              C
7382 C          o             o                                                     C
7383 C         /l\   /   \   /j\                                                    C
7384 C        /   \ /     \ /   \                                                   C
7385 C       /| o |o       o| o |\                                                  C
7386 C     \ j|/k\|      \  |/k\|l                                                  C
7387 C      \ /   \       \ /   \                                                   C
7388 C       o     \       o     \                                                  C
7389 C       i             i                                                        C
7390 C                                                                              C
7391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7392 C
7393 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7394 C           energy moment and not to the cluster cumulant.
7395 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7396       iti=itortyp(itype(i))
7397       itj=itortyp(itype(j))
7398       if (j.lt.nres-1) then
7399         itj1=itortyp(itype(j+1))
7400       else
7401         itj1=ntortyp+1
7402       endif
7403       itk=itortyp(itype(k))
7404       if (k.lt.nres-1) then
7405         itk1=itortyp(itype(k+1))
7406       else
7407         itk1=ntortyp+1
7408       endif
7409       itl=itortyp(itype(l))
7410       if (l.lt.nres-1) then
7411         itl1=itortyp(itype(l+1))
7412       else
7413         itl1=ntortyp+1
7414       endif
7415 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7416 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7417 cd     & ' itl',itl,' itl1',itl1
7418 #ifdef MOMENT
7419       if (imat.eq.1) then
7420         s1=dip(3,jj,i)*dip(3,kk,k)
7421       else
7422         s1=dip(2,jj,j)*dip(2,kk,l)
7423       endif
7424 #endif
7425       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7426       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7427       if (j.eq.l+1) then
7428         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7429         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7430       else
7431         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7432         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7433       endif
7434       call transpose2(EUg(1,1,k),auxmat(1,1))
7435       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7436       vv(1)=pizda(1,1)-pizda(2,2)
7437       vv(2)=pizda(2,1)+pizda(1,2)
7438       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7439 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7440 #ifdef MOMENT
7441       eello6_graph4=-(s1+s2+s3+s4)
7442 #else
7443       eello6_graph4=-(s2+s3+s4)
7444 #endif
7445       if (.not. calc_grad) return
7446 C Derivatives in gamma(i-1)
7447       if (i.gt.1) then
7448 #ifdef MOMENT
7449         if (imat.eq.1) then
7450           s1=dipderg(2,jj,i)*dip(3,kk,k)
7451         else
7452           s1=dipderg(4,jj,j)*dip(2,kk,l)
7453         endif
7454 #endif
7455         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7456         if (j.eq.l+1) then
7457           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7458           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7459         else
7460           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7461           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7462         endif
7463         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7464         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7465 cd          write (2,*) 'turn6 derivatives'
7466 #ifdef MOMENT
7467           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7468 #else
7469           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7470 #endif
7471         else
7472 #ifdef MOMENT
7473           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7474 #else
7475           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7476 #endif
7477         endif
7478       endif
7479 C Derivatives in gamma(k-1)
7480 #ifdef MOMENT
7481       if (imat.eq.1) then
7482         s1=dip(3,jj,i)*dipderg(2,kk,k)
7483       else
7484         s1=dip(2,jj,j)*dipderg(4,kk,l)
7485       endif
7486 #endif
7487       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7488       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7489       if (j.eq.l+1) then
7490         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7491         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7492       else
7493         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7494         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7495       endif
7496       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7497       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7498       vv(1)=pizda(1,1)-pizda(2,2)
7499       vv(2)=pizda(2,1)+pizda(1,2)
7500       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7501       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7502 #ifdef MOMENT
7503         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7504 #else
7505         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7506 #endif
7507       else
7508 #ifdef MOMENT
7509         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7510 #else
7511         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7512 #endif
7513       endif
7514 C Derivatives in gamma(j-1) or gamma(l-1)
7515       if (l.eq.j+1 .and. l.gt.1) then
7516         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7517         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7518         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7519         vv(1)=pizda(1,1)-pizda(2,2)
7520         vv(2)=pizda(2,1)+pizda(1,2)
7521         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7522         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7523       else if (j.gt.1) then
7524         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7525         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7526         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7527         vv(1)=pizda(1,1)-pizda(2,2)
7528         vv(2)=pizda(2,1)+pizda(1,2)
7529         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7530         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7531           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7532         else
7533           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7534         endif
7535       endif
7536 C Cartesian derivatives.
7537       do iii=1,2
7538         do kkk=1,5
7539           do lll=1,3
7540 #ifdef MOMENT
7541             if (iii.eq.1) then
7542               if (imat.eq.1) then
7543                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7544               else
7545                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7546               endif
7547             else
7548               if (imat.eq.1) then
7549                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7550               else
7551                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7552               endif
7553             endif
7554 #endif
7555             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7556      &        auxvec(1))
7557             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7558             if (j.eq.l+1) then
7559               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7560      &          b1(1,itj1),auxvec(1))
7561               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7562             else
7563               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7564      &          b1(1,itl1),auxvec(1))
7565               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7566             endif
7567             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7568      &        pizda(1,1))
7569             vv(1)=pizda(1,1)-pizda(2,2)
7570             vv(2)=pizda(2,1)+pizda(1,2)
7571             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7572             if (swap) then
7573               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7574 #ifdef MOMENT
7575                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7576      &             -(s1+s2+s4)
7577 #else
7578                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7579      &             -(s2+s4)
7580 #endif
7581                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7582               else
7583 #ifdef MOMENT
7584                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7585 #else
7586                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7587 #endif
7588                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7589               endif
7590             else
7591 #ifdef MOMENT
7592               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7593 #else
7594               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7595 #endif
7596               if (l.eq.j+1) then
7597                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7598               else
7599                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7600               endif
7601             endif
7602           enddo
7603         enddo
7604       enddo
7605       return
7606       end
7607 c----------------------------------------------------------------------------
7608       double precision function eello_turn6(i,jj,kk)
7609       implicit real*8 (a-h,o-z)
7610       include 'DIMENSIONS'
7611       include 'sizesclu.dat'
7612       include 'COMMON.IOUNITS'
7613       include 'COMMON.CHAIN'
7614       include 'COMMON.DERIV'
7615       include 'COMMON.INTERACT'
7616       include 'COMMON.CONTACTS'
7617       include 'COMMON.TORSION'
7618       include 'COMMON.VAR'
7619       include 'COMMON.GEO'
7620       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7621      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7622      &  ggg1(3),ggg2(3)
7623       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7624      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7625 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7626 C           the respective energy moment and not to the cluster cumulant.
7627       eello_turn6=0.0d0
7628       j=i+4
7629       k=i+1
7630       l=i+3
7631       iti=itortyp(itype(i))
7632       itk=itortyp(itype(k))
7633       itk1=itortyp(itype(k+1))
7634       itl=itortyp(itype(l))
7635       itj=itortyp(itype(j))
7636 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7637 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7638 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7639 cd        eello6=0.0d0
7640 cd        return
7641 cd      endif
7642 cd      write (iout,*)
7643 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7644 cd     &   ' and',k,l
7645 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7646       do iii=1,2
7647         do kkk=1,5
7648           do lll=1,3
7649             derx_turn(lll,kkk,iii)=0.0d0
7650           enddo
7651         enddo
7652       enddo
7653 cd      eij=1.0d0
7654 cd      ekl=1.0d0
7655 cd      ekont=1.0d0
7656       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7657 cd      eello6_5=0.0d0
7658 cd      write (2,*) 'eello6_5',eello6_5
7659 #ifdef MOMENT
7660       call transpose2(AEA(1,1,1),auxmat(1,1))
7661       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7662       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7663       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7664 #else
7665       s1 = 0.0d0
7666 #endif
7667       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7668       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7669       s2 = scalar2(b1(1,itk),vtemp1(1))
7670 #ifdef MOMENT
7671       call transpose2(AEA(1,1,2),atemp(1,1))
7672       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7673       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7674       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7675 #else
7676       s8=0.0d0
7677 #endif
7678       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7679       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7680       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7681 #ifdef MOMENT
7682       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7683       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7684       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7685       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7686       ss13 = scalar2(b1(1,itk),vtemp4(1))
7687       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7688 #else
7689       s13=0.0d0
7690 #endif
7691 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7692 c      s1=0.0d0
7693 c      s2=0.0d0
7694 c      s8=0.0d0
7695 c      s12=0.0d0
7696 c      s13=0.0d0
7697       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7698       if (calc_grad) then
7699 C Derivatives in gamma(i+2)
7700 #ifdef MOMENT
7701       call transpose2(AEA(1,1,1),auxmatd(1,1))
7702       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7703       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7704       call transpose2(AEAderg(1,1,2),atempd(1,1))
7705       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7706       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7707 #else
7708       s8d=0.0d0
7709 #endif
7710       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7711       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7712       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7713 c      s1d=0.0d0
7714 c      s2d=0.0d0
7715 c      s8d=0.0d0
7716 c      s12d=0.0d0
7717 c      s13d=0.0d0
7718       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7719 C Derivatives in gamma(i+3)
7720 #ifdef MOMENT
7721       call transpose2(AEA(1,1,1),auxmatd(1,1))
7722       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7723       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7724       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7725 #else
7726       s1d=0.0d0
7727 #endif
7728       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7729       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7730       s2d = scalar2(b1(1,itk),vtemp1d(1))
7731 #ifdef MOMENT
7732       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7733       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7734 #endif
7735       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7736 #ifdef MOMENT
7737       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7738       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7739       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7740 #else
7741       s13d=0.0d0
7742 #endif
7743 c      s1d=0.0d0
7744 c      s2d=0.0d0
7745 c      s8d=0.0d0
7746 c      s12d=0.0d0
7747 c      s13d=0.0d0
7748 #ifdef MOMENT
7749       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7750      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7751 #else
7752       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7753      &               -0.5d0*ekont*(s2d+s12d)
7754 #endif
7755 C Derivatives in gamma(i+4)
7756       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7757       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7758       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7759 #ifdef MOMENT
7760       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7761       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7762       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7763 #else
7764       s13d = 0.0d0
7765 #endif
7766 c      s1d=0.0d0
7767 c      s2d=0.0d0
7768 c      s8d=0.0d0
7769 C      s12d=0.0d0
7770 c      s13d=0.0d0
7771 #ifdef MOMENT
7772       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7773 #else
7774       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7775 #endif
7776 C Derivatives in gamma(i+5)
7777 #ifdef MOMENT
7778       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7779       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7780       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7781 #else
7782       s1d = 0.0d0
7783 #endif
7784       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7785       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7786       s2d = scalar2(b1(1,itk),vtemp1d(1))
7787 #ifdef MOMENT
7788       call transpose2(AEA(1,1,2),atempd(1,1))
7789       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7790       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7791 #else
7792       s8d = 0.0d0
7793 #endif
7794       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7795       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7796 #ifdef MOMENT
7797       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7798       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7799       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7800 #else
7801       s13d = 0.0d0
7802 #endif
7803 c      s1d=0.0d0
7804 c      s2d=0.0d0
7805 c      s8d=0.0d0
7806 c      s12d=0.0d0
7807 c      s13d=0.0d0
7808 #ifdef MOMENT
7809       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7810      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7811 #else
7812       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7813      &               -0.5d0*ekont*(s2d+s12d)
7814 #endif
7815 C Cartesian derivatives
7816       do iii=1,2
7817         do kkk=1,5
7818           do lll=1,3
7819 #ifdef MOMENT
7820             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7821             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7822             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7823 #else
7824             s1d = 0.0d0
7825 #endif
7826             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7827             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7828      &          vtemp1d(1))
7829             s2d = scalar2(b1(1,itk),vtemp1d(1))
7830 #ifdef MOMENT
7831             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7832             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7833             s8d = -(atempd(1,1)+atempd(2,2))*
7834      &           scalar2(cc(1,1,itl),vtemp2(1))
7835 #else
7836             s8d = 0.0d0
7837 #endif
7838             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7839      &           auxmatd(1,1))
7840             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7841             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7842 c      s1d=0.0d0
7843 c      s2d=0.0d0
7844 c      s8d=0.0d0
7845 c      s12d=0.0d0
7846 c      s13d=0.0d0
7847 #ifdef MOMENT
7848             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7849      &        - 0.5d0*(s1d+s2d)
7850 #else
7851             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7852      &        - 0.5d0*s2d
7853 #endif
7854 #ifdef MOMENT
7855             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7856      &        - 0.5d0*(s8d+s12d)
7857 #else
7858             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7859      &        - 0.5d0*s12d
7860 #endif
7861           enddo
7862         enddo
7863       enddo
7864 #ifdef MOMENT
7865       do kkk=1,5
7866         do lll=1,3
7867           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7868      &      achuj_tempd(1,1))
7869           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7870           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7871           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7872           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7873           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7874      &      vtemp4d(1))
7875           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7876           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7877           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7878         enddo
7879       enddo
7880 #endif
7881 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7882 cd     &  16*eel_turn6_num
7883 cd      goto 1112
7884       if (j.lt.nres-1) then
7885         j1=j+1
7886         j2=j-1
7887       else
7888         j1=j-1
7889         j2=j-2
7890       endif
7891       if (l.lt.nres-1) then
7892         l1=l+1
7893         l2=l-1
7894       else
7895         l1=l-1
7896         l2=l-2
7897       endif
7898       do ll=1,3
7899         ggg1(ll)=eel_turn6*g_contij(ll,1)
7900         ggg2(ll)=eel_turn6*g_contij(ll,2)
7901         ghalf=0.5d0*ggg1(ll)
7902 cd        ghalf=0.0d0
7903         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7904      &    +ekont*derx_turn(ll,2,1)
7905         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7906         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7907      &    +ekont*derx_turn(ll,4,1)
7908         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7909         ghalf=0.5d0*ggg2(ll)
7910 cd        ghalf=0.0d0
7911         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7912      &    +ekont*derx_turn(ll,2,2)
7913         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7914         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7915      &    +ekont*derx_turn(ll,4,2)
7916         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7917       enddo
7918 cd      goto 1112
7919       do m=i+1,j-1
7920         do ll=1,3
7921           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7922         enddo
7923       enddo
7924       do m=k+1,l-1
7925         do ll=1,3
7926           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7927         enddo
7928       enddo
7929 1112  continue
7930       do m=i+2,j2
7931         do ll=1,3
7932           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7933         enddo
7934       enddo
7935       do m=k+2,l2
7936         do ll=1,3
7937           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7938         enddo
7939       enddo
7940 cd      do iii=1,nres-3
7941 cd        write (2,*) iii,g_corr6_loc(iii)
7942 cd      enddo
7943       endif
7944       eello_turn6=ekont*eel_turn6
7945 cd      write (2,*) 'ekont',ekont
7946 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7947       return
7948       end
7949 crc-------------------------------------------------
7950       SUBROUTINE MATVEC2(A1,V1,V2)
7951       implicit real*8 (a-h,o-z)
7952       include 'DIMENSIONS'
7953       DIMENSION A1(2,2),V1(2),V2(2)
7954 c      DO 1 I=1,2
7955 c        VI=0.0
7956 c        DO 3 K=1,2
7957 c    3     VI=VI+A1(I,K)*V1(K)
7958 c        Vaux(I)=VI
7959 c    1 CONTINUE
7960
7961       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7962       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7963
7964       v2(1)=vaux1
7965       v2(2)=vaux2
7966       END
7967 C---------------------------------------
7968       SUBROUTINE MATMAT2(A1,A2,A3)
7969       implicit real*8 (a-h,o-z)
7970       include 'DIMENSIONS'
7971       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7972 c      DIMENSION AI3(2,2)
7973 c        DO  J=1,2
7974 c          A3IJ=0.0
7975 c          DO K=1,2
7976 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7977 c          enddo
7978 c          A3(I,J)=A3IJ
7979 c       enddo
7980 c      enddo
7981
7982       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7983       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7984       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7985       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7986
7987       A3(1,1)=AI3_11
7988       A3(2,1)=AI3_21
7989       A3(1,2)=AI3_12
7990       A3(2,2)=AI3_22
7991       END
7992
7993 c-------------------------------------------------------------------------
7994       double precision function scalar2(u,v)
7995       implicit none
7996       double precision u(2),v(2)
7997       double precision sc
7998       integer i
7999       scalar2=u(1)*v(1)+u(2)*v(2)
8000       return
8001       end
8002
8003 C-----------------------------------------------------------------------------
8004
8005       subroutine transpose2(a,at)
8006       implicit none
8007       double precision a(2,2),at(2,2)
8008       at(1,1)=a(1,1)
8009       at(1,2)=a(2,1)
8010       at(2,1)=a(1,2)
8011       at(2,2)=a(2,2)
8012       return
8013       end
8014 c--------------------------------------------------------------------------
8015       subroutine transpose(n,a,at)
8016       implicit none
8017       integer n,i,j
8018       double precision a(n,n),at(n,n)
8019       do i=1,n
8020         do j=1,n
8021           at(j,i)=a(i,j)
8022         enddo
8023       enddo
8024       return
8025       end
8026 C---------------------------------------------------------------------------
8027       subroutine prodmat3(a1,a2,kk,transp,prod)
8028       implicit none
8029       integer i,j
8030       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8031       logical transp
8032 crc      double precision auxmat(2,2),prod_(2,2)
8033
8034       if (transp) then
8035 crc        call transpose2(kk(1,1),auxmat(1,1))
8036 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8037 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8038
8039            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8040      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8041            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8042      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8043            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8044      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8045            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8046      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8047
8048       else
8049 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8050 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8051
8052            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8053      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8054            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8055      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8056            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8057      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8058            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8059      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8060
8061       endif
8062 c      call transpose2(a2(1,1),a2t(1,1))
8063
8064 crc      print *,transp
8065 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8066 crc      print *,((prod(i,j),i=1,2),j=1,2)
8067
8068       return
8069       end
8070 C-----------------------------------------------------------------------------
8071       double precision function scalar(u,v)
8072       implicit none
8073       double precision u(3),v(3)
8074       double precision sc
8075       integer i
8076       sc=0.0d0
8077       do i=1,3
8078         sc=sc+u(i)*v(i)
8079       enddo
8080       scalar=sc
8081       return
8082       end
8083