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