source/cluster/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 c     external proc_proc
   7 #ifdef WINPGI
   8 cMS$ATTRIBUTES C ::  proc_proc
   9 #endif
  10
  11       include 'COMMON.IOUNITS'
  12       double precision energia(0:max_ene),energia1(0:max_ene+1)
  13 #ifdef MPL
  14       include 'COMMON.INFO'
  15       external d_vadd
  16       integer ready
  17 #endif
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.CONTROL'
  24
  25       double precision fact(5)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor,fact(1))
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105
 106 c      write(iout,*) "TEST_ENE",constr_homology
 107       if (constr_homology.ge.1) then
 108         call e_modeller(ehomology_constr)
 109       else
 110         ehomology_constr=0.0d0
 111       endif
 112 c      write(iout,*) "TEST_ENE",ehomology_constr
 113
 114 C     BARTEK for dfa test!
 115       if (wdfa_dist.gt.0) call edfad(edfadis)
 116 c      print*, 'edfad is finished!', edfadis
 117       if (wdfa_tor.gt.0) call edfat(edfator)
 118 c      print*, 'edfat is finished!', edfator
 119       if (wdfa_nei.gt.0) call edfan(edfanei)
 120 c      print*, 'edfan is finished!', edfanei
 121       if (wdfa_beta.gt.0) call edfab(edfabet)
 122 c      print*, 'edfab is finished!', edfabet
 123
 124
 125 C     call multibody(ecorr)
 126 C
 127 C Sum the energies
 128 C
 129 #ifdef SPLITELE
 130       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*ees+wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*(ees+evdw1)
 141      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 142      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 143      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 144      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 145      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 146      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 147      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 148      & +wdfa_beta*edfabet
 149 #endif
 150       energia(0)=etot
 151       energia(1)=evdw
 152 #ifdef SCP14
 153       energia(2)=evdw2-evdw2_14
 154       energia(17)=evdw2_14
 155 #else
 156       energia(2)=evdw2
 157       energia(17)=0.0d0
 158 #endif
 159 #ifdef SPLITELE
 160       energia(3)=ees
 161       energia(16)=evdw1
 162 #else
 163       energia(3)=ees+evdw1
 164       energia(16)=0.0d0
 165 #endif
 166       energia(4)=ecorr
 167       energia(5)=ecorr5
 168       energia(6)=ecorr6
 169       energia(7)=eel_loc
 170       energia(8)=eello_turn3
 171       energia(9)=eello_turn4
 172       energia(10)=eturn6
 173       energia(11)=ebe
 174       energia(12)=escloc
 175       energia(13)=etors
 176       energia(14)=etors_d
 177       energia(15)=ehpb
 178       energia(18)=estr
 179       energia(19)=esccor
 180       energia(20)=edihcnstr
 181       energia(21)=ehomology_constr
 182       energia(22)=edfadis
 183       energia(23)=edfator
 184       energia(24)=edfanei
 185       energia(25)=edfabet
 186 cc      if (dyn_ss) call dyn_set_nss
 187 c detecting NaNQ
 188       i=0
 189 #ifdef WINPGI
 190       idumm=proc_proc(etot,i)
 191 #else
 192 c     call proc_proc(etot,i)
 193 #endif
 194       if(i.eq.1)energia(0)=1.0d+99
 195 #ifdef MPL
 196 c     endif
 197 #endif
 198       if (calc_grad) then
 199 C
 200 C Sum up the components of the Cartesian gradient.
 201 C
 202 #ifdef SPLITELE
 203       do i=1,nct
 204         do j=1,3
 205           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 206      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 207      &                wbond*gradb(j,i)+
 208      &                wstrain*ghpbc(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)+
 217      &                wdfa_dist*gdfad(j,i)+
 218      &                wdfa_tor*gdfat(j,i)+
 219      &                wdfa_nei*gdfan(j,i)+
 220      &                wdfa_beta*gdfab(j,i)
 221           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 222      &                  wbond*gradbx(j,i)+
 223      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 224         enddo
 225 #else
 226       do i=1,nct
 227         do j=1,3
 228           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 229      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 230      &                wbond*gradb(j,i)+
 231      &                wcorr*fact(3)*gradcorr(j,i)+
 232      &                wel_loc*fact(2)*gel_loc(j,i)+
 233      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 234      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 235      &                wcorr5*fact(4)*gradcorr5(j,i)+
 236      &                wcorr6*fact(5)*gradcorr6(j,i)+
 237      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 238      &                wsccor*fact(2)*gsccorc(j,i)+
 239      &                wdfa_dist*gdfad(j,i)+
 240      &                wdfa_tor*gdfat(j,i)+
 241      &                wdfa_nei*gdfan(j,i)+
 242      &                wdfa_beta*gdfab(j,i)
 243           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 244      &                  wbond*gradbx(j,i)+
 245      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 246         enddo
 247 #endif
 248 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 249 cd   &        (gradc(k,i),k=1,3)
 250       enddo
 251
 252
 253       do i=1,nres-3
 254 cd        write (iout,*) i,g_corr5_loc(i)
 255         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 256      &   +wcorr5*fact(4)*g_corr5_loc(i)
 257      &   +wcorr6*fact(5)*g_corr6_loc(i)
 258      &   +wturn4*fact(3)*gel_loc_turn4(i)
 259      &   +wturn3*fact(2)*gel_loc_turn3(i)
 260      &   +wturn6*fact(5)*gel_loc_turn6(i)
 261      &   +wel_loc*fact(2)*gel_loc_loc(i)
 262      &   +wsccor*fact(1)*gsccor_loc(i)
 263       enddo
 264       endif
 265 c      call enerprint(energia(0),fact)
 266 cd    call intout
 267 cd    stop
 268       return
 269       end
 270 C------------------------------------------------------------------------
 271       subroutine enerprint(energia,fact)
 272       implicit real*8 (a-h,o-z)
 273       include 'DIMENSIONS'
 274       include 'sizesclu.dat'
 275       include 'COMMON.IOUNITS'
 276       include 'COMMON.FFIELD'
 277       include 'COMMON.SBRIDGE'
 278       double precision energia(0:max_ene),fact(5)
 279       etot=energia(0)
 280       evdw=energia(1)
 281 #ifdef SCP14
 282       evdw2=energia(2)+energia(17)
 283 #else
 284       evdw2=energia(2)
 285 #endif
 286       ees=energia(3)
 287 #ifdef SPLITELE
 288       evdw1=energia(16)
 289 #endif
 290       ecorr=energia(4)
 291       ecorr5=energia(5)
 292       ecorr6=energia(6)
 293       eel_loc=energia(7)
 294       eello_turn3=energia(8)
 295       eello_turn4=energia(9)
 296       eello_turn6=energia(10)
 297       ebe=energia(11)
 298       escloc=energia(12)
 299       etors=energia(13)
 300       etors_d=energia(14)
 301       ehpb=energia(15)
 302       esccor=energia(19)
 303       edihcnstr=energia(20)
 304       estr=energia(18)
 305       ehomology_constr=energia(21)
 306       edfadis=energia(22)
 307       edfator=energia(23)
 308       edfanei=energia(24)
 309       edfabet=energia(25)
 310 #ifdef SPLITELE
 311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 312      &  wvdwpp,
 313      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 314      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 315      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 316      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 317      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 318      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 320      &  wdfa_beta,etot
 321    10 format (/'Virtual-chain energies:'//
 322      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 323      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 324      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 325      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 332      & ' (SS bridges & dist. cnstr.)'/
 333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 341      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 342      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 344      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 345      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 346      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 347      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #else
 350       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 351      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 352      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 353      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 354      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 355      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 356      &  edihcnstr,ehomology_constr,ebr*nss,
 357      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 358      &  wdfa_beta,etot
 359    10 format (/'Virtual-chain energies:'//
 360      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 361      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 362      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 363      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 364      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 365      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 366      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 367      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 368      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 369      & ' (SS bridges & dist. cnstr.)'/
 370      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 372      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 373      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 374      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 375      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 376      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 377      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 378      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 379      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 380      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 381      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 382      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 383      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 384      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 385      & 'ETOT=  ',1pE16.6,' (total)')
 386 #endif
 387       return
 388       end
 389 C-----------------------------------------------------------------------
 390       subroutine elj(evdw)
 391 C
 392 C This subroutine calculates the interaction energy of nonbonded side chains
 393 C assuming the LJ potential of interaction.
 394 C
 395       implicit real*8 (a-h,o-z)
 396       include 'DIMENSIONS'
 397       include 'sizesclu.dat'
 398 c      include "DIMENSIONS.COMPAR"
 399       parameter (accur=1.0d-10)
 400       include 'COMMON.GEO'
 401       include 'COMMON.VAR'
 402       include 'COMMON.LOCAL'
 403       include 'COMMON.CHAIN'
 404       include 'COMMON.DERIV'
 405       include 'COMMON.INTERACT'
 406       include 'COMMON.TORSION'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.NAMES'
 409       include 'COMMON.IOUNITS'
 410       include 'COMMON.CONTACTS'
 411       dimension gg(3)
 412       integer icant
 413       external icant
 414 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 415       evdw=0.0D0
 416       do i=iatsc_s,iatsc_e
 417         itypi=itype(i)
 418         itypi1=itype(i+1)
 419         xi=c(1,nres+i)
 420         yi=c(2,nres+i)
 421         zi=c(3,nres+i)
 422 C Change 12/1/95
 423         num_conti=0
 424 C
 425 C Calculate SC interaction energy.
 426 C
 427         do iint=1,nint_gr(i)
 428 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 429 cd   &                  'iend=',iend(i,iint)
 430           do j=istart(i,iint),iend(i,iint)
 431             itypj=itype(j)
 432             xj=c(1,nres+j)-xi
 433             yj=c(2,nres+j)-yi
 434             zj=c(3,nres+j)-zi
 435 C Change 12/1/95 to calculate four-body interactions
 436             rij=xj*xj+yj*yj+zj*zj
 437             rrij=1.0D0/rij
 438 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 439             eps0ij=eps(itypi,itypj)
 440             fac=rrij**expon2
 441             e1=fac*fac*aa(itypi,itypj)
 442             e2=fac*bb(itypi,itypj)
 443             evdwij=e1+e2
 444             ij=icant(itypi,itypj)
 445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 447 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 449 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 450 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 451             evdw=evdw+evdwij
 452             if (calc_grad) then
 453 C
 454 C Calculate the components of the gradient in DC and X
 455 C
 456             fac=-rrij*(e1+evdwij)
 457             gg(1)=xj*fac
 458             gg(2)=yj*fac
 459             gg(3)=zj*fac
 460             do k=1,3
 461               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 462               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 463             enddo
 464             do k=i,j-1
 465               do l=1,3
 466                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 467               enddo
 468             enddo
 469             endif
 470 C
 471 C 12/1/95, revised on 5/20/97
 472 C
 473 C Calculate the contact function. The ith column of the array JCONT will
 474 C contain the numbers of atoms that make contacts with the atom I (of numbers
 475 C greater than I). The arrays FACONT and GACONT will contain the values of
 476 C the contact function and its derivative.
 477 C
 478 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 479 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 480 C Uncomment next line, if the correlation interactions are contact function only
 481             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 482               rij=dsqrt(rij)
 483               sigij=sigma(itypi,itypj)
 484               r0ij=rs0(itypi,itypj)
 485 C
 486 C Check whether the SC's are not too far to make a contact.
 487 C
 488               rcut=1.5d0*r0ij
 489               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 490 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 491 C
 492               if (fcont.gt.0.0D0) then
 493 C If the SC-SC distance if close to sigma, apply spline.
 494 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 495 cAdam &             fcont1,fprimcont1)
 496 cAdam           fcont1=1.0d0-fcont1
 497 cAdam           if (fcont1.gt.0.0d0) then
 498 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 499 cAdam             fcont=fcont*fcont1
 500 cAdam           endif
 501 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 502 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 503 cga             do k=1,3
 504 cga               gg(k)=gg(k)*eps0ij
 505 cga             enddo
 506 cga             eps0ij=-evdwij*eps0ij
 507 C Uncomment for AL's type of SC correlation interactions.
 508 cadam           eps0ij=-evdwij
 509                 num_conti=num_conti+1
 510                 jcont(num_conti,i)=j
 511                 facont(num_conti,i)=fcont*eps0ij
 512                 fprimcont=eps0ij*fprimcont/rij
 513                 fcont=expon*fcont
 514 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 515 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 516 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 517 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 518                 gacont(1,num_conti,i)=-fprimcont*xj
 519                 gacont(2,num_conti,i)=-fprimcont*yj
 520                 gacont(3,num_conti,i)=-fprimcont*zj
 521 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 522 cd              write (iout,'(2i3,3f10.5)')
 523 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 524               endif
 525             endif
 526           enddo      ! j
 527         enddo        ! iint
 528 C Change 12/1/95
 529         num_cont(i)=num_conti
 530       enddo          ! i
 531       if (calc_grad) then
 532       do i=1,nct
 533         do j=1,3
 534           gvdwc(j,i)=expon*gvdwc(j,i)
 535           gvdwx(j,i)=expon*gvdwx(j,i)
 536         enddo
 537       enddo
 538       endif
 539 C******************************************************************************
 540 C
 541 C                              N O T E !!!
 542 C
 543 C To save time, the factor of EXPON has been extracted from ALL components
 544 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 545 C use!
 546 C
 547 C******************************************************************************
 548       return
 549       end
 550 C-----------------------------------------------------------------------------
 551       subroutine eljk(evdw)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJK potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'sizesclu.dat'
 559 c      include "DIMENSIONS.COMPAR"
 560       include 'COMMON.GEO'
 561       include 'COMMON.VAR'
 562       include 'COMMON.LOCAL'
 563       include 'COMMON.CHAIN'
 564       include 'COMMON.DERIV'
 565       include 'COMMON.INTERACT'
 566       include 'COMMON.IOUNITS'
 567       include 'COMMON.NAMES'
 568       dimension gg(3)
 569       logical scheck
 570       integer icant
 571       external icant
 572 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 573       evdw=0.0D0
 574       do i=iatsc_s,iatsc_e
 575         itypi=itype(i)
 576         itypi1=itype(i+1)
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=itype(j)
 586             xj=c(1,nres+j)-xi
 587             yj=c(2,nres+j)-yi
 588             zj=c(3,nres+j)-zi
 589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 590             fac_augm=rrij**expon
 591             e_augm=augm(itypi,itypj)*fac_augm
 592             r_inv_ij=dsqrt(rrij)
 593             rij=1.0D0/r_inv_ij
 594             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 595             fac=r_shift_inv**expon
 596             e1=fac*fac*aa(itypi,itypj)
 597             e2=fac*bb(itypi,itypj)
 598             evdwij=e_augm+e1+e2
 599             ij=icant(itypi,itypj)
 600 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 601 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 602 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 603 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 604 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 605 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 606 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 607             evdw=evdw+evdwij
 608             if (calc_grad) then
 609 C
 610 C Calculate the components of the gradient in DC and X
 611 C
 612             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 613             gg(1)=xj*fac
 614             gg(2)=yj*fac
 615             gg(3)=zj*fac
 616             do k=1,3
 617               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 618               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 619             enddo
 620             do k=i,j-1
 621               do l=1,3
 622                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 623               enddo
 624             enddo
 625             endif
 626           enddo      ! j
 627         enddo        ! iint
 628       enddo          ! i
 629       if (calc_grad) then
 630       do i=1,nct
 631         do j=1,3
 632           gvdwc(j,i)=expon*gvdwc(j,i)
 633           gvdwx(j,i)=expon*gvdwx(j,i)
 634         enddo
 635       enddo
 636       endif
 637       return
 638       end
 639 C-----------------------------------------------------------------------------
 640       subroutine ebp(evdw)
 641 C
 642 C This subroutine calculates the interaction energy of nonbonded side chains
 643 C assuming the Berne-Pechukas potential of interaction.
 644 C
 645       implicit real*8 (a-h,o-z)
 646       include 'DIMENSIONS'
 647       include 'sizesclu.dat'
 648 c      include "DIMENSIONS.COMPAR"
 649       include 'COMMON.GEO'
 650       include 'COMMON.VAR'
 651       include 'COMMON.LOCAL'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.DERIV'
 654       include 'COMMON.NAMES'
 655       include 'COMMON.INTERACT'
 656       include 'COMMON.IOUNITS'
 657       include 'COMMON.CALC'
 658       common /srutu/ icall
 659 c     double precision rrsave(maxdim)
 660       logical lprn
 661       integer icant
 662       external icant
 663       evdw=0.0D0
 664 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 665       evdw=0.0D0
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=itype(i)
 674         itypi1=itype(i+1)
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678         dxi=dc_norm(1,nres+i)
 679         dyi=dc_norm(2,nres+i)
 680         dzi=dc_norm(3,nres+i)
 681         dsci_inv=vbld_inv(i+nres)
 682 C
 683 C Calculate SC interaction energy.
 684 C
 685         do iint=1,nint_gr(i)
 686           do j=istart(i,iint),iend(i,iint)
 687             ind=ind+1
 688             itypj=itype(j)
 689             dscj_inv=vbld_inv(j+nres)
 690             chi1=chi(itypi,itypj)
 691             chi2=chi(itypj,itypi)
 692             chi12=chi1*chi2
 693             chip1=chip(itypi)
 694             chip2=chip(itypj)
 695             chip12=chip1*chip2
 696             alf1=alp(itypi)
 697             alf2=alp(itypj)
 698             alf12=0.5D0*(alf1+alf2)
 699 C For diagnostics only!!!
 700 c           chi1=0.0D0
 701 c           chi2=0.0D0
 702 c           chi12=0.0D0
 703 c           chip1=0.0D0
 704 c           chip2=0.0D0
 705 c           chip12=0.0D0
 706 c           alf1=0.0D0
 707 c           alf2=0.0D0
 708 c           alf12=0.0D0
 709             xj=c(1,nres+j)-xi
 710             yj=c(2,nres+j)-yi
 711             zj=c(3,nres+j)-zi
 712             dxj=dc_norm(1,nres+j)
 713             dyj=dc_norm(2,nres+j)
 714             dzj=dc_norm(3,nres+j)
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716 cd          if (icall.eq.0) then
 717 cd            rrsave(ind)=rrij
 718 cd          else
 719 cd            rrij=rrsave(ind)
 720 cd          endif
 721             rij=dsqrt(rrij)
 722 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 723             call sc_angular
 724 C Calculate whole angle-dependent part of epsilon and contributions
 725 C to its derivatives
 726             fac=(rrij*sigsq)**expon2
 727             e1=fac*fac*aa(itypi,itypj)
 728             e2=fac*bb(itypi,itypj)
 729             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 730             eps2der=evdwij*eps3rt
 731             eps3der=evdwij*eps2rt
 732             evdwij=evdwij*eps2rt*eps3rt
 733             ij=icant(itypi,itypj)
 734             aux=eps1*eps2rt**2*eps3rt**2
 735             evdw=evdw+evdwij
 736             if (calc_grad) then
 737             if (lprn) then
 738             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 741 cd     &        restyp(itypi),i,restyp(itypj),j,
 742 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 743 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 744 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 745 cd     &        evdwij
 746             endif
 747 C Calculate gradient components.
 748             e1=e1*eps1*eps2rt**2*eps3rt**2
 749             fac=-expon*(e1+evdwij)
 750             sigder=fac/sigsq
 751             fac=rrij*fac
 752 C Calculate radial part of the gradient
 753             gg(1)=xj*fac
 754             gg(2)=yj*fac
 755             gg(3)=zj*fac
 756 C Calculate the angular part of the gradient and sum add the contributions
 757 C to the appropriate components of the Cartesian gradient.
 758             call sc_grad
 759             endif
 760           enddo      ! j
 761         enddo        ! iint
 762       enddo          ! i
 763 c     stop
 764       return
 765       end
 766 C-----------------------------------------------------------------------------
 767       subroutine egb(evdw)
 768 C
 769 C This subroutine calculates the interaction energy of nonbonded side chains
 770 C assuming the Gay-Berne potential of interaction.
 771 C
 772       implicit real*8 (a-h,o-z)
 773       include 'DIMENSIONS'
 774       include 'sizesclu.dat'
 775 c      include "DIMENSIONS.COMPAR"
 776       include 'COMMON.GEO'
 777       include 'COMMON.VAR'
 778       include 'COMMON.LOCAL'
 779       include 'COMMON.CHAIN'
 780       include 'COMMON.DERIV'
 781       include 'COMMON.NAMES'
 782       include 'COMMON.INTERACT'
 783       include 'COMMON.IOUNITS'
 784       include 'COMMON.CALC'
 785       include 'COMMON.SBRIDGE'
 786       logical lprn
 787       common /srutu/icall
 788       integer icant
 789       external icant
 790       evdw=0.0D0
 791 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 792       evdw=0.0D0
 793       lprn=.false.
 794 c      if (icall.gt.0) lprn=.true.
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=itype(i)
 798         itypi1=itype(i+1)
 799         xi=c(1,nres+i)
 800         yi=c(2,nres+i)
 801         zi=c(3,nres+i)
 802         dxi=dc_norm(1,nres+i)
 803         dyi=dc_norm(2,nres+i)
 804         dzi=dc_norm(3,nres+i)
 805         dsci_inv=vbld_inv(i+nres)
 806 C
 807 C Calculate SC interaction energy.
 808 C
 809         do iint=1,nint_gr(i)
 810           do j=istart(i,iint),iend(i,iint)
 811             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 812               call dyn_ssbond_ene(i,j,evdwij)
 813               evdw=evdw+evdwij
 814 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 815 c     &                        'evdw',i,j,evdwij,' ss'
 816             ELSE
 817             ind=ind+1
 818             itypj=itype(j)
 819             dscj_inv=vbld_inv(j+nres)
 820             sig0ij=sigma(itypi,itypj)
 821             chi1=chi(itypi,itypj)
 822             chi2=chi(itypj,itypi)
 823             chi12=chi1*chi2
 824             chip1=chip(itypi)
 825             chip2=chip(itypj)
 826             chip12=chip1*chip2
 827             alf1=alp(itypi)
 828             alf2=alp(itypj)
 829             alf12=0.5D0*(alf1+alf2)
 830 C For diagnostics only!!!
 831 c           chi1=0.0D0
 832 c           chi2=0.0D0
 833 c           chi12=0.0D0
 834 c           chip1=0.0D0
 835 c           chip2=0.0D0
 836 c           chip12=0.0D0
 837 c           alf1=0.0D0
 838 c           alf2=0.0D0
 839 c           alf12=0.0D0
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843             dxj=dc_norm(1,nres+j)
 844             dyj=dc_norm(2,nres+j)
 845             dzj=dc_norm(3,nres+j)
 846 c            write (iout,*) i,j,xj,yj,zj
 847             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 848             rij=dsqrt(rrij)
 849 C Calculate angle-dependent terms of energy and contributions to their
 850 C derivatives.
 851             call sc_angular
 852             sigsq=1.0D0/sigsq
 853             sig=sig0ij*dsqrt(sigsq)
 854             rij_shift=1.0D0/rij-sig+sig0ij
 855 C I hate to put IF's in the loops, but here don't have another choice!!!!
 856             if (rij_shift.le.0.0D0) then
 857               evdw=1.0D20
 858               return
 859             endif
 860             sigder=-sig*sigsq
 861 c---------------------------------------------------------------
 862             rij_shift=1.0D0/rij_shift
 863             fac=rij_shift**expon
 864             e1=fac*fac*aa(itypi,itypj)
 865             e2=fac*bb(itypi,itypj)
 866             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 867             eps2der=evdwij*eps3rt
 868             eps3der=evdwij*eps2rt
 869             evdwij=evdwij*eps2rt*eps3rt
 870             evdw=evdw+evdwij
 871             ij=icant(itypi,itypj)
 872             aux=eps1*eps2rt**2*eps3rt**2
 873 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 874 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 875 c     &         aux*e2/eps(itypi,itypj)
 876             if (lprn) then
 877             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 878             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 879             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 880      &        restyp(itypi),i,restyp(itypj),j,
 881      &        epsi,sigm,chi1,chi2,chip1,chip2,
 882      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 883      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 884      &        evdwij
 885             endif
 886             if (calc_grad) then
 887 C Calculate gradient components.
 888             e1=e1*eps1*eps2rt**2*eps3rt**2
 889             fac=-expon*(e1+evdwij)*rij_shift
 890             sigder=fac*sigder
 891             fac=rij*fac
 892 C Calculate the radial part of the gradient
 893             gg(1)=xj*fac
 894             gg(2)=yj*fac
 895             gg(3)=zj*fac
 896 C Calculate angular part of the gradient.
 897             call sc_grad
 898             endif
 899             ENDIF    ! SSBOND
 900           enddo      ! j
 901         enddo        ! iint
 902       enddo          ! i
 903       return
 904       end
 905 C-----------------------------------------------------------------------------
 906       subroutine egbv(evdw)
 907 C
 908 C This subroutine calculates the interaction energy of nonbonded side chains
 909 C assuming the Gay-Berne-Vorobjev potential of interaction.
 910 C
 911       implicit real*8 (a-h,o-z)
 912       include 'DIMENSIONS'
 913       include 'sizesclu.dat'
 914 c      include "DIMENSIONS.COMPAR"
 915       include 'COMMON.GEO'
 916       include 'COMMON.VAR'
 917       include 'COMMON.LOCAL'
 918       include 'COMMON.CHAIN'
 919       include 'COMMON.DERIV'
 920       include 'COMMON.NAMES'
 921       include 'COMMON.INTERACT'
 922       include 'COMMON.IOUNITS'
 923       include 'COMMON.CALC'
 924       include 'COMMON.SBRIDGE'
 925       common /srutu/ icall
 926       logical lprn
 927       integer icant
 928       external icant
 929       evdw=0.0D0
 930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 931       evdw=0.0D0
 932       lprn=.false.
 933 c      if (icall.gt.0) lprn=.true.
 934       ind=0
 935       do i=iatsc_s,iatsc_e
 936         itypi=itype(i)
 937         itypi1=itype(i+1)
 938         xi=c(1,nres+i)
 939         yi=c(2,nres+i)
 940         zi=c(3,nres+i)
 941         dxi=dc_norm(1,nres+i)
 942         dyi=dc_norm(2,nres+i)
 943         dzi=dc_norm(3,nres+i)
 944         dsci_inv=vbld_inv(i+nres)
 945 C
 946 C Calculate SC interaction energy.
 947 C
 948         do iint=1,nint_gr(i)
 949           do j=istart(i,iint),iend(i,iint)
 950 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 951             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 952               call dyn_ssbond_ene(i,j,evdwij)
 953               evdw=evdw+evdwij
 954 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 955 c     &                        'evdw',i,j,evdwij,' ss'
 956             ELSE
 957             ind=ind+1
 958             itypj=itype(j)
 959             dscj_inv=vbld_inv(j+nres)
 960             sig0ij=sigma(itypi,itypj)
 961             r0ij=r0(itypi,itypj)
 962             chi1=chi(itypi,itypj)
 963             chi2=chi(itypj,itypi)
 964             chi12=chi1*chi2
 965             chip1=chip(itypi)
 966             chip2=chip(itypj)
 967             chip12=chip1*chip2
 968             alf1=alp(itypi)
 969             alf2=alp(itypj)
 970             alf12=0.5D0*(alf1+alf2)
 971 C For diagnostics only!!!
 972 c           chi1=0.0D0
 973 c           chi2=0.0D0
 974 c           chi12=0.0D0
 975 c           chip1=0.0D0
 976 c           chip2=0.0D0
 977 c           chip12=0.0D0
 978 c           alf1=0.0D0
 979 c           alf2=0.0D0
 980 c           alf12=0.0D0
 981             xj=c(1,nres+j)-xi
 982             yj=c(2,nres+j)-yi
 983             zj=c(3,nres+j)-zi
 984             dxj=dc_norm(1,nres+j)
 985             dyj=dc_norm(2,nres+j)
 986             dzj=dc_norm(3,nres+j)
 987             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 988             rij=dsqrt(rrij)
 989 C Calculate angle-dependent terms of energy and contributions to their
 990 C derivatives.
 991             call sc_angular
 992             sigsq=1.0D0/sigsq
 993             sig=sig0ij*dsqrt(sigsq)
 994             rij_shift=1.0D0/rij-sig+r0ij
 995 C I hate to put IF's in the loops, but here don't have another choice!!!!
 996             if (rij_shift.le.0.0D0) then
 997               evdw=1.0D20
 998               return
 999             endif
1000             sigder=-sig*sigsq
1001 c---------------------------------------------------------------
1002             rij_shift=1.0D0/rij_shift
1003             fac=rij_shift**expon
1004             e1=fac*fac*aa(itypi,itypj)
1005             e2=fac*bb(itypi,itypj)
1006             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1007             eps2der=evdwij*eps3rt
1008             eps3der=evdwij*eps2rt
1009             fac_augm=rrij**expon
1010             e_augm=augm(itypi,itypj)*fac_augm
1011             evdwij=evdwij*eps2rt*eps3rt
1012             evdw=evdw+evdwij+e_augm
1013             ij=icant(itypi,itypj)
1014             aux=eps1*eps2rt**2*eps3rt**2
1015 c            if (lprn) then
1016 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1017 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1018 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1019 c     &        restyp(itypi),i,restyp(itypj),j,
1020 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1021 c     &        chi1,chi2,chip1,chip2,
1022 c     &        eps1,eps2rt**2,eps3rt**2,
1023 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1024 c     &        evdwij+e_augm
1025 c            endif
1026             if (calc_grad) then
1027 C Calculate gradient components.
1028             e1=e1*eps1*eps2rt**2*eps3rt**2
1029             fac=-expon*(e1+evdwij)*rij_shift
1030             sigder=fac*sigder
1031             fac=rij*fac-2*expon*rrij*e_augm
1032 C Calculate the radial part of the gradient
1033             gg(1)=xj*fac
1034             gg(2)=yj*fac
1035             gg(3)=zj*fac
1036 C Calculate angular part of the gradient.
1037             call sc_grad
1038             endif
1039             ENDIF    ! dyn_ss
1040           enddo      ! j
1041         enddo        ! iint
1042       enddo          ! i
1043       return
1044       end
1045 C-----------------------------------------------------------------------------
1046       subroutine sc_angular
1047 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1048 C om12. Called by ebp, egb, and egbv.
1049       implicit none
1050       include 'COMMON.CALC'
1051       erij(1)=xj*rij
1052       erij(2)=yj*rij
1053       erij(3)=zj*rij
1054       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1055       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1056       om12=dxi*dxj+dyi*dyj+dzi*dzj
1057       chiom12=chi12*om12
1058 C Calculate eps1(om12) and its derivative in om12
1059       faceps1=1.0D0-om12*chiom12
1060       faceps1_inv=1.0D0/faceps1
1061       eps1=dsqrt(faceps1_inv)
1062 C Following variable is eps1*deps1/dom12
1063       eps1_om12=faceps1_inv*chiom12
1064 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1065 C and om12.
1066       om1om2=om1*om2
1067       chiom1=chi1*om1
1068       chiom2=chi2*om2
1069       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1070       sigsq=1.0D0-facsig*faceps1_inv
1071       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1072       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1073       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1074 C Calculate eps2 and its derivatives in om1, om2, and om12.
1075       chipom1=chip1*om1
1076       chipom2=chip2*om2
1077       chipom12=chip12*om12
1078       facp=1.0D0-om12*chipom12
1079       facp_inv=1.0D0/facp
1080       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1081 C Following variable is the square root of eps2
1082       eps2rt=1.0D0-facp1*facp_inv
1083 C Following three variables are the derivatives of the square root of eps
1084 C in om1, om2, and om12.
1085       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1086       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1087       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1088 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1089       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1090 C Calculate whole angle-dependent part of epsilon and contributions
1091 C to its derivatives
1092       return
1093       end
1094 C----------------------------------------------------------------------------
1095       subroutine sc_grad
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       include 'sizesclu.dat'
1099       include 'COMMON.CHAIN'
1100       include 'COMMON.DERIV'
1101       include 'COMMON.CALC'
1102       double precision dcosom1(3),dcosom2(3)
1103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1104       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1105       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1106      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1107       do k=1,3
1108         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1109         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1110       enddo
1111       do k=1,3
1112         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1113       enddo
1114       do k=1,3
1115         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1117      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1118         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1119      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1120      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1121       enddo
1122 C
1123 C Calculate the components of the gradient in DC and X
1124 C
1125       do k=i,j-1
1126         do l=1,3
1127           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128         enddo
1129       enddo
1130       return
1131       end
1132 c------------------------------------------------------------------------------
1133       subroutine vec_and_deriv
1134       implicit real*8 (a-h,o-z)
1135       include 'DIMENSIONS'
1136       include 'sizesclu.dat'
1137       include 'COMMON.IOUNITS'
1138       include 'COMMON.GEO'
1139       include 'COMMON.VAR'
1140       include 'COMMON.LOCAL'
1141       include 'COMMON.CHAIN'
1142       include 'COMMON.VECTORS'
1143       include 'COMMON.DERIV'
1144       include 'COMMON.INTERACT'
1145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1146 C Compute the local reference systems. For reference system (i), the
1147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1149       do i=1,nres-1
1150 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1151           if (i.eq.nres-1) then
1152 C Case of the last full residue
1153 C Compute the Z-axis
1154             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1155             costh=dcos(pi-theta(nres))
1156             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1157             do k=1,3
1158               uz(k,i)=fac*uz(k,i)
1159             enddo
1160             if (calc_grad) then
1161 C Compute the derivatives of uz
1162             uzder(1,1,1)= 0.0d0
1163             uzder(2,1,1)=-dc_norm(3,i-1)
1164             uzder(3,1,1)= dc_norm(2,i-1)
1165             uzder(1,2,1)= dc_norm(3,i-1)
1166             uzder(2,2,1)= 0.0d0
1167             uzder(3,2,1)=-dc_norm(1,i-1)
1168             uzder(1,3,1)=-dc_norm(2,i-1)
1169             uzder(2,3,1)= dc_norm(1,i-1)
1170             uzder(3,3,1)= 0.0d0
1171             uzder(1,1,2)= 0.0d0
1172             uzder(2,1,2)= dc_norm(3,i)
1173             uzder(3,1,2)=-dc_norm(2,i)
1174             uzder(1,2,2)=-dc_norm(3,i)
1175             uzder(2,2,2)= 0.0d0
1176             uzder(3,2,2)= dc_norm(1,i)
1177             uzder(1,3,2)= dc_norm(2,i)
1178             uzder(2,3,2)=-dc_norm(1,i)
1179             uzder(3,3,2)= 0.0d0
1180             endif
1181 C Compute the Y-axis
1182             facy=fac
1183             do k=1,3
1184               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1185             enddo
1186             if (calc_grad) then
1187 C Compute the derivatives of uy
1188             do j=1,3
1189               do k=1,3
1190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1193               enddo
1194               uyder(j,j,1)=uyder(j,j,1)-costh
1195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1196             enddo
1197             do j=1,2
1198               do k=1,3
1199                 do l=1,3
1200                   uygrad(l,k,j,i)=uyder(l,k,j)
1201                   uzgrad(l,k,j,i)=uzder(l,k,j)
1202                 enddo
1203               enddo
1204             enddo
1205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1209             endif
1210           else
1211 C Other residues
1212 C Compute the Z-axis
1213             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1214             costh=dcos(pi-theta(i+2))
1215             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1216             do k=1,3
1217               uz(k,i)=fac*uz(k,i)
1218             enddo
1219             if (calc_grad) then
1220 C Compute the derivatives of uz
1221             uzder(1,1,1)= 0.0d0
1222             uzder(2,1,1)=-dc_norm(3,i+1)
1223             uzder(3,1,1)= dc_norm(2,i+1)
1224             uzder(1,2,1)= dc_norm(3,i+1)
1225             uzder(2,2,1)= 0.0d0
1226             uzder(3,2,1)=-dc_norm(1,i+1)
1227             uzder(1,3,1)=-dc_norm(2,i+1)
1228             uzder(2,3,1)= dc_norm(1,i+1)
1229             uzder(3,3,1)= 0.0d0
1230             uzder(1,1,2)= 0.0d0
1231             uzder(2,1,2)= dc_norm(3,i)
1232             uzder(3,1,2)=-dc_norm(2,i)
1233             uzder(1,2,2)=-dc_norm(3,i)
1234             uzder(2,2,2)= 0.0d0
1235             uzder(3,2,2)= dc_norm(1,i)
1236             uzder(1,3,2)= dc_norm(2,i)
1237             uzder(2,3,2)=-dc_norm(1,i)
1238             uzder(3,3,2)= 0.0d0
1239             endif
1240 C Compute the Y-axis
1241             facy=fac
1242             do k=1,3
1243               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1244             enddo
1245             if (calc_grad) then
1246 C Compute the derivatives of uy
1247             do j=1,3
1248               do k=1,3
1249                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1250      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1251                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1252               enddo
1253               uyder(j,j,1)=uyder(j,j,1)-costh
1254               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1255             enddo
1256             do j=1,2
1257               do k=1,3
1258                 do l=1,3
1259                   uygrad(l,k,j,i)=uyder(l,k,j)
1260                   uzgrad(l,k,j,i)=uzder(l,k,j)
1261                 enddo
1262               enddo
1263             enddo
1264             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1265             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1266             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1267             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1268           endif
1269           endif
1270       enddo
1271       if (calc_grad) then
1272       do i=1,nres-1
1273         vbld_inv_temp(1)=vbld_inv(i+1)
1274         if (i.lt.nres-1) then
1275           vbld_inv_temp(2)=vbld_inv(i+2)
1276         else
1277           vbld_inv_temp(2)=vbld_inv(i)
1278         endif
1279         do j=1,2
1280           do k=1,3
1281             do l=1,3
1282               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1283               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1284             enddo
1285           enddo
1286         enddo
1287       enddo
1288       endif
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine vec_and_deriv_test
1293       implicit real*8 (a-h,o-z)
1294       include 'DIMENSIONS'
1295       include 'sizesclu.dat'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.VECTORS'
1302       dimension uyder(3,3,2),uzder(3,3,2)
1303 C Compute the local reference systems. For reference system (i), the
1304 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1305 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1306       do i=1,nres-1
1307           if (i.eq.nres-1) then
1308 C Case of the last full residue
1309 C Compute the Z-axis
1310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1311             costh=dcos(pi-theta(nres))
1312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1313 c            write (iout,*) 'fac',fac,
1314 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1315             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1316             do k=1,3
1317               uz(k,i)=fac*uz(k,i)
1318             enddo
1319 C Compute the derivatives of uz
1320             uzder(1,1,1)= 0.0d0
1321             uzder(2,1,1)=-dc_norm(3,i-1)
1322             uzder(3,1,1)= dc_norm(2,i-1)
1323             uzder(1,2,1)= dc_norm(3,i-1)
1324             uzder(2,2,1)= 0.0d0
1325             uzder(3,2,1)=-dc_norm(1,i-1)
1326             uzder(1,3,1)=-dc_norm(2,i-1)
1327             uzder(2,3,1)= dc_norm(1,i-1)
1328             uzder(3,3,1)= 0.0d0
1329             uzder(1,1,2)= 0.0d0
1330             uzder(2,1,2)= dc_norm(3,i)
1331             uzder(3,1,2)=-dc_norm(2,i)
1332             uzder(1,2,2)=-dc_norm(3,i)
1333             uzder(2,2,2)= 0.0d0
1334             uzder(3,2,2)= dc_norm(1,i)
1335             uzder(1,3,2)= dc_norm(2,i)
1336             uzder(2,3,2)=-dc_norm(1,i)
1337             uzder(3,3,2)= 0.0d0
1338 C Compute the Y-axis
1339             do k=1,3
1340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1341             enddo
1342             facy=fac
1343             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1344      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1345      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1346             do k=1,3
1347 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348               uy(k,i)=
1349 c     &        facy*(
1350      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1351      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1352 c     &        )
1353             enddo
1354 c            write (iout,*) 'facy',facy,
1355 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1356             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1357             do k=1,3
1358               uy(k,i)=facy*uy(k,i)
1359             enddo
1360 C Compute the derivatives of uy
1361             do j=1,3
1362               do k=1,3
1363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1366               enddo
1367 c              uyder(j,j,1)=uyder(j,j,1)-costh
1368 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1369               uyder(j,j,1)=uyder(j,j,1)
1370      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1371               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1372      &          +uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386           else
1387 C Other residues
1388 C Compute the Z-axis
1389             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1390             costh=dcos(pi-theta(i+2))
1391             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i+1)
1399             uzder(3,1,1)= dc_norm(2,i+1)
1400             uzder(1,2,1)= dc_norm(3,i+1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i+1)
1403             uzder(1,3,1)=-dc_norm(2,i+1)
1404             uzder(2,3,1)= dc_norm(1,i+1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             facy=fac
1417             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1418      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1419      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1420             do k=1,3
1421 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1422               uy(k,i)=
1423 c     &        facy*(
1424      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1425      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1426 c     &        )
1427             enddo
1428 c            write (iout,*) 'facy',facy,
1429 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1430             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1431             do k=1,3
1432               uy(k,i)=facy*uy(k,i)
1433             enddo
1434 C Compute the derivatives of uy
1435             do j=1,3
1436               do k=1,3
1437                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1438      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1439                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1440               enddo
1441 c              uyder(j,j,1)=uyder(j,j,1)-costh
1442 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1443               uyder(j,j,1)=uyder(j,j,1)
1444      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1445               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1446      &          +uyder(j,j,2)
1447             enddo
1448             do j=1,2
1449               do k=1,3
1450                 do l=1,3
1451                   uygrad(l,k,j,i)=uyder(l,k,j)
1452                   uzgrad(l,k,j,i)=uzder(l,k,j)
1453                 enddo
1454               enddo
1455             enddo
1456             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1457             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1458             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1459             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1460           endif
1461       enddo
1462       do i=1,nres-1
1463         do j=1,2
1464           do k=1,3
1465             do l=1,3
1466               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1467               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1468             enddo
1469           enddo
1470         enddo
1471       enddo
1472       return
1473       end
1474 C-----------------------------------------------------------------------------
1475       subroutine check_vecgrad
1476       implicit real*8 (a-h,o-z)
1477       include 'DIMENSIONS'
1478       include 'sizesclu.dat'
1479       include 'COMMON.IOUNITS'
1480       include 'COMMON.GEO'
1481       include 'COMMON.VAR'
1482       include 'COMMON.LOCAL'
1483       include 'COMMON.CHAIN'
1484       include 'COMMON.VECTORS'
1485       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1486       dimension uyt(3,maxres),uzt(3,maxres)
1487       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1488       double precision delta /1.0d-7/
1489       call vec_and_deriv
1490 cd      do i=1,nres
1491 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1492 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1493 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1494 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1495 cd     &     (dc_norm(if90,i),if90=1,3)
1496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1497 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1498 cd          write(iout,'(a)')
1499 cd      enddo
1500       do i=1,nres
1501         do j=1,2
1502           do k=1,3
1503             do l=1,3
1504               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1505               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1506             enddo
1507           enddo
1508         enddo
1509       enddo
1510       call vec_and_deriv
1511       do i=1,nres
1512         do j=1,3
1513           uyt(j,i)=uy(j,i)
1514           uzt(j,i)=uz(j,i)
1515         enddo
1516       enddo
1517       do i=1,nres
1518 cd        write (iout,*) 'i=',i
1519         do k=1,3
1520           erij(k)=dc_norm(k,i)
1521         enddo
1522         do j=1,3
1523           do k=1,3
1524             dc_norm(k,i)=erij(k)
1525           enddo
1526           dc_norm(j,i)=dc_norm(j,i)+delta
1527 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1528 c          do k=1,3
1529 c            dc_norm(k,i)=dc_norm(k,i)/fac
1530 c          enddo
1531 c          write (iout,*) (dc_norm(k,i),k=1,3)
1532 c          write (iout,*) (erij(k),k=1,3)
1533           call vec_and_deriv
1534           do k=1,3
1535             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1536             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1537             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1538             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1539           enddo
1540 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1541 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1542 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1543         enddo
1544         do k=1,3
1545           dc_norm(k,i)=erij(k)
1546         enddo
1547 cd        do k=1,3
1548 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1549 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1550 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1551 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1552 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1553 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1554 cd          write (iout,'(a)')
1555 cd        enddo
1556       enddo
1557       return
1558       end
1559 C--------------------------------------------------------------------------
1560       subroutine set_matrices
1561       implicit real*8 (a-h,o-z)
1562       include 'DIMENSIONS'
1563       include 'sizesclu.dat'
1564       include 'COMMON.IOUNITS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.CONTACTS'
1572       include 'COMMON.TORSION'
1573       include 'COMMON.VECTORS'
1574       include 'COMMON.FFIELD'
1575       double precision auxvec(2),auxmat(2,2)
1576 C
1577 C Compute the virtual-bond-torsional-angle dependent quantities needed
1578 C to calculate the el-loc multibody terms of various order.
1579 C
1580       do i=3,nres+1
1581         if (i .lt. nres+1) then
1582           sin1=dsin(phi(i))
1583           cos1=dcos(phi(i))
1584           sintab(i-2)=sin1
1585           costab(i-2)=cos1
1586           obrot(1,i-2)=cos1
1587           obrot(2,i-2)=sin1
1588           sin2=dsin(2*phi(i))
1589           cos2=dcos(2*phi(i))
1590           sintab2(i-2)=sin2
1591           costab2(i-2)=cos2
1592           obrot2(1,i-2)=cos2
1593           obrot2(2,i-2)=sin2
1594           Ug(1,1,i-2)=-cos1
1595           Ug(1,2,i-2)=-sin1
1596           Ug(2,1,i-2)=-sin1
1597           Ug(2,2,i-2)= cos1
1598           Ug2(1,1,i-2)=-cos2
1599           Ug2(1,2,i-2)=-sin2
1600           Ug2(2,1,i-2)=-sin2
1601           Ug2(2,2,i-2)= cos2
1602         else
1603           costab(i-2)=1.0d0
1604           sintab(i-2)=0.0d0
1605           obrot(1,i-2)=1.0d0
1606           obrot(2,i-2)=0.0d0
1607           obrot2(1,i-2)=0.0d0
1608           obrot2(2,i-2)=0.0d0
1609           Ug(1,1,i-2)=1.0d0
1610           Ug(1,2,i-2)=0.0d0
1611           Ug(2,1,i-2)=0.0d0
1612           Ug(2,2,i-2)=1.0d0
1613           Ug2(1,1,i-2)=0.0d0
1614           Ug2(1,2,i-2)=0.0d0
1615           Ug2(2,1,i-2)=0.0d0
1616           Ug2(2,2,i-2)=0.0d0
1617         endif
1618         if (i .gt. 3 .and. i .lt. nres+1) then
1619           obrot_der(1,i-2)=-sin1
1620           obrot_der(2,i-2)= cos1
1621           Ugder(1,1,i-2)= sin1
1622           Ugder(1,2,i-2)=-cos1
1623           Ugder(2,1,i-2)=-cos1
1624           Ugder(2,2,i-2)=-sin1
1625           dwacos2=cos2+cos2
1626           dwasin2=sin2+sin2
1627           obrot2_der(1,i-2)=-dwasin2
1628           obrot2_der(2,i-2)= dwacos2
1629           Ug2der(1,1,i-2)= dwasin2
1630           Ug2der(1,2,i-2)=-dwacos2
1631           Ug2der(2,1,i-2)=-dwacos2
1632           Ug2der(2,2,i-2)=-dwasin2
1633         else
1634           obrot_der(1,i-2)=0.0d0
1635           obrot_der(2,i-2)=0.0d0
1636           Ugder(1,1,i-2)=0.0d0
1637           Ugder(1,2,i-2)=0.0d0
1638           Ugder(2,1,i-2)=0.0d0
1639           Ugder(2,2,i-2)=0.0d0
1640           obrot2_der(1,i-2)=0.0d0
1641           obrot2_der(2,i-2)=0.0d0
1642           Ug2der(1,1,i-2)=0.0d0
1643           Ug2der(1,2,i-2)=0.0d0
1644           Ug2der(2,1,i-2)=0.0d0
1645           Ug2der(2,2,i-2)=0.0d0
1646         endif
1647         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1648           iti = itortyp(itype(i-2))
1649         else
1650           iti=ntortyp+1
1651         endif
1652         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1653           iti1 = itortyp(itype(i-1))
1654         else
1655           iti1=ntortyp+1
1656         endif
1657 cd        write (iout,*) '*******i',i,' iti1',iti
1658 cd        write (iout,*) 'b1',b1(:,iti)
1659 cd        write (iout,*) 'b2',b2(:,iti)
1660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1661         if (i .gt. iatel_s+2) then
1662           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1663           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1664           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1665           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1666           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1667           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1668           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1669         else
1670           do k=1,2
1671             Ub2(k,i-2)=0.0d0
1672             Ctobr(k,i-2)=0.0d0
1673             Dtobr2(k,i-2)=0.0d0
1674             do l=1,2
1675               EUg(l,k,i-2)=0.0d0
1676               CUg(l,k,i-2)=0.0d0
1677               DUg(l,k,i-2)=0.0d0
1678               DtUg2(l,k,i-2)=0.0d0
1679             enddo
1680           enddo
1681         endif
1682         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1683         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1684         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1685         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1686         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1687         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1688         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1689         do k=1,2
1690           muder(k,i-2)=Ub2der(k,i-2)
1691         enddo
1692         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1693           iti1 = itortyp(itype(i-1))
1694         else
1695           iti1=ntortyp+1
1696         endif
1697         do k=1,2
1698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1699         enddo
1700 C Vectors and matrices dependent on a single virtual-bond dihedral.
1701         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1702         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1703         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1704         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1705         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1706         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1707         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1708         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1709         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1710 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1711 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1712       enddo
1713 C Matrices dependent on two consecutive virtual-bond dihedrals.
1714 C The order of matrices is from left to right.
1715       do i=2,nres-1
1716         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1717         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1718         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1719         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1720         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1721         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1722         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1723         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1724       enddo
1725 cd      do i=1,nres
1726 cd        iti = itortyp(itype(i))
1727 cd        write (iout,*) i
1728 cd        do j=1,2
1729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1731 cd        enddo
1732 cd      enddo
1733       return
1734       end
1735 C--------------------------------------------------------------------------
1736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1737 C
1738 C This subroutine calculates the average interaction energy and its gradient
1739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1741 C The potential depends both on the distance of peptide-group centers and on
1742 C the orientation of the CA-CA virtual bonds.
1743 C
1744       implicit real*8 (a-h,o-z)
1745       include 'DIMENSIONS'
1746       include 'sizesclu.dat'
1747       include 'COMMON.CONTROL'
1748       include 'COMMON.IOUNITS'
1749       include 'COMMON.GEO'
1750       include 'COMMON.VAR'
1751       include 'COMMON.LOCAL'
1752       include 'COMMON.CHAIN'
1753       include 'COMMON.DERIV'
1754       include 'COMMON.INTERACT'
1755       include 'COMMON.CONTACTS'
1756       include 'COMMON.TORSION'
1757       include 'COMMON.VECTORS'
1758       include 'COMMON.FFIELD'
1759       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1760      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1761       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1765       double precision scal_el /0.5d0/
1766 C 12/13/98
1767 C 13-go grudnia roku pamietnego...
1768       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1769      &                   0.0d0,1.0d0,0.0d0,
1770      &                   0.0d0,0.0d0,1.0d0/
1771 cd      write(iout,*) 'In EELEC'
1772 cd      do i=1,nloctyp
1773 cd        write(iout,*) 'Type',i
1774 cd        write(iout,*) 'B1',B1(:,i)
1775 cd        write(iout,*) 'B2',B2(:,i)
1776 cd        write(iout,*) 'CC',CC(:,:,i)
1777 cd        write(iout,*) 'DD',DD(:,:,i)
1778 cd        write(iout,*) 'EE',EE(:,:,i)
1779 cd      enddo
1780 cd      call check_vecgrad
1781 cd      stop
1782       if (icheckgrad.eq.1) then
1783         do i=1,nres-1
1784           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1785           do k=1,3
1786             dc_norm(k,i)=dc(k,i)*fac
1787           enddo
1788 c          write (iout,*) 'i',i,' fac',fac
1789         enddo
1790       endif
1791       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1792      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1793      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1794 cd      if (wel_loc.gt.0.0d0) then
1795         if (icheckgrad.eq.1) then
1796         call vec_and_deriv_test
1797         else
1798         call vec_and_deriv
1799         endif
1800         call set_matrices
1801       endif
1802 cd      do i=1,nres-1
1803 cd        write (iout,*) 'i=',i
1804 cd        do k=1,3
1805 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1806 cd        enddo
1807 cd        do k=1,3
1808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1810 cd        enddo
1811 cd      enddo
1812       num_conti_hb=0
1813       ees=0.0D0
1814       evdw1=0.0D0
1815       eel_loc=0.0d0
1816       eello_turn3=0.0d0
1817       eello_turn4=0.0d0
1818       ind=0
1819       do i=1,nres
1820         num_cont_hb(i)=0
1821       enddo
1822 cd      print '(a)','Enter EELEC'
1823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1824       do i=1,nres
1825         gel_loc_loc(i)=0.0d0
1826         gcorr_loc(i)=0.0d0
1827       enddo
1828       do i=iatel_s,iatel_e
1829         if (itel(i).eq.0) goto 1215
1830         dxi=dc(1,i)
1831         dyi=dc(2,i)
1832         dzi=dc(3,i)
1833         dx_normi=dc_norm(1,i)
1834         dy_normi=dc_norm(2,i)
1835         dz_normi=dc_norm(3,i)
1836         xmedi=c(1,i)+0.5d0*dxi
1837         ymedi=c(2,i)+0.5d0*dyi
1838         zmedi=c(3,i)+0.5d0*dzi
1839         num_conti=0
1840 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1841         do j=ielstart(i),ielend(i)
1842           if (itel(j).eq.0) goto 1216
1843           ind=ind+1
1844           iteli=itel(i)
1845           itelj=itel(j)
1846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1847           aaa=app(iteli,itelj)
1848           bbb=bpp(iteli,itelj)
1849 C Diagnostics only!!!
1850 c         aaa=0.0D0
1851 c         bbb=0.0D0
1852 c         ael6i=0.0D0
1853 c         ael3i=0.0D0
1854 C End diagnostics
1855           ael6i=ael6(iteli,itelj)
1856           ael3i=ael3(iteli,itelj)
1857           dxj=dc(1,j)
1858           dyj=dc(2,j)
1859           dzj=dc(3,j)
1860           dx_normj=dc_norm(1,j)
1861           dy_normj=dc_norm(2,j)
1862           dz_normj=dc_norm(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           rrmij=1.0D0/rij
1868           rij=dsqrt(rij)
1869           rmij=1.0D0/rij
1870           r3ij=rrmij*rmij
1871           r6ij=r3ij*r3ij
1872           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1873           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1874           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1875           fac=cosa-3.0D0*cosb*cosg
1876           ev1=aaa*r6ij*r6ij
1877 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1878           if (j.eq.i+2) ev1=scal_el*ev1
1879           ev2=bbb*r6ij
1880           fac3=ael6i*r6ij
1881           fac4=ael3i*r3ij
1882           evdwij=ev1+ev2
1883           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1884           el2=fac4*fac
1885           eesij=el1+el2
1886 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1887 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1888           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1889           ees=ees+eesij
1890           evdw1=evdw1+evdwij
1891 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1892 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1893 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1894 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1895 C
1896 C Calculate contributions to the Cartesian gradient.
1897 C
1898 #ifdef SPLITELE
1899           facvdw=-6*rrmij*(ev1+evdwij)
1900           facel=-3*rrmij*(el1+eesij)
1901           fac1=fac
1902           erij(1)=xj*rmij
1903           erij(2)=yj*rmij
1904           erij(3)=zj*rmij
1905           if (calc_grad) then
1906 *
1907 * Radial derivatives. First process both termini of the fragment (i,j)
1908 *
1909           ggg(1)=facel*xj
1910           ggg(2)=facel*yj
1911           ggg(3)=facel*zj
1912           do k=1,3
1913             ghalf=0.5D0*ggg(k)
1914             gelc(k,i)=gelc(k,i)+ghalf
1915             gelc(k,j)=gelc(k,j)+ghalf
1916           enddo
1917 *
1918 * Loop over residues i+1 thru j-1.
1919 *
1920           do k=i+1,j-1
1921             do l=1,3
1922               gelc(l,k)=gelc(l,k)+ggg(l)
1923             enddo
1924           enddo
1925           ggg(1)=facvdw*xj
1926           ggg(2)=facvdw*yj
1927           ggg(3)=facvdw*zj
1928           do k=1,3
1929             ghalf=0.5D0*ggg(k)
1930             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1931             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1932           enddo
1933 *
1934 * Loop over residues i+1 thru j-1.
1935 *
1936           do k=i+1,j-1
1937             do l=1,3
1938               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1939             enddo
1940           enddo
1941 #else
1942           facvdw=ev1+evdwij
1943           facel=el1+eesij
1944           fac1=fac
1945           fac=-3*rrmij*(facvdw+facvdw+facel)
1946           erij(1)=xj*rmij
1947           erij(2)=yj*rmij
1948           erij(3)=zj*rmij
1949           if (calc_grad) then
1950 *
1951 * Radial derivatives. First process both termini of the fragment (i,j)
1952 *
1953           ggg(1)=fac*xj
1954           ggg(2)=fac*yj
1955           ggg(3)=fac*zj
1956           do k=1,3
1957             ghalf=0.5D0*ggg(k)
1958             gelc(k,i)=gelc(k,i)+ghalf
1959             gelc(k,j)=gelc(k,j)+ghalf
1960           enddo
1961 *
1962 * Loop over residues i+1 thru j-1.
1963 *
1964           do k=i+1,j-1
1965             do l=1,3
1966               gelc(l,k)=gelc(l,k)+ggg(l)
1967             enddo
1968           enddo
1969 #endif
1970 *
1971 * Angular part
1972 *
1973           ecosa=2.0D0*fac3*fac1+fac4
1974           fac4=-3.0D0*fac4
1975           fac3=-6.0D0*fac3
1976           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1977           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1978           do k=1,3
1979             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1980             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1981           enddo
1982 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1983 cd   &          (dcosg(k),k=1,3)
1984           do k=1,3
1985             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1986           enddo
1987           do k=1,3
1988             ghalf=0.5D0*ggg(k)
1989             gelc(k,i)=gelc(k,i)+ghalf
1990      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1991      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1992             gelc(k,j)=gelc(k,j)+ghalf
1993      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1994      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1995           enddo
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           endif
2002
2003           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2004      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2005      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2006 C
2007 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2008 C   energy of a peptide unit is assumed in the form of a second-order
2009 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2010 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2011 C   are computed for EVERY pair of non-contiguous peptide groups.
2012 C
2013           if (j.lt.nres-1) then
2014             j1=j+1
2015             j2=j-1
2016           else
2017             j1=j-1
2018             j2=j-2
2019           endif
2020           kkk=0
2021           do k=1,2
2022             do l=1,2
2023               kkk=kkk+1
2024               muij(kkk)=mu(k,i)*mu(l,j)
2025             enddo
2026           enddo
2027 cd         write (iout,*) 'EELEC: i',i,' j',j
2028 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2029 cd          write(iout,*) 'muij',muij
2030           ury=scalar(uy(1,i),erij)
2031           urz=scalar(uz(1,i),erij)
2032           vry=scalar(uy(1,j),erij)
2033           vrz=scalar(uz(1,j),erij)
2034           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2035           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2036           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2037           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2038 C For diagnostics only
2039 cd          a22=1.0d0
2040 cd          a23=1.0d0
2041 cd          a32=1.0d0
2042 cd          a33=1.0d0
2043           fac=dsqrt(-ael6i)*r3ij
2044 cd          write (2,*) 'fac=',fac
2045 C For diagnostics only
2046 cd          fac=1.0d0
2047           a22=a22*fac
2048           a23=a23*fac
2049           a32=a32*fac
2050           a33=a33*fac
2051 cd          write (iout,'(4i5,4f10.5)')
2052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2055 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2056 cd          write (iout,'(4f10.5)')
2057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2060 cd           write (iout,'(2i3,9f10.5/)') i,j,
2061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2062           if (calc_grad) then
2063 C Derivatives of the elements of A in virtual-bond vectors
2064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2065 cd          do k=1,3
2066 cd            do l=1,3
2067 cd              erder(k,l)=0.0d0
2068 cd            enddo
2069 cd          enddo
2070           do k=1,3
2071             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2072             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2073             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2074             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2075             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2076             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2077             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2078             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2079             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2080             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2081             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2082             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2083           enddo
2084 cd          do k=1,3
2085 cd            do l=1,3
2086 cd              uryg(k,l)=0.0d0
2087 cd              urzg(k,l)=0.0d0
2088 cd              vryg(k,l)=0.0d0
2089 cd              vrzg(k,l)=0.0d0
2090 cd            enddo
2091 cd          enddo
2092 C Compute radial contributions to the gradient
2093           facr=-3.0d0*rrmij
2094           a22der=a22*facr
2095           a23der=a23*facr
2096           a32der=a32*facr
2097           a33der=a33*facr
2098 cd          a22der=0.0d0
2099 cd          a23der=0.0d0
2100 cd          a32der=0.0d0
2101 cd          a33der=0.0d0
2102           agg(1,1)=a22der*xj
2103           agg(2,1)=a22der*yj
2104           agg(3,1)=a22der*zj
2105           agg(1,2)=a23der*xj
2106           agg(2,2)=a23der*yj
2107           agg(3,2)=a23der*zj
2108           agg(1,3)=a32der*xj
2109           agg(2,3)=a32der*yj
2110           agg(3,3)=a32der*zj
2111           agg(1,4)=a33der*xj
2112           agg(2,4)=a33der*yj
2113           agg(3,4)=a33der*zj
2114 C Add the contributions coming from er
2115           fac3=-3.0d0*fac
2116           do k=1,3
2117             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2118             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2119             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2120             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2121           enddo
2122           do k=1,3
2123 C Derivatives in DC(i)
2124             ghalf1=0.5d0*agg(k,1)
2125             ghalf2=0.5d0*agg(k,2)
2126             ghalf3=0.5d0*agg(k,3)
2127             ghalf4=0.5d0*agg(k,4)
2128             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2129      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2130             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2131      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2132             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2133      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2134             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2135      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2136 C Derivatives in DC(i+1)
2137             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2138      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2139             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2140      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2141             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2142      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2143             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2144      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2145 C Derivatives in DC(j)
2146             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2147      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2148             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2149      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2150             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2151      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2152             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2153      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2154 C Derivatives in DC(j+1) or DC(nres-1)
2155             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2156      &      -3.0d0*vryg(k,3)*ury)
2157             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2158      &      -3.0d0*vrzg(k,3)*ury)
2159             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2160      &      -3.0d0*vryg(k,3)*urz)
2161             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2162      &      -3.0d0*vrzg(k,3)*urz)
2163 cd            aggi(k,1)=ghalf1
2164 cd            aggi(k,2)=ghalf2
2165 cd            aggi(k,3)=ghalf3
2166 cd            aggi(k,4)=ghalf4
2167 C Derivatives in DC(i+1)
2168 cd            aggi1(k,1)=agg(k,1)
2169 cd            aggi1(k,2)=agg(k,2)
2170 cd            aggi1(k,3)=agg(k,3)
2171 cd            aggi1(k,4)=agg(k,4)
2172 C Derivatives in DC(j)
2173 cd            aggj(k,1)=ghalf1
2174 cd            aggj(k,2)=ghalf2
2175 cd            aggj(k,3)=ghalf3
2176 cd            aggj(k,4)=ghalf4
2177 C Derivatives in DC(j+1)
2178 cd            aggj1(k,1)=0.0d0
2179 cd            aggj1(k,2)=0.0d0
2180 cd            aggj1(k,3)=0.0d0
2181 cd            aggj1(k,4)=0.0d0
2182             if (j.eq.nres-1 .and. i.lt.j-2) then
2183               do l=1,4
2184                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2185 cd                aggj1(k,l)=agg(k,l)
2186               enddo
2187             endif
2188           enddo
2189           endif
2190 c          goto 11111
2191 C Check the loc-el terms by numerical integration
2192           acipa(1,1)=a22
2193           acipa(1,2)=a23
2194           acipa(2,1)=a32
2195           acipa(2,2)=a33
2196           a22=-a22
2197           a23=-a23
2198           do l=1,2
2199             do k=1,3
2200               agg(k,l)=-agg(k,l)
2201               aggi(k,l)=-aggi(k,l)
2202               aggi1(k,l)=-aggi1(k,l)
2203               aggj(k,l)=-aggj(k,l)
2204               aggj1(k,l)=-aggj1(k,l)
2205             enddo
2206           enddo
2207           if (j.lt.nres-1) then
2208             a22=-a22
2209             a32=-a32
2210             do l=1,3,2
2211               do k=1,3
2212                 agg(k,l)=-agg(k,l)
2213                 aggi(k,l)=-aggi(k,l)
2214                 aggi1(k,l)=-aggi1(k,l)
2215                 aggj(k,l)=-aggj(k,l)
2216                 aggj1(k,l)=-aggj1(k,l)
2217               enddo
2218             enddo
2219           else
2220             a22=-a22
2221             a23=-a23
2222             a32=-a32
2223             a33=-a33
2224             do l=1,4
2225               do k=1,3
2226                 agg(k,l)=-agg(k,l)
2227                 aggi(k,l)=-aggi(k,l)
2228                 aggi1(k,l)=-aggi1(k,l)
2229                 aggj(k,l)=-aggj(k,l)
2230                 aggj1(k,l)=-aggj1(k,l)
2231               enddo
2232             enddo
2233           endif
2234           ENDIF ! WCORR
2235 11111     continue
2236           IF (wel_loc.gt.0.0d0) THEN
2237 C Contribution to the local-electrostatic energy coming from the i-j pair
2238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2239      &     +a33*muij(4)
2240 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2241 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2242           eel_loc=eel_loc+eel_loc_ij
2243 C Partial derivatives in virtual-bond dihedral angles gamma
2244           if (calc_grad) then
2245           if (i.gt.1)
2246      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2247      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2248      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2249           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2250      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2251      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2252 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2253 cd          write(iout,*) 'agg  ',agg
2254 cd          write(iout,*) 'aggi ',aggi
2255 cd          write(iout,*) 'aggi1',aggi1
2256 cd          write(iout,*) 'aggj ',aggj
2257 cd          write(iout,*) 'aggj1',aggj1
2258
2259 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2260           do l=1,3
2261             ggg(l)=agg(l,1)*muij(1)+
2262      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2263           enddo
2264           do k=i+2,j2
2265             do l=1,3
2266               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2267             enddo
2268           enddo
2269 C Remaining derivatives of eello
2270           do l=1,3
2271             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2272      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2273             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2274      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2275             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2276      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2277             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2278      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2279           enddo
2280           endif
2281           ENDIF
2282           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2283 C Contributions from turns
2284             a_temp(1,1)=a22
2285             a_temp(1,2)=a23
2286             a_temp(2,1)=a32
2287             a_temp(2,2)=a33
2288             call eturn34(i,j,eello_turn3,eello_turn4)
2289           endif
2290 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2291           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2292 C
2293 C Calculate the contact function. The ith column of the array JCONT will
2294 C contain the numbers of atoms that make contacts with the atom I (of numbers
2295 C greater than I). The arrays FACONT and GACONT will contain the values of
2296 C the contact function and its derivative.
2297 c           r0ij=1.02D0*rpp(iteli,itelj)
2298 c           r0ij=1.11D0*rpp(iteli,itelj)
2299             r0ij=2.20D0*rpp(iteli,itelj)
2300 c           r0ij=1.55D0*rpp(iteli,itelj)
2301             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2302             if (fcont.gt.0.0D0) then
2303               num_conti=num_conti+1
2304               if (num_conti.gt.maxconts) then
2305                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2306      &                         ' will skip next contacts for this conf.'
2307               else
2308                 jcont_hb(num_conti,i)=j
2309                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2310      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2311 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2312 C  terms.
2313                 d_cont(num_conti,i)=rij
2314 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2315 C     --- Electrostatic-interaction matrix ---
2316                 a_chuj(1,1,num_conti,i)=a22
2317                 a_chuj(1,2,num_conti,i)=a23
2318                 a_chuj(2,1,num_conti,i)=a32
2319                 a_chuj(2,2,num_conti,i)=a33
2320 C     --- Gradient of rij
2321                 do kkk=1,3
2322                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2323                 enddo
2324 c             if (i.eq.1) then
2325 c                a_chuj(1,1,num_conti,i)=-0.61d0
2326 c                a_chuj(1,2,num_conti,i)= 0.4d0
2327 c                a_chuj(2,1,num_conti,i)= 0.65d0
2328 c                a_chuj(2,2,num_conti,i)= 0.50d0
2329 c             else if (i.eq.2) then
2330 c                a_chuj(1,1,num_conti,i)= 0.0d0
2331 c                a_chuj(1,2,num_conti,i)= 0.0d0
2332 c                a_chuj(2,1,num_conti,i)= 0.0d0
2333 c                a_chuj(2,2,num_conti,i)= 0.0d0
2334 c             endif
2335 C     --- and its gradients
2336 cd                write (iout,*) 'i',i,' j',j
2337 cd                do kkk=1,3
2338 cd                write (iout,*) 'iii 1 kkk',kkk
2339 cd                write (iout,*) agg(kkk,:)
2340 cd                enddo
2341 cd                do kkk=1,3
2342 cd                write (iout,*) 'iii 2 kkk',kkk
2343 cd                write (iout,*) aggi(kkk,:)
2344 cd                enddo
2345 cd                do kkk=1,3
2346 cd                write (iout,*) 'iii 3 kkk',kkk
2347 cd                write (iout,*) aggi1(kkk,:)
2348 cd                enddo
2349 cd                do kkk=1,3
2350 cd                write (iout,*) 'iii 4 kkk',kkk
2351 cd                write (iout,*) aggj(kkk,:)
2352 cd                enddo
2353 cd                do kkk=1,3
2354 cd                write (iout,*) 'iii 5 kkk',kkk
2355 cd                write (iout,*) aggj1(kkk,:)
2356 cd                enddo
2357                 kkll=0
2358                 do k=1,2
2359                   do l=1,2
2360                     kkll=kkll+1
2361                     do m=1,3
2362                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2363                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2364                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2365                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2366                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2367 c                      do mm=1,5
2368 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2369 c                      enddo
2370                     enddo
2371                   enddo
2372                 enddo
2373                 ENDIF
2374                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2375 C Calculate contact energies
2376                 cosa4=4.0D0*cosa
2377                 wij=cosa-3.0D0*cosb*cosg
2378                 cosbg1=cosb+cosg
2379                 cosbg2=cosb-cosg
2380 c               fac3=dsqrt(-ael6i)/r0ij**3
2381                 fac3=dsqrt(-ael6i)*r3ij
2382                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2383                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2384 c               ees0mij=0.0D0
2385                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2386                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2387 C Diagnostics. Comment out or remove after debugging!
2388 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2389 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2390 c               ees0m(num_conti,i)=0.0D0
2391 C End diagnostics.
2392 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2393 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2394                 facont_hb(num_conti,i)=fcont
2395                 if (calc_grad) then
2396 C Angular derivatives of the contact function
2397                 ees0pij1=fac3/ees0pij
2398                 ees0mij1=fac3/ees0mij
2399                 fac3p=-3.0D0*fac3*rrmij
2400                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2401                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2402 c               ees0mij1=0.0D0
2403                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2404                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2405                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2406                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2407                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2408                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2409                 ecosap=ecosa1+ecosa2
2410                 ecosbp=ecosb1+ecosb2
2411                 ecosgp=ecosg1+ecosg2
2412                 ecosam=ecosa1-ecosa2
2413                 ecosbm=ecosb1-ecosb2
2414                 ecosgm=ecosg1-ecosg2
2415 C Diagnostics
2416 c               ecosap=ecosa1
2417 c               ecosbp=ecosb1
2418 c               ecosgp=ecosg1
2419 c               ecosam=0.0D0
2420 c               ecosbm=0.0D0
2421 c               ecosgm=0.0D0
2422 C End diagnostics
2423                 fprimcont=fprimcont/rij
2424 cd              facont_hb(num_conti,i)=1.0D0
2425 C Following line is for diagnostics.
2426 cd              fprimcont=0.0D0
2427                 do k=1,3
2428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2430                 enddo
2431                 do k=1,3
2432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2434                 enddo
2435                 gggp(1)=gggp(1)+ees0pijp*xj
2436                 gggp(2)=gggp(2)+ees0pijp*yj
2437                 gggp(3)=gggp(3)+ees0pijp*zj
2438                 gggm(1)=gggm(1)+ees0mijp*xj
2439                 gggm(2)=gggm(2)+ees0mijp*yj
2440                 gggm(3)=gggm(3)+ees0mijp*zj
2441 C Derivatives due to the contact function
2442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2445                 do k=1,3
2446                   ghalfp=0.5D0*gggp(k)
2447                   ghalfm=0.5D0*gggm(k)
2448                   gacontp_hb1(k,num_conti,i)=ghalfp
2449      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2450      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2451                   gacontp_hb2(k,num_conti,i)=ghalfp
2452      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2453      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2454                   gacontp_hb3(k,num_conti,i)=gggp(k)
2455                   gacontm_hb1(k,num_conti,i)=ghalfm
2456      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2457      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2458                   gacontm_hb2(k,num_conti,i)=ghalfm
2459      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2460      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2461                   gacontm_hb3(k,num_conti,i)=gggm(k)
2462                 enddo
2463                 endif
2464 C Diagnostics. Comment out or remove after debugging!
2465 cdiag           do k=1,3
2466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2472 cdiag           enddo
2473               ENDIF ! wcorr
2474               endif  ! num_conti.le.maxconts
2475             endif  ! fcont.gt.0
2476           endif    ! j.gt.i+1
2477  1216     continue
2478         enddo ! j
2479         num_cont_hb(i)=num_conti
2480  1215   continue
2481       enddo   ! i
2482 cd      do i=1,nres
2483 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2484 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2485 cd      enddo
2486 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2487 ccc      eel_loc=eel_loc+eello_turn3
2488       return
2489       end
2490 C-----------------------------------------------------------------------------
2491       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2492 C Third- and fourth-order contributions from turns
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'sizesclu.dat'
2496       include 'COMMON.IOUNITS'
2497       include 'COMMON.GEO'
2498       include 'COMMON.VAR'
2499       include 'COMMON.LOCAL'
2500       include 'COMMON.CHAIN'
2501       include 'COMMON.DERIV'
2502       include 'COMMON.INTERACT'
2503       include 'COMMON.CONTACTS'
2504       include 'COMMON.TORSION'
2505       include 'COMMON.VECTORS'
2506       include 'COMMON.FFIELD'
2507       dimension ggg(3)
2508       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2509      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2510      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2511       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2512      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2514       if (j.eq.i+2) then
2515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2516 C
2517 C               Third-order contributions
2518 C
2519 C                 (i+2)o----(i+3)
2520 C                      | |
2521 C                      | |
2522 C                 (i+1)o----i
2523 C
2524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2525 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2526         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2527         call transpose2(auxmat(1,1),auxmat1(1,1))
2528         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2529         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2530 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2531 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2532 cd     &    ' eello_turn3_num',4*eello_turn3_num
2533         if (calc_grad) then
2534 C Derivatives in gamma(i)
2535         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2536         call transpose2(auxmat2(1,1),pizda(1,1))
2537         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2538         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2539 C Derivatives in gamma(i+1)
2540         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2541         call transpose2(auxmat2(1,1),pizda(1,1))
2542         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2543         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2544      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2545 C Cartesian derivatives
2546         do l=1,3
2547           a_temp(1,1)=aggi(l,1)
2548           a_temp(1,2)=aggi(l,2)
2549           a_temp(2,1)=aggi(l,3)
2550           a_temp(2,2)=aggi(l,4)
2551           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2552           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2553      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2554           a_temp(1,1)=aggi1(l,1)
2555           a_temp(1,2)=aggi1(l,2)
2556           a_temp(2,1)=aggi1(l,3)
2557           a_temp(2,2)=aggi1(l,4)
2558           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2559           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2560      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2561           a_temp(1,1)=aggj(l,1)
2562           a_temp(1,2)=aggj(l,2)
2563           a_temp(2,1)=aggj(l,3)
2564           a_temp(2,2)=aggj(l,4)
2565           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2566           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2567      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2568           a_temp(1,1)=aggj1(l,1)
2569           a_temp(1,2)=aggj1(l,2)
2570           a_temp(2,1)=aggj1(l,3)
2571           a_temp(2,2)=aggj1(l,4)
2572           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2573           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2574      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2575         enddo
2576         endif
2577       else if (j.eq.i+3) then
2578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2579 C
2580 C               Fourth-order contributions
2581 C
2582 C                 (i+3)o----(i+4)
2583 C                     /  |
2584 C               (i+2)o   |
2585 C                     \  |
2586 C                 (i+1)o----i
2587 C
2588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2589 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2590         iti1=itortyp(itype(i+1))
2591         iti2=itortyp(itype(i+2))
2592         iti3=itortyp(itype(i+3))
2593         call transpose2(EUg(1,1,i+1),e1t(1,1))
2594         call transpose2(Eug(1,1,i+2),e2t(1,1))
2595         call transpose2(Eug(1,1,i+3),e3t(1,1))
2596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2597         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2598         s1=scalar2(b1(1,iti2),auxvec(1))
2599         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2601         s2=scalar2(b1(1,iti1),auxvec(1))
2602         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2603         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2604         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2605         eello_turn4=eello_turn4-(s1+s2+s3)
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2607 cd     &    ' eello_turn4_num',8*eello_turn4_num
2608 C Derivatives in gamma(i)
2609         if (calc_grad) then
2610         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2611         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2613         s1=scalar2(b1(1,iti2),auxvec(1))
2614         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2615         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2617 C Derivatives in gamma(i+1)
2618         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2619         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2620         s2=scalar2(b1(1,iti1),auxvec(1))
2621         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2622         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2623         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2624         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2625 C Derivatives in gamma(i+2)
2626         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2627         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2628         s1=scalar2(b1(1,iti2),auxvec(1))
2629         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2631         s2=scalar2(b1(1,iti1),auxvec(1))
2632         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2633         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2634         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2636 C Cartesian derivatives
2637 C Derivatives of this turn contributions in DC(i+2)
2638         if (j.lt.nres-1) then
2639           do l=1,3
2640             a_temp(1,1)=agg(l,1)
2641             a_temp(1,2)=agg(l,2)
2642             a_temp(2,1)=agg(l,3)
2643             a_temp(2,2)=agg(l,4)
2644             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2645             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2646             s1=scalar2(b1(1,iti2),auxvec(1))
2647             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2648             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2649             s2=scalar2(b1(1,iti1),auxvec(1))
2650             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2651             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2652             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653             ggg(l)=-(s1+s2+s3)
2654             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2655           enddo
2656         endif
2657 C Remaining derivatives of this turn contribution
2658         do l=1,3
2659           a_temp(1,1)=aggi(l,1)
2660           a_temp(1,2)=aggi(l,2)
2661           a_temp(2,1)=aggi(l,3)
2662           a_temp(2,2)=aggi(l,4)
2663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2665           s1=scalar2(b1(1,iti2),auxvec(1))
2666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2668           s2=scalar2(b1(1,iti1),auxvec(1))
2669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2672           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2673           a_temp(1,1)=aggi1(l,1)
2674           a_temp(1,2)=aggi1(l,2)
2675           a_temp(2,1)=aggi1(l,3)
2676           a_temp(2,2)=aggi1(l,4)
2677           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2678           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2679           s1=scalar2(b1(1,iti2),auxvec(1))
2680           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2681           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2682           s2=scalar2(b1(1,iti1),auxvec(1))
2683           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2684           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2685           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2686           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2687           a_temp(1,1)=aggj(l,1)
2688           a_temp(1,2)=aggj(l,2)
2689           a_temp(2,1)=aggj(l,3)
2690           a_temp(2,2)=aggj(l,4)
2691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2693           s1=scalar2(b1(1,iti2),auxvec(1))
2694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2696           s2=scalar2(b1(1,iti1),auxvec(1))
2697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2701           a_temp(1,1)=aggj1(l,1)
2702           a_temp(1,2)=aggj1(l,2)
2703           a_temp(2,1)=aggj1(l,3)
2704           a_temp(2,2)=aggj1(l,4)
2705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2707           s1=scalar2(b1(1,iti2),auxvec(1))
2708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2710           s2=scalar2(b1(1,iti1),auxvec(1))
2711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2714           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2715         enddo
2716         endif
2717       endif
2718       return
2719       end
2720 C-----------------------------------------------------------------------------
2721       subroutine vecpr(u,v,w)
2722       implicit real*8(a-h,o-z)
2723       dimension u(3),v(3),w(3)
2724       w(1)=u(2)*v(3)-u(3)*v(2)
2725       w(2)=-u(1)*v(3)+u(3)*v(1)
2726       w(3)=u(1)*v(2)-u(2)*v(1)
2727       return
2728       end
2729 C-----------------------------------------------------------------------------
2730       subroutine unormderiv(u,ugrad,unorm,ungrad)
2731 C This subroutine computes the derivatives of a normalized vector u, given
2732 C the derivatives computed without normalization conditions, ugrad. Returns
2733 C ungrad.
2734       implicit none
2735       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2736       double precision vec(3)
2737       double precision scalar
2738       integer i,j
2739 c      write (2,*) 'ugrad',ugrad
2740 c      write (2,*) 'u',u
2741       do i=1,3
2742         vec(i)=scalar(ugrad(1,i),u(1))
2743       enddo
2744 c      write (2,*) 'vec',vec
2745       do i=1,3
2746         do j=1,3
2747           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2748         enddo
2749       enddo
2750 c      write (2,*) 'ungrad',ungrad
2751       return
2752       end
2753 C-----------------------------------------------------------------------------
2754       subroutine escp(evdw2,evdw2_14)
2755 C
2756 C This subroutine calculates the excluded-volume interaction energy between
2757 C peptide-group centers and side chains and its gradient in virtual-bond and
2758 C side-chain vectors.
2759 C
2760       implicit real*8 (a-h,o-z)
2761       include 'DIMENSIONS'
2762       include 'sizesclu.dat'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.FFIELD'
2770       include 'COMMON.IOUNITS'
2771       dimension ggg(3)
2772       evdw2=0.0D0
2773       evdw2_14=0.0d0
2774 cd    print '(a)','Enter ESCP'
2775 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2776 c     &  ' scal14',scal14
2777       do i=iatscp_s,iatscp_e
2778         iteli=itel(i)
2779 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2780 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2781         if (iteli.eq.0) goto 1225
2782         xi=0.5D0*(c(1,i)+c(1,i+1))
2783         yi=0.5D0*(c(2,i)+c(2,i+1))
2784         zi=0.5D0*(c(3,i)+c(3,i+1))
2785
2786         do iint=1,nscp_gr(i)
2787
2788         do j=iscpstart(i,iint),iscpend(i,iint)
2789           itypj=itype(j)
2790 C Uncomment following three lines for SC-p interactions
2791 c         xj=c(1,nres+j)-xi
2792 c         yj=c(2,nres+j)-yi
2793 c         zj=c(3,nres+j)-zi
2794 C Uncomment following three lines for Ca-p interactions
2795           xj=c(1,j)-xi
2796           yj=c(2,j)-yi
2797           zj=c(3,j)-zi
2798           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2799           fac=rrij**expon2
2800           e1=fac*fac*aad(itypj,iteli)
2801           e2=fac*bad(itypj,iteli)
2802           if (iabs(j-i) .le. 2) then
2803             e1=scal14*e1
2804             e2=scal14*e2
2805             evdw2_14=evdw2_14+e1+e2
2806           endif
2807           evdwij=e1+e2
2808 c          write (iout,*) i,j,evdwij
2809           evdw2=evdw2+evdwij
2810           if (calc_grad) then
2811 C
2812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2813 C
2814           fac=-(evdwij+e1)*rrij
2815           ggg(1)=xj*fac
2816           ggg(2)=yj*fac
2817           ggg(3)=zj*fac
2818           if (j.lt.i) then
2819 cd          write (iout,*) 'j<i'
2820 C Uncomment following three lines for SC-p interactions
2821 c           do k=1,3
2822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2823 c           enddo
2824           else
2825 cd          write (iout,*) 'j>i'
2826             do k=1,3
2827               ggg(k)=-ggg(k)
2828 C Uncomment following line for SC-p interactions
2829 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2830             enddo
2831           endif
2832           do k=1,3
2833             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2834           enddo
2835           kstart=min0(i+1,j)
2836           kend=max0(i-1,j-1)
2837 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2838 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2839           do k=kstart,kend
2840             do l=1,3
2841               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2842             enddo
2843           enddo
2844           endif
2845         enddo
2846         enddo ! iint
2847  1225   continue
2848       enddo ! i
2849       do i=1,nct
2850         do j=1,3
2851           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2852           gradx_scp(j,i)=expon*gradx_scp(j,i)
2853         enddo
2854       enddo
2855 C******************************************************************************
2856 C
2857 C                              N O T E !!!
2858 C
2859 C To save time the factor EXPON has been extracted from ALL components
2860 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2861 C use!
2862 C
2863 C******************************************************************************
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine edis(ehpb)
2868 C
2869 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2870 C
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873       include 'COMMON.SBRIDGE'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.VAR'
2877       include 'COMMON.INTERACT'
2878       include 'COMMON.IOUNITS'
2879       include 'COMMON.CONTROL'
2880       dimension ggg(3)
2881       ehpb=0.0D0
2882 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2883 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2884       if (link_end.eq.0) return
2885       do i=link_start,link_end
2886 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2887 C CA-CA distance used in regularization of structure.
2888         ii=ihpb(i)
2889         jj=jhpb(i)
2890 C iii and jjj point to the residues for which the distance is assigned.
2891         if (ii.gt.nres) then
2892           iii=ii-nres
2893           jjj=jj-nres
2894         else
2895           iii=ii
2896           jjj=jj
2897         endif
2898 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2899 c     &    dhpb(i),dhpb1(i),forcon(i)
2900 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2901 C    distance and angle dependent SS bond potential.
2902         if (.not.dyn_ss .and. i.le.nss) then
2903 C 15/02/13 CC dynamic SSbond - additional check
2904         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2905           call ssbond_ene(iii,jjj,eij)
2906           ehpb=ehpb+2*eij
2907 cd          write (iout,*) "eij",eij
2908         endif
2909         else if (ii.gt.nres .and. jj.gt.nres) then
2910 c Restraints from contact prediction
2911           dd=dist(ii,jj)
2912          if (constr_dist.eq.11) then
2913             ehpb=ehpb+fordepth(i)**4.0d0
2914      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2915             fac=fordepth(i)**4.0d0
2916      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2917          else
2918           if (dhpb1(i).gt.0.0d0) then
2919             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2920             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2921 c            write (iout,*) "beta nmr",
2922 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2923           else
2924             dd=dist(ii,jj)
2925             rdis=dd-dhpb(i)
2926 C Get the force constant corresponding to this distance.
2927             waga=forcon(i)
2928 C Calculate the contribution to energy.
2929             ehpb=ehpb+waga*rdis*rdis
2930 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2931 C
2932 C Evaluate gradient.
2933 C
2934             fac=waga*rdis/dd
2935           endif !end dhpb1(i).gt.0
2936          endif !end const_dist=11
2937           do j=1,3
2938             ggg(j)=fac*(c(j,jj)-c(j,ii))
2939           enddo
2940           do j=1,3
2941             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2942             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2943           enddo
2944           do k=1,3
2945             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2946             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2947           enddo
2948         else
2949 C Calculate the distance between the two points and its difference from the
2950 C target distance.
2951           dd=dist(ii,jj)
2952 C          write(iout,*) "after",dd
2953           if (constr_dist.eq.11) then
2954             ehpb=ehpb+fordepth(i)**4.0d0
2955      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2956             fac=fordepth(i)**4.0d0
2957      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2958 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
2959 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
2960 C            print *,ehpb,"tu?"
2961 C            write(iout,*) ehpb,"btu?",
2962 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
2963 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
2964 C     &    ehpb,fordepth(i),dd
2965            else
2966           if (dhpb1(i).gt.0.0d0) then
2967             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2968             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2969 c            write (iout,*) "alph nmr",
2970 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2971           else
2972             rdis=dd-dhpb(i)
2973 C Get the force constant corresponding to this distance.
2974             waga=forcon(i)
2975 C Calculate the contribution to energy.
2976             ehpb=ehpb+waga*rdis*rdis
2977 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2978 C
2979 C Evaluate gradient.
2980 C
2981             fac=waga*rdis/dd
2982           endif
2983           endif
2984 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2985 cd   &   ' waga=',waga,' fac=',fac
2986             do j=1,3
2987               ggg(j)=fac*(c(j,jj)-c(j,ii))
2988             enddo
2989 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2990 C If this is a SC-SC distance, we need to calculate the contributions to the
2991 C Cartesian gradient in the SC vectors (ghpbx).
2992           if (iii.lt.ii) then
2993           do j=1,3
2994             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2995             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2996           enddo
2997           endif
2998           do k=1,3
2999             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3000             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3001           enddo
3002         endif
3003       enddo
3004       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3005       return
3006       end
3007 C--------------------------------------------------------------------------
3008       subroutine ssbond_ene(i,j,eij)
3009 C
3010 C Calculate the distance and angle dependent SS-bond potential energy
3011 C using a free-energy function derived based on RHF/6-31G** ab initio
3012 C calculations of diethyl disulfide.
3013 C
3014 C A. Liwo and U. Kozlowska, 11/24/03
3015 C
3016       implicit real*8 (a-h,o-z)
3017       include 'DIMENSIONS'
3018       include 'sizesclu.dat'
3019       include 'COMMON.SBRIDGE'
3020       include 'COMMON.CHAIN'
3021       include 'COMMON.DERIV'
3022       include 'COMMON.LOCAL'
3023       include 'COMMON.INTERACT'
3024       include 'COMMON.VAR'
3025       include 'COMMON.IOUNITS'
3026       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3027       itypi=itype(i)
3028       xi=c(1,nres+i)
3029       yi=c(2,nres+i)
3030       zi=c(3,nres+i)
3031       dxi=dc_norm(1,nres+i)
3032       dyi=dc_norm(2,nres+i)
3033       dzi=dc_norm(3,nres+i)
3034       dsci_inv=dsc_inv(itypi)
3035       itypj=itype(j)
3036       dscj_inv=dsc_inv(itypj)
3037       xj=c(1,nres+j)-xi
3038       yj=c(2,nres+j)-yi
3039       zj=c(3,nres+j)-zi
3040       dxj=dc_norm(1,nres+j)
3041       dyj=dc_norm(2,nres+j)
3042       dzj=dc_norm(3,nres+j)
3043       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3044       rij=dsqrt(rrij)
3045       erij(1)=xj*rij
3046       erij(2)=yj*rij
3047       erij(3)=zj*rij
3048       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3049       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3050       om12=dxi*dxj+dyi*dyj+dzi*dzj
3051       do k=1,3
3052         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3053         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3054       enddo
3055       rij=1.0d0/rij
3056       deltad=rij-d0cm
3057       deltat1=1.0d0-om1
3058       deltat2=1.0d0+om2
3059       deltat12=om2-om1+2.0d0
3060       cosphi=om12-om1*om2
3061       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3062      &  +akct*deltad*deltat12+ebr
3063      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3064 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3065 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3066 c     &  " deltat12",deltat12," eij",eij
3067       ed=2*akcm*deltad+akct*deltat12
3068       pom1=akct*deltad
3069       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3070       eom1=-2*akth*deltat1-pom1-om2*pom2
3071       eom2= 2*akth*deltat2+pom1-om1*pom2
3072       eom12=pom2
3073       do k=1,3
3074         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3075       enddo
3076       do k=1,3
3077         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3078      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3079         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3080      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3081       enddo
3082 C
3083 C Calculate the components of the gradient in DC and X
3084 C
3085       do k=i,j-1
3086         do l=1,3
3087           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3088         enddo
3089       enddo
3090       return
3091       end
3092
3093 C--------------------------------------------------------------------------
3094
3095
3096 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3097       subroutine e_modeller(ehomology_constr)
3098       implicit real*8 (a-h,o-z)
3099
3100       include 'DIMENSIONS'
3101
3102       integer nnn, i, j, k, ki, irec, l
3103       integer katy, odleglosci, test7
3104       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3105       real*8 distance(max_template),distancek(max_template),
3106      &    min_odl,godl(max_template),dih_diff(max_template)
3107
3108 c
3109 c     FP - 30/10/2014 Temporary specifications for homology restraints
3110 c
3111       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3112      &                 sgtheta
3113       double precision, dimension (maxres) :: guscdiff,usc_diff
3114       double precision, dimension (max_template) ::
3115      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3116      &           theta_diff
3117
3118       include 'COMMON.SBRIDGE'
3119       include 'COMMON.CHAIN'
3120       include 'COMMON.GEO'
3121       include 'COMMON.DERIV'
3122       include 'COMMON.LOCAL'
3123       include 'COMMON.INTERACT'
3124       include 'COMMON.VAR'
3125       include 'COMMON.IOUNITS'
3126       include 'COMMON.CONTROL'
3127       include 'COMMON.HOMRESTR'
3128 c
3129       include 'COMMON.SETUP'
3130       include 'COMMON.NAMES'
3131
3132       do i=1,max_template
3133         distancek(i)=9999999.9
3134       enddo
3135
3136       odleg=0.0d0
3137
3138 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3139 c function)
3140 C AL 5/2/14 - Introduce list of restraints
3141 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3142 #ifdef DEBUG
3143       write(iout,*) "------- dist restrs start -------"
3144       write (iout,*) "link_start_homo",link_start_homo,
3145      &    " link_end_homo",link_end_homo
3146 #endif
3147       do ii = link_start_homo,link_end_homo
3148          i = ires_homo(ii)
3149          j = jres_homo(ii)
3150          dij=dist(i,j)
3151 c        write (iout,*) "dij(",i,j,") =",dij
3152          do k=1,constr_homology
3153            if(.not.l_homo(k,ii)) cycle
3154            distance(k)=odl(k,ii)-dij
3155 c          write (iout,*) "distance(",k,") =",distance(k)
3156 c
3157 c          For Gaussian-type Urestr
3158 c
3159            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3160 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3161 c          write (iout,*) "distancek(",k,") =",distancek(k)
3162 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3163 c
3164 c          For Lorentzian-type Urestr
3165 c
3166            if (waga_dist.lt.0.0d0) then
3167               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3168               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3169      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3170            endif
3171          enddo
3172
3173 c         min_odl=minval(distancek)
3174          do kk=1,constr_homology
3175           if(l_homo(kk,ii)) then
3176             min_odl=distancek(kk)
3177             exit
3178           endif
3179          enddo
3180          do kk=1,constr_homology
3181           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3182      &              min_odl=distancek(kk)
3183          enddo
3184 c        write (iout,* )"min_odl",min_odl
3185 #ifdef DEBUG
3186          write (iout,*) "ij dij",i,j,dij
3187          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3188          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3189          write (iout,* )"min_odl",min_odl
3190 #endif
3191          odleg2=0.0d0
3192          do k=1,constr_homology
3193 c Nie wiem po co to liczycie jeszcze raz!
3194 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3195 c     &              (2*(sigma_odl(i,j,k))**2))
3196            if(.not.l_homo(k,ii)) cycle
3197            if (waga_dist.ge.0.0d0) then
3198 c
3199 c          For Gaussian-type Urestr
3200 c
3201             godl(k)=dexp(-distancek(k)+min_odl)
3202             odleg2=odleg2+godl(k)
3203 c
3204 c          For Lorentzian-type Urestr
3205 c
3206            else
3207             odleg2=odleg2+distancek(k)
3208            endif
3209
3210 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3211 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3212 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3213 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3214
3215          enddo
3216 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3217 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3218 #ifdef DEBUG
3219          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3220          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3221 #endif
3222            if (waga_dist.ge.0.0d0) then
3223 c
3224 c          For Gaussian-type Urestr
3225 c
3226               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3227 c
3228 c          For Lorentzian-type Urestr
3229 c
3230            else
3231               odleg=odleg+odleg2/constr_homology
3232            endif
3233 c
3234 #ifdef GRAD
3235 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3236 c Gradient
3237 c
3238 c          For Gaussian-type Urestr
3239 c
3240          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3241          sum_sgodl=0.0d0
3242          do k=1,constr_homology
3243 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3244 c     &           *waga_dist)+min_odl
3245 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3246 c
3247          if(.not.l_homo(k,ii)) cycle
3248          if (waga_dist.ge.0.0d0) then
3249 c          For Gaussian-type Urestr
3250 c
3251            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3252 c
3253 c          For Lorentzian-type Urestr
3254 c
3255          else
3256            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3257      &           sigma_odlir(k,ii)**2)**2)
3258          endif
3259            sum_sgodl=sum_sgodl+sgodl
3260
3261 c            sgodl2=sgodl2+sgodl
3262 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3263 c      write(iout,*) "constr_homology=",constr_homology
3264 c      write(iout,*) i, j, k, "TEST K"
3265          enddo
3266          if (waga_dist.ge.0.0d0) then
3267 c
3268 c          For Gaussian-type Urestr
3269 c
3270             grad_odl3=waga_homology(iset)*waga_dist
3271      &                *sum_sgodl/(sum_godl*dij)
3272 c
3273 c          For Lorentzian-type Urestr
3274 c
3275          else
3276 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3277 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3278             grad_odl3=-waga_homology(iset)*waga_dist*
3279      &                sum_sgodl/(constr_homology*dij)
3280          endif
3281 c
3282 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3283
3284
3285 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3286 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3287 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3288
3289 ccc      write(iout,*) godl, sgodl, grad_odl3
3290
3291 c          grad_odl=grad_odl+grad_odl3
3292
3293          do jik=1,3
3294             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3295 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3296 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3297 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3298             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3299             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3300 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3301 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3302 c         if (i.eq.25.and.j.eq.27) then
3303 c         write(iout,*) "jik",jik,"i",i,"j",j
3304 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3305 c         write(iout,*) "grad_odl3",grad_odl3
3306 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3307 c         write(iout,*) "ggodl",ggodl
3308 c         write(iout,*) "ghpbc(",jik,i,")",
3309 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3310 c     &                 ghpbc(jik,j)
3311 c         endif
3312          enddo
3313 #endif
3314 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3315 ccc     & dLOG(odleg2),"-odleg=", -odleg
3316
3317       enddo ! ii-loop for dist
3318 #ifdef DEBUG
3319       write(iout,*) "------- dist restrs end -------"
3320 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3321 c    &     waga_d.eq.1.0d0) call sum_gradient
3322 #endif
3323 c Pseudo-energy and gradient from dihedral-angle restraints from
3324 c homology templates
3325 c      write (iout,*) "End of distance loop"
3326 c      call flush(iout)
3327       kat=0.0d0
3328 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3329 #ifdef DEBUG
3330       write(iout,*) "------- dih restrs start -------"
3331       do i=idihconstr_start_homo,idihconstr_end_homo
3332         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3333       enddo
3334 #endif
3335       do i=idihconstr_start_homo,idihconstr_end_homo
3336         kat2=0.0d0
3337 c        betai=beta(i,i+1,i+2,i+3)
3338         betai = phi(i)
3339 c       write (iout,*) "betai =",betai
3340         do k=1,constr_homology
3341           dih_diff(k)=pinorm(dih(k,i)-betai)
3342 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3343 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3344 c     &                                   -(6.28318-dih_diff(i,k))
3345 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3346 c     &                                   6.28318+dih_diff(i,k)
3347
3348           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3349 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3350           gdih(k)=dexp(kat3)
3351           kat2=kat2+gdih(k)
3352 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3353 c          write(*,*)""
3354         enddo
3355 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3356 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3357 #ifdef DEBUG
3358         write (iout,*) "i",i," betai",betai," kat2",kat2
3359         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3360 #endif
3361         if (kat2.le.1.0d-14) cycle
3362         kat=kat-dLOG(kat2/constr_homology)
3363 c       write (iout,*) "kat",kat ! sum of -ln-s
3364
3365 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3366 ccc     & dLOG(kat2), "-kat=", -kat
3367
3368 #ifdef GRAD
3369 c ----------------------------------------------------------------------
3370 c Gradient
3371 c ----------------------------------------------------------------------
3372
3373         sum_gdih=kat2
3374         sum_sgdih=0.0d0
3375         do k=1,constr_homology
3376           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3377 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3378           sum_sgdih=sum_sgdih+sgdih
3379         enddo
3380 c       grad_dih3=sum_sgdih/sum_gdih
3381         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3382
3383 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3384 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3385 ccc     & gloc(nphi+i-3,icg)
3386         gloc(i,icg)=gloc(i,icg)+grad_dih3
3387 c        if (i.eq.25) then
3388 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3389 c        endif
3390 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3391 ccc     & gloc(nphi+i-3,icg)
3392 #endif
3393       enddo ! i-loop for dih
3394 #ifdef DEBUG
3395       write(iout,*) "------- dih restrs end -------"
3396 #endif
3397
3398 c Pseudo-energy and gradient for theta angle restraints from
3399 c homology templates
3400 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3401 c adapted
3402
3403 c
3404 c     For constr_homology reference structures (FP)
3405 c
3406 c     Uconst_back_tot=0.0d0
3407       Eval=0.0d0
3408       Erot=0.0d0
3409 c     Econstr_back legacy
3410 #ifdef GRAD
3411       do i=1,nres
3412 c     do i=ithet_start,ithet_end
3413        dutheta(i)=0.0d0
3414 c     enddo
3415 c     do i=loc_start,loc_end
3416         do j=1,3
3417           duscdiff(j,i)=0.0d0
3418           duscdiffx(j,i)=0.0d0
3419         enddo
3420       enddo
3421 #endif
3422 c
3423 c     do iref=1,nref
3424 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3425 c     write (iout,*) "waga_theta",waga_theta
3426       if (waga_theta.gt.0.0d0) then
3427 #ifdef DEBUG
3428       write (iout,*) "usampl",usampl
3429       write(iout,*) "------- theta restrs start -------"
3430 c     do i=ithet_start,ithet_end
3431 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3432 c     enddo
3433 #endif
3434 c     write (iout,*) "maxres",maxres,"nres",nres
3435
3436       do i=ithet_start,ithet_end
3437 c
3438 c     do i=1,nfrag_back
3439 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3440 c
3441 c Deviation of theta angles wrt constr_homology ref structures
3442 c
3443         utheta_i=0.0d0 ! argument of Gaussian for single k
3444         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3445 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3446 c       over residues in a fragment
3447 c       write (iout,*) "theta(",i,")=",theta(i)
3448         do k=1,constr_homology
3449 c
3450 c         dtheta_i=theta(j)-thetaref(j,iref)
3451 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3452           theta_diff(k)=thetatpl(k,i)-theta(i)
3453 c
3454           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3455 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3456           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3457           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3458 c         Gradient for single Gaussian restraint in subr Econstr_back
3459 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3460 c
3461         enddo
3462 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3463 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3464
3465 c
3466 #ifdef GRAD
3467 c         Gradient for multiple Gaussian restraint
3468         sum_gtheta=gutheta_i
3469         sum_sgtheta=0.0d0
3470         do k=1,constr_homology
3471 c        New generalized expr for multiple Gaussian from Econstr_back
3472          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3473 c
3474 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3475           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3476         enddo
3477 c
3478 c       Final value of gradient using same var as in Econstr_back
3479         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3480      &               *waga_homology(iset)
3481 c       dutheta(i)=sum_sgtheta/sum_gtheta
3482 c
3483 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3484 #endif
3485         Eval=Eval-dLOG(gutheta_i/constr_homology)
3486 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3487 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3488 c       Uconst_back=Uconst_back+utheta(i)
3489       enddo ! (i-loop for theta)
3490 #ifdef DEBUG
3491       write(iout,*) "------- theta restrs end -------"
3492 #endif
3493       endif
3494 c
3495 c Deviation of local SC geometry
3496 c
3497 c Separation of two i-loops (instructed by AL - 11/3/2014)
3498 c
3499 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3500 c     write (iout,*) "waga_d",waga_d
3501
3502 #ifdef DEBUG
3503       write(iout,*) "------- SC restrs start -------"
3504       write (iout,*) "Initial duscdiff,duscdiffx"
3505       do i=loc_start,loc_end
3506         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3507      &                 (duscdiffx(jik,i),jik=1,3)
3508       enddo
3509 #endif
3510       do i=loc_start,loc_end
3511         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3512         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3513 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3514 c       write(iout,*) "xxtab, yytab, zztab"
3515 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3516         do k=1,constr_homology
3517 c
3518           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3519 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3520           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3521           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3522 c         write(iout,*) "dxx, dyy, dzz"
3523 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3524 c
3525           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3526 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3527 c         uscdiffk(k)=usc_diff(i)
3528           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3529           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3530 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3531 c     &      xxref(j),yyref(j),zzref(j)
3532         enddo
3533 c
3534 c       Gradient
3535 c
3536 c       Generalized expression for multiple Gaussian acc to that for a single
3537 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3538 c
3539 c       Original implementation
3540 c       sum_guscdiff=guscdiff(i)
3541 c
3542 c       sum_sguscdiff=0.0d0
3543 c       do k=1,constr_homology
3544 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3545 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3546 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3547 c       enddo
3548 c
3549 c       Implementation of new expressions for gradient (Jan. 2015)
3550 c
3551 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3552 #ifdef GRAD
3553         do k=1,constr_homology
3554 c
3555 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3556 c       before. Now the drivatives should be correct
3557 c
3558           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3559 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3560           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3561           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3562 c
3563 c         New implementation
3564 c
3565           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3566      &                 sigma_d(k,i) ! for the grad wrt r'
3567 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3568 c
3569 c
3570 c        New implementation
3571          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3572          do jik=1,3
3573             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3574      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3575      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3576             duscdiff(jik,i)=duscdiff(jik,i)+
3577      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3578      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3579             duscdiffx(jik,i)=duscdiffx(jik,i)+
3580      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3581      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3582 c
3583 #ifdef DEBUG
3584              write(iout,*) "jik",jik,"i",i
3585              write(iout,*) "dxx, dyy, dzz"
3586              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3587              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3588 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3589 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3590 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3591 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3592 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3593 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3594 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3595 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3596 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3597 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3598 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3599 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3600 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3601 c            endif
3602 #endif
3603          enddo
3604         enddo
3605 #endif
3606 c
3607 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3608 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3609 c
3610 c        write (iout,*) i," uscdiff",uscdiff(i)
3611 c
3612 c Put together deviations from local geometry
3613
3614 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3615 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3616         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3617 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3618 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3619 c       Uconst_back=Uconst_back+usc_diff(i)
3620 c
3621 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3622 c
3623 c     New implment: multiplied by sum_sguscdiff
3624 c
3625
3626       enddo ! (i-loop for dscdiff)
3627
3628 c      endif
3629
3630 #ifdef DEBUG
3631       write(iout,*) "------- SC restrs end -------"
3632         write (iout,*) "------ After SC loop in e_modeller ------"
3633         do i=loc_start,loc_end
3634          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3635          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3636         enddo
3637       if (waga_theta.eq.1.0d0) then
3638       write (iout,*) "in e_modeller after SC restr end: dutheta"
3639       do i=ithet_start,ithet_end
3640         write (iout,*) i,dutheta(i)
3641       enddo
3642       endif
3643       if (waga_d.eq.1.0d0) then
3644       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3645       do i=1,nres
3646         write (iout,*) i,(duscdiff(j,i),j=1,3)
3647         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3648       enddo
3649       endif
3650 #endif
3651
3652 c Total energy from homology restraints
3653 #ifdef DEBUG
3654       write (iout,*) "odleg",odleg," kat",kat
3655       write (iout,*) "odleg",odleg," kat",kat
3656       write (iout,*) "Eval",Eval," Erot",Erot
3657       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3658       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3659       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3660       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3661 #endif
3662 c
3663 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3664 c
3665 c     ehomology_constr=odleg+kat
3666 c
3667 c     For Lorentzian-type Urestr
3668 c
3669
3670       if (waga_dist.ge.0.0d0) then
3671 c
3672 c          For Gaussian-type Urestr
3673 c
3674         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3675      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3676 c     write (iout,*) "ehomology_constr=",ehomology_constr
3677       else
3678 c
3679 c          For Lorentzian-type Urestr
3680 c
3681         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3682      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3683 c     write (iout,*) "ehomology_constr=",ehomology_constr
3684       endif
3685 #ifdef DEBUG
3686       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
3687       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3688      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
3689       write (iout,*) "ehomology_constr",ehomology_constr
3690 #endif
3691       return
3692
3693   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3694   747 format(a12,i4,i4,i4,f8.3,f8.3)
3695   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3696   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3697   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3698      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3699       end
3700 C--------------------------------------------------------------------------
3701       subroutine ebond(estr)
3702 c
3703 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3704 c
3705       implicit real*8 (a-h,o-z)
3706       include 'DIMENSIONS'
3707       include 'COMMON.LOCAL'
3708       include 'COMMON.GEO'
3709       include 'COMMON.INTERACT'
3710       include 'COMMON.DERIV'
3711       include 'COMMON.VAR'
3712       include 'COMMON.CHAIN'
3713       include 'COMMON.IOUNITS'
3714       include 'COMMON.NAMES'
3715       include 'COMMON.FFIELD'
3716       include 'COMMON.CONTROL'
3717       double precision u(3),ud(3)
3718       estr=0.0d0
3719       do i=nnt+1,nct
3720         diff = vbld(i)-vbldp0
3721 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3722         estr=estr+diff*diff
3723         do j=1,3
3724           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3725         enddo
3726       enddo
3727       estr=0.5d0*AKP*estr
3728 c
3729 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3730 c
3731       do i=nnt,nct
3732         iti=itype(i)
3733         if (iti.ne.10) then
3734           nbi=nbondterm(iti)
3735           if (nbi.eq.1) then
3736             diff=vbld(i+nres)-vbldsc0(1,iti)
3737 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3738 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3739             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3740             do j=1,3
3741               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3742             enddo
3743           else
3744             do j=1,nbi
3745               diff=vbld(i+nres)-vbldsc0(j,iti)
3746               ud(j)=aksc(j,iti)*diff
3747               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3748             enddo
3749             uprod=u(1)
3750             do j=2,nbi
3751               uprod=uprod*u(j)
3752             enddo
3753             usum=0.0d0
3754             usumsqder=0.0d0
3755             do j=1,nbi
3756               uprod1=1.0d0
3757               uprod2=1.0d0
3758               do k=1,nbi
3759                 if (k.ne.j) then
3760                   uprod1=uprod1*u(k)
3761                   uprod2=uprod2*u(k)*u(k)
3762                 endif
3763               enddo
3764               usum=usum+uprod1
3765               usumsqder=usumsqder+ud(j)*uprod2
3766             enddo
3767 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3768 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3769             estr=estr+uprod/usum
3770             do j=1,3
3771              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3772             enddo
3773           endif
3774         endif
3775       enddo
3776       return
3777       end
3778 #ifdef CRYST_THETA
3779 C--------------------------------------------------------------------------
3780       subroutine ebend(etheta)
3781 C
3782 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3783 C angles gamma and its derivatives in consecutive thetas and gammas.
3784 C
3785       implicit real*8 (a-h,o-z)
3786       include 'DIMENSIONS'
3787       include 'sizesclu.dat'
3788       include 'COMMON.LOCAL'
3789       include 'COMMON.GEO'
3790       include 'COMMON.INTERACT'
3791       include 'COMMON.DERIV'
3792       include 'COMMON.VAR'
3793       include 'COMMON.CHAIN'
3794       include 'COMMON.IOUNITS'
3795       include 'COMMON.NAMES'
3796       include 'COMMON.FFIELD'
3797       common /calcthet/ term1,term2,termm,diffak,ratak,
3798      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3799      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3800       double precision y(2),z(2)
3801       delta=0.02d0*pi
3802       time11=dexp(-2*time)
3803       time12=1.0d0
3804       etheta=0.0D0
3805 c      write (iout,*) "nres",nres
3806 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3807 c      write (iout,*) ithet_start,ithet_end
3808       do i=ithet_start,ithet_end
3809 C Zero the energy function and its derivative at 0 or pi.
3810         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3811         it=itype(i-1)
3812 c        if (i.gt.ithet_start .and.
3813 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3814 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3815 c          phii=phi(i)
3816 c          y(1)=dcos(phii)
3817 c          y(2)=dsin(phii)
3818 c        else
3819 c          y(1)=0.0D0
3820 c          y(2)=0.0D0
3821 c        endif
3822 c        if (i.lt.nres .and. itel(i).ne.0) then
3823 c          phii1=phi(i+1)
3824 c          z(1)=dcos(phii1)
3825 c          z(2)=dsin(phii1)
3826 c        else
3827 c          z(1)=0.0D0
3828 c          z(2)=0.0D0
3829 c        endif
3830         if (i.gt.3) then
3831 #ifdef OSF
3832           phii=phi(i)
3833           icrc=0
3834           call proc_proc(phii,icrc)
3835           if (icrc.eq.1) phii=150.0
3836 #else
3837           phii=phi(i)
3838 #endif
3839           y(1)=dcos(phii)
3840           y(2)=dsin(phii)
3841         else
3842           y(1)=0.0D0
3843           y(2)=0.0D0
3844         endif
3845         if (i.lt.nres) then
3846 #ifdef OSF
3847           phii1=phi(i+1)
3848           icrc=0
3849           call proc_proc(phii1,icrc)
3850           if (icrc.eq.1) phii1=150.0
3851           phii1=pinorm(phii1)
3852           z(1)=cos(phii1)
3853 #else
3854           phii1=phi(i+1)
3855           z(1)=dcos(phii1)
3856 #endif
3857           z(2)=dsin(phii1)
3858         else
3859           z(1)=0.0D0
3860           z(2)=0.0D0
3861         endif
3862 C Calculate the "mean" value of theta from the part of the distribution
3863 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3864 C In following comments this theta will be referred to as t_c.
3865         thet_pred_mean=0.0d0
3866         do k=1,2
3867           athetk=athet(k,it)
3868           bthetk=bthet(k,it)
3869           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3870         enddo
3871 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3872         dthett=thet_pred_mean*ssd
3873         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3874 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3875 C Derivatives of the "mean" values in gamma1 and gamma2.
3876         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3877         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3878         if (theta(i).gt.pi-delta) then
3879           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3880      &         E_tc0)
3881           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3882           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3883           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3884      &        E_theta)
3885           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3886      &        E_tc)
3887         else if (theta(i).lt.delta) then
3888           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3889           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3890           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3891      &        E_theta)
3892           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3893           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3894      &        E_tc)
3895         else
3896           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3897      &        E_theta,E_tc)
3898         endif
3899         etheta=etheta+ethetai
3900 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3901 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3902         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3903         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3904         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3905  1215   continue
3906       enddo
3907 C Ufff.... We've done all this!!!
3908       return
3909       end
3910 C---------------------------------------------------------------------------
3911       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3912      &     E_tc)
3913       implicit real*8 (a-h,o-z)
3914       include 'DIMENSIONS'
3915       include 'COMMON.LOCAL'
3916       include 'COMMON.IOUNITS'
3917       common /calcthet/ term1,term2,termm,diffak,ratak,
3918      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3919      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3920 C Calculate the contributions to both Gaussian lobes.
3921 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3922 C The "polynomial part" of the "standard deviation" of this part of
3923 C the distribution.
3924         sig=polthet(3,it)
3925         do j=2,0,-1
3926           sig=sig*thet_pred_mean+polthet(j,it)
3927         enddo
3928 C Derivative of the "interior part" of the "standard deviation of the"
3929 C gamma-dependent Gaussian lobe in t_c.
3930         sigtc=3*polthet(3,it)
3931         do j=2,1,-1
3932           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3933         enddo
3934         sigtc=sig*sigtc
3935 C Set the parameters of both Gaussian lobes of the distribution.
3936 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3937         fac=sig*sig+sigc0(it)
3938         sigcsq=fac+fac
3939         sigc=1.0D0/sigcsq
3940 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3941         sigsqtc=-4.0D0*sigcsq*sigtc
3942 c       print *,i,sig,sigtc,sigsqtc
3943 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3944         sigtc=-sigtc/(fac*fac)
3945 C Following variable is sigma(t_c)**(-2)
3946         sigcsq=sigcsq*sigcsq
3947         sig0i=sig0(it)
3948         sig0inv=1.0D0/sig0i**2
3949         delthec=thetai-thet_pred_mean
3950         delthe0=thetai-theta0i
3951         term1=-0.5D0*sigcsq*delthec*delthec
3952         term2=-0.5D0*sig0inv*delthe0*delthe0
3953 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3954 C NaNs in taking the logarithm. We extract the largest exponent which is added
3955 C to the energy (this being the log of the distribution) at the end of energy
3956 C term evaluation for this virtual-bond angle.
3957         if (term1.gt.term2) then
3958           termm=term1
3959           term2=dexp(term2-termm)
3960           term1=1.0d0
3961         else
3962           termm=term2
3963           term1=dexp(term1-termm)
3964           term2=1.0d0
3965         endif
3966 C The ratio between the gamma-independent and gamma-dependent lobes of
3967 C the distribution is a Gaussian function of thet_pred_mean too.
3968         diffak=gthet(2,it)-thet_pred_mean
3969         ratak=diffak/gthet(3,it)**2
3970         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3971 C Let's differentiate it in thet_pred_mean NOW.
3972         aktc=ak*ratak
3973 C Now put together the distribution terms to make complete distribution.
3974         termexp=term1+ak*term2
3975         termpre=sigc+ak*sig0i
3976 C Contribution of the bending energy from this theta is just the -log of
3977 C the sum of the contributions from the two lobes and the pre-exponential
3978 C factor. Simple enough, isn't it?
3979         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3980 C NOW the derivatives!!!
3981 C 6/6/97 Take into account the deformation.
3982         E_theta=(delthec*sigcsq*term1
3983      &       +ak*delthe0*sig0inv*term2)/termexp
3984         E_tc=((sigtc+aktc*sig0i)/termpre
3985      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3986      &       aktc*term2)/termexp)
3987       return
3988       end
3989 c-----------------------------------------------------------------------------
3990       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3991       implicit real*8 (a-h,o-z)
3992       include 'DIMENSIONS'
3993       include 'COMMON.LOCAL'
3994       include 'COMMON.IOUNITS'
3995       common /calcthet/ term1,term2,termm,diffak,ratak,
3996      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3997      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3998       delthec=thetai-thet_pred_mean
3999       delthe0=thetai-theta0i
4000 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4001       t3 = thetai-thet_pred_mean
4002       t6 = t3**2
4003       t9 = term1
4004       t12 = t3*sigcsq
4005       t14 = t12+t6*sigsqtc
4006       t16 = 1.0d0
4007       t21 = thetai-theta0i
4008       t23 = t21**2
4009       t26 = term2
4010       t27 = t21*t26
4011       t32 = termexp
4012       t40 = t32**2
4013       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4014      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4015      & *(-t12*t9-ak*sig0inv*t27)
4016       return
4017       end
4018 #else
4019 C--------------------------------------------------------------------------
4020       subroutine ebend(etheta)
4021 C
4022 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4023 C angles gamma and its derivatives in consecutive thetas and gammas.
4024 C ab initio-derived potentials from
4025 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4026 C
4027       implicit real*8 (a-h,o-z)
4028       include 'DIMENSIONS'
4029       include 'COMMON.LOCAL'
4030       include 'COMMON.GEO'
4031       include 'COMMON.INTERACT'
4032       include 'COMMON.DERIV'
4033       include 'COMMON.VAR'
4034       include 'COMMON.CHAIN'
4035       include 'COMMON.IOUNITS'
4036       include 'COMMON.NAMES'
4037       include 'COMMON.FFIELD'
4038       include 'COMMON.CONTROL'
4039       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4040      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4041      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4042      & sinph1ph2(maxdouble,maxdouble)
4043       logical lprn /.false./, lprn1 /.false./
4044       etheta=0.0D0
4045       do i=ithet_start,ithet_end
4046         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4047      &    (itype(i).eq.ntyp1)) cycle
4048         dethetai=0.0d0
4049         dephii=0.0d0
4050         dephii1=0.0d0
4051         theti2=0.5d0*theta(i)
4052         ityp2=ithetyp(itype(i-1))
4053         do k=1,nntheterm
4054           coskt(k)=dcos(k*theti2)
4055           sinkt(k)=dsin(k*theti2)
4056         enddo
4057         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4058 #ifdef OSF
4059           phii=phi(i)
4060           if (phii.ne.phii) phii=150.0
4061 #else
4062           phii=phi(i)
4063 #endif
4064           ityp1=ithetyp(itype(i-2))
4065           do k=1,nsingle
4066             cosph1(k)=dcos(k*phii)
4067             sinph1(k)=dsin(k*phii)
4068           enddo
4069         else
4070           phii=0.0d0
4071           ityp1=ithetyp(itype(i-2))
4072           do k=1,nsingle
4073             cosph1(k)=0.0d0
4074             sinph1(k)=0.0d0
4075           enddo
4076         endif
4077         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4078 #ifdef OSF
4079           phii1=phi(i+1)
4080           if (phii1.ne.phii1) phii1=150.0
4081           phii1=pinorm(phii1)
4082 #else
4083           phii1=phi(i+1)
4084 #endif
4085           ityp3=ithetyp(itype(i))
4086           do k=1,nsingle
4087             cosph2(k)=dcos(k*phii1)
4088             sinph2(k)=dsin(k*phii1)
4089           enddo
4090         else
4091           phii1=0.0d0
4092           ityp3=ithetyp(itype(i))
4093           do k=1,nsingle
4094             cosph2(k)=0.0d0
4095             sinph2(k)=0.0d0
4096           enddo
4097         endif
4098 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4099 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4100 c        call flush(iout)
4101         ethetai=aa0thet(ityp1,ityp2,ityp3)
4102         do k=1,ndouble
4103           do l=1,k-1
4104             ccl=cosph1(l)*cosph2(k-l)
4105             ssl=sinph1(l)*sinph2(k-l)
4106             scl=sinph1(l)*cosph2(k-l)
4107             csl=cosph1(l)*sinph2(k-l)
4108             cosph1ph2(l,k)=ccl-ssl
4109             cosph1ph2(k,l)=ccl+ssl
4110             sinph1ph2(l,k)=scl+csl
4111             sinph1ph2(k,l)=scl-csl
4112           enddo
4113         enddo
4114         if (lprn) then
4115         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4116      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4117         write (iout,*) "coskt and sinkt"
4118         do k=1,nntheterm
4119           write (iout,*) k,coskt(k),sinkt(k)
4120         enddo
4121         endif
4122         do k=1,ntheterm
4123           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4124           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4125      &      *coskt(k)
4126           if (lprn)
4127      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4128      &     " ethetai",ethetai
4129         enddo
4130         if (lprn) then
4131         write (iout,*) "cosph and sinph"
4132         do k=1,nsingle
4133           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4134         enddo
4135         write (iout,*) "cosph1ph2 and sinph2ph2"
4136         do k=2,ndouble
4137           do l=1,k-1
4138             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4139      &         sinph1ph2(l,k),sinph1ph2(k,l)
4140           enddo
4141         enddo
4142         write(iout,*) "ethetai",ethetai
4143         endif
4144         do m=1,ntheterm2
4145           do k=1,nsingle
4146             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4147      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4148      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4149      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4150             ethetai=ethetai+sinkt(m)*aux
4151             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4152             dephii=dephii+k*sinkt(m)*(
4153      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4154      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4155             dephii1=dephii1+k*sinkt(m)*(
4156      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4157      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4158             if (lprn)
4159      &      write (iout,*) "m",m," k",k," bbthet",
4160      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4161      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4162      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4163      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4164           enddo
4165         enddo
4166         if (lprn)
4167      &  write(iout,*) "ethetai",ethetai
4168         do m=1,ntheterm3
4169           do k=2,ndouble
4170             do l=1,k-1
4171               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4172      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4173      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4174      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4175               ethetai=ethetai+sinkt(m)*aux
4176               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4177               dephii=dephii+l*sinkt(m)*(
4178      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4179      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4180      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4181      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4182               dephii1=dephii1+(k-l)*sinkt(m)*(
4183      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4184      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4185      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4186      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4187               if (lprn) then
4188               write (iout,*) "m",m," k",k," l",l," ffthet",
4189      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4190      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4191      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4192      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4193               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4194      &            cosph1ph2(k,l)*sinkt(m),
4195      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4196               endif
4197             enddo
4198           enddo
4199         enddo
4200 10      continue
4201 c        lprn1=.true.
4202         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4203      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4204      &   phii1*rad2deg,ethetai
4205 c        lprn1=.false.
4206         etheta=etheta+ethetai
4207
4208         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4209         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4210         gloc(nphi+i-2,icg)=wang*dethetai
4211       enddo
4212       return
4213       end
4214 #endif
4215 #ifdef CRYST_SC
4216 c-----------------------------------------------------------------------------
4217       subroutine esc(escloc)
4218 C Calculate the local energy of a side chain and its derivatives in the
4219 C corresponding virtual-bond valence angles THETA and the spherical angles
4220 C ALPHA and OMEGA.
4221       implicit real*8 (a-h,o-z)
4222       include 'DIMENSIONS'
4223       include 'sizesclu.dat'
4224       include 'COMMON.GEO'
4225       include 'COMMON.LOCAL'
4226       include 'COMMON.VAR'
4227       include 'COMMON.INTERACT'
4228       include 'COMMON.DERIV'
4229       include 'COMMON.CHAIN'
4230       include 'COMMON.IOUNITS'
4231       include 'COMMON.NAMES'
4232       include 'COMMON.FFIELD'
4233       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4234      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4235       common /sccalc/ time11,time12,time112,theti,it,nlobit
4236       delta=0.02d0*pi
4237       escloc=0.0D0
4238 c     write (iout,'(a)') 'ESC'
4239       do i=loc_start,loc_end
4240         it=itype(i)
4241         if (it.eq.10) goto 1
4242         nlobit=nlob(it)
4243 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4244 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4245         theti=theta(i+1)-pipol
4246         x(1)=dtan(theti)
4247         x(2)=alph(i)
4248         x(3)=omeg(i)
4249 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4250
4251         if (x(2).gt.pi-delta) then
4252           xtemp(1)=x(1)
4253           xtemp(2)=pi-delta
4254           xtemp(3)=x(3)
4255           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4256           xtemp(2)=pi
4257           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4258           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4259      &        escloci,dersc(2))
4260           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4261      &        ddersc0(1),dersc(1))
4262           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4263      &        ddersc0(3),dersc(3))
4264           xtemp(2)=pi-delta
4265           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4266           xtemp(2)=pi
4267           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4268           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4269      &            dersc0(2),esclocbi,dersc02)
4270           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4271      &            dersc12,dersc01)
4272           call splinthet(x(2),0.5d0*delta,ss,ssd)
4273           dersc0(1)=dersc01
4274           dersc0(2)=dersc02
4275           dersc0(3)=0.0d0
4276           do k=1,3
4277             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4278           enddo
4279           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4280 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4281 c    &             esclocbi,ss,ssd
4282           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4283 c         escloci=esclocbi
4284 c         write (iout,*) escloci
4285         else if (x(2).lt.delta) then
4286           xtemp(1)=x(1)
4287           xtemp(2)=delta
4288           xtemp(3)=x(3)
4289           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4290           xtemp(2)=0.0d0
4291           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4292           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4293      &        escloci,dersc(2))
4294           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4295      &        ddersc0(1),dersc(1))
4296           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4297      &        ddersc0(3),dersc(3))
4298           xtemp(2)=delta
4299           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4300           xtemp(2)=0.0d0
4301           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4302           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4303      &            dersc0(2),esclocbi,dersc02)
4304           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4305      &            dersc12,dersc01)
4306           dersc0(1)=dersc01
4307           dersc0(2)=dersc02
4308           dersc0(3)=0.0d0
4309           call splinthet(x(2),0.5d0*delta,ss,ssd)
4310           do k=1,3
4311             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4312           enddo
4313           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4314 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4315 c    &             esclocbi,ss,ssd
4316           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4317 c         write (iout,*) escloci
4318         else
4319           call enesc(x,escloci,dersc,ddummy,.false.)
4320         endif
4321
4322         escloc=escloc+escloci
4323 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4324
4325         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4326      &   wscloc*dersc(1)
4327         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4328         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4329     1   continue
4330       enddo
4331       return
4332       end
4333 C---------------------------------------------------------------------------
4334       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4335       implicit real*8 (a-h,o-z)
4336       include 'DIMENSIONS'
4337       include 'COMMON.GEO'
4338       include 'COMMON.LOCAL'
4339       include 'COMMON.IOUNITS'
4340       common /sccalc/ time11,time12,time112,theti,it,nlobit
4341       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4342       double precision contr(maxlob,-1:1)
4343       logical mixed
4344 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4345         escloc_i=0.0D0
4346         do j=1,3
4347           dersc(j)=0.0D0
4348           if (mixed) ddersc(j)=0.0d0
4349         enddo
4350         x3=x(3)
4351
4352 C Because of periodicity of the dependence of the SC energy in omega we have
4353 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4354 C To avoid underflows, first compute & store the exponents.
4355
4356         do iii=-1,1
4357
4358           x(3)=x3+iii*dwapi
4359
4360           do j=1,nlobit
4361             do k=1,3
4362               z(k)=x(k)-censc(k,j,it)
4363             enddo
4364             do k=1,3
4365               Axk=0.0D0
4366               do l=1,3
4367                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4368               enddo
4369               Ax(k,j,iii)=Axk
4370             enddo
4371             expfac=0.0D0
4372             do k=1,3
4373               expfac=expfac+Ax(k,j,iii)*z(k)
4374             enddo
4375             contr(j,iii)=expfac
4376           enddo ! j
4377
4378         enddo ! iii
4379
4380         x(3)=x3
4381 C As in the case of ebend, we want to avoid underflows in exponentiation and
4382 C subsequent NaNs and INFs in energy calculation.
4383 C Find the largest exponent
4384         emin=contr(1,-1)
4385         do iii=-1,1
4386           do j=1,nlobit
4387             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4388           enddo
4389         enddo
4390         emin=0.5D0*emin
4391 cd      print *,'it=',it,' emin=',emin
4392
4393 C Compute the contribution to SC energy and derivatives
4394         do iii=-1,1
4395
4396           do j=1,nlobit
4397             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4398 cd          print *,'j=',j,' expfac=',expfac
4399             escloc_i=escloc_i+expfac
4400             do k=1,3
4401               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4402             enddo
4403             if (mixed) then
4404               do k=1,3,2
4405                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4406      &            +gaussc(k,2,j,it))*expfac
4407               enddo
4408             endif
4409           enddo
4410
4411         enddo ! iii
4412
4413         dersc(1)=dersc(1)/cos(theti)**2
4414         ddersc(1)=ddersc(1)/cos(theti)**2
4415         ddersc(3)=ddersc(3)
4416
4417         escloci=-(dlog(escloc_i)-emin)
4418         do j=1,3
4419           dersc(j)=dersc(j)/escloc_i
4420         enddo
4421         if (mixed) then
4422           do j=1,3,2
4423             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4424           enddo
4425         endif
4426       return
4427       end
4428 C------------------------------------------------------------------------------
4429       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4430       implicit real*8 (a-h,o-z)
4431       include 'DIMENSIONS'
4432       include 'COMMON.GEO'
4433       include 'COMMON.LOCAL'
4434       include 'COMMON.IOUNITS'
4435       common /sccalc/ time11,time12,time112,theti,it,nlobit
4436       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4437       double precision contr(maxlob)
4438       logical mixed
4439
4440       escloc_i=0.0D0
4441
4442       do j=1,3
4443         dersc(j)=0.0D0
4444       enddo
4445
4446       do j=1,nlobit
4447         do k=1,2
4448           z(k)=x(k)-censc(k,j,it)
4449         enddo
4450         z(3)=dwapi
4451         do k=1,3
4452           Axk=0.0D0
4453           do l=1,3
4454             Axk=Axk+gaussc(l,k,j,it)*z(l)
4455           enddo
4456           Ax(k,j)=Axk
4457         enddo
4458         expfac=0.0D0
4459         do k=1,3
4460           expfac=expfac+Ax(k,j)*z(k)
4461         enddo
4462         contr(j)=expfac
4463       enddo ! j
4464
4465 C As in the case of ebend, we want to avoid underflows in exponentiation and
4466 C subsequent NaNs and INFs in energy calculation.
4467 C Find the largest exponent
4468       emin=contr(1)
4469       do j=1,nlobit
4470         if (emin.gt.contr(j)) emin=contr(j)
4471       enddo
4472       emin=0.5D0*emin
4473
4474 C Compute the contribution to SC energy and derivatives
4475
4476       dersc12=0.0d0
4477       do j=1,nlobit
4478         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4479         escloc_i=escloc_i+expfac
4480         do k=1,2
4481           dersc(k)=dersc(k)+Ax(k,j)*expfac
4482         enddo
4483         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4484      &            +gaussc(1,2,j,it))*expfac
4485         dersc(3)=0.0d0
4486       enddo
4487
4488       dersc(1)=dersc(1)/cos(theti)**2
4489       dersc12=dersc12/cos(theti)**2
4490       escloci=-(dlog(escloc_i)-emin)
4491       do j=1,2
4492         dersc(j)=dersc(j)/escloc_i
4493       enddo
4494       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4495       return
4496       end
4497 #else
4498 c----------------------------------------------------------------------------------
4499       subroutine esc(escloc)
4500 C Calculate the local energy of a side chain and its derivatives in the
4501 C corresponding virtual-bond valence angles THETA and the spherical angles
4502 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4503 C added by Urszula Kozlowska. 07/11/2007
4504 C
4505       implicit real*8 (a-h,o-z)
4506       include 'DIMENSIONS'
4507       include 'COMMON.GEO'
4508       include 'COMMON.LOCAL'
4509       include 'COMMON.VAR'
4510       include 'COMMON.SCROT'
4511       include 'COMMON.INTERACT'
4512       include 'COMMON.DERIV'
4513       include 'COMMON.CHAIN'
4514       include 'COMMON.IOUNITS'
4515       include 'COMMON.NAMES'
4516       include 'COMMON.FFIELD'
4517       include 'COMMON.CONTROL'
4518       include 'COMMON.VECTORS'
4519       double precision x_prime(3),y_prime(3),z_prime(3)
4520      &    , sumene,dsc_i,dp2_i,x(65),
4521      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4522      &    de_dxx,de_dyy,de_dzz,de_dt
4523       double precision s1_t,s1_6_t,s2_t,s2_6_t
4524       double precision
4525      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4526      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4527      & dt_dCi(3),dt_dCi1(3)
4528       common /sccalc/ time11,time12,time112,theti,it,nlobit
4529       delta=0.02d0*pi
4530       escloc=0.0D0
4531       do i=loc_start,loc_end
4532         costtab(i+1) =dcos(theta(i+1))
4533         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4534         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4535         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4536         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4537         cosfac=dsqrt(cosfac2)
4538         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4539         sinfac=dsqrt(sinfac2)
4540         it=itype(i)
4541         if (it.eq.10) goto 1
4542 c
4543 C  Compute the axes of tghe local cartesian coordinates system; store in
4544 c   x_prime, y_prime and z_prime
4545 c
4546         do j=1,3
4547           x_prime(j) = 0.00
4548           y_prime(j) = 0.00
4549           z_prime(j) = 0.00
4550         enddo
4551 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4552 C     &   dc_norm(3,i+nres)
4553         do j = 1,3
4554           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4555           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4556         enddo
4557         do j = 1,3
4558           z_prime(j) = -uz(j,i-1)
4559         enddo
4560 c       write (2,*) "i",i
4561 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4562 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4563 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4564 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4565 c      & " xy",scalar(x_prime(1),y_prime(1)),
4566 c      & " xz",scalar(x_prime(1),z_prime(1)),
4567 c      & " yy",scalar(y_prime(1),y_prime(1)),
4568 c      & " yz",scalar(y_prime(1),z_prime(1)),
4569 c      & " zz",scalar(z_prime(1),z_prime(1))
4570 c
4571 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4572 C to local coordinate system. Store in xx, yy, zz.
4573 c
4574         xx=0.0d0
4575         yy=0.0d0
4576         zz=0.0d0
4577         do j = 1,3
4578           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4579           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4580           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4581         enddo
4582
4583         xxtab(i)=xx
4584         yytab(i)=yy
4585         zztab(i)=zz
4586 C
4587 C Compute the energy of the ith side cbain
4588 C
4589 c        write (2,*) "xx",xx," yy",yy," zz",zz
4590         it=itype(i)
4591         do j = 1,65
4592           x(j) = sc_parmin(j,it)
4593         enddo
4594 #ifdef CHECK_COORD
4595 Cc diagnostics - remove later
4596         xx1 = dcos(alph(2))
4597         yy1 = dsin(alph(2))*dcos(omeg(2))
4598         zz1 = -dsin(alph(2))*dsin(omeg(2))
4599         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4600      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4601      &    xx1,yy1,zz1
4602 C,"  --- ", xx_w,yy_w,zz_w
4603 c end diagnostics
4604 #endif
4605         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4606      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4607      &   + x(10)*yy*zz
4608         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4609      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4610      & + x(20)*yy*zz
4611         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4612      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4613      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4614      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4615      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4616      &  +x(40)*xx*yy*zz
4617         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4618      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4619      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4620      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4621      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4622      &  +x(60)*xx*yy*zz
4623         dsc_i   = 0.743d0+x(61)
4624         dp2_i   = 1.9d0+x(62)
4625         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4626      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4627         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4628      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4629         s1=(1+x(63))/(0.1d0 + dscp1)
4630         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4631         s2=(1+x(65))/(0.1d0 + dscp2)
4632         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4633         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4634      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4635 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4636 c     &   sumene4,
4637 c     &   dscp1,dscp2,sumene
4638 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4639         escloc = escloc + sumene
4640 c        write (2,*) "escloc",escloc
4641         if (.not. calc_grad) goto 1
4642 #ifdef DEBUG
4643 C
4644 C This section to check the numerical derivatives of the energy of ith side
4645 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4646 C #define DEBUG in the code to turn it on.
4647 C
4648         write (2,*) "sumene               =",sumene
4649         aincr=1.0d-7
4650         xxsave=xx
4651         xx=xx+aincr
4652         write (2,*) xx,yy,zz
4653         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4654         de_dxx_num=(sumenep-sumene)/aincr
4655         xx=xxsave
4656         write (2,*) "xx+ sumene from enesc=",sumenep
4657         yysave=yy
4658         yy=yy+aincr
4659         write (2,*) xx,yy,zz
4660         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4661         de_dyy_num=(sumenep-sumene)/aincr
4662         yy=yysave
4663         write (2,*) "yy+ sumene from enesc=",sumenep
4664         zzsave=zz
4665         zz=zz+aincr
4666         write (2,*) xx,yy,zz
4667         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4668         de_dzz_num=(sumenep-sumene)/aincr
4669         zz=zzsave
4670         write (2,*) "zz+ sumene from enesc=",sumenep
4671         costsave=cost2tab(i+1)
4672         sintsave=sint2tab(i+1)
4673         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4674         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4675         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4676         de_dt_num=(sumenep-sumene)/aincr
4677         write (2,*) " t+ sumene from enesc=",sumenep
4678         cost2tab(i+1)=costsave
4679         sint2tab(i+1)=sintsave
4680 C End of diagnostics section.
4681 #endif
4682 C
4683 C Compute the gradient of esc
4684 C
4685         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4686         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4687         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4688         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4689         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4690         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4691         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4692         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4693         pom1=(sumene3*sint2tab(i+1)+sumene1)
4694      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4695         pom2=(sumene4*cost2tab(i+1)+sumene2)
4696      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4697         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4698         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4699      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4700      &  +x(40)*yy*zz
4701         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4702         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4703      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4704      &  +x(60)*yy*zz
4705         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4706      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4707      &        +(pom1+pom2)*pom_dx
4708 #ifdef DEBUG
4709         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4710 #endif
4711 C
4712         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4713         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4714      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4715      &  +x(40)*xx*zz
4716         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4717         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4718      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4719      &  +x(59)*zz**2 +x(60)*xx*zz
4720         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4721      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4722      &        +(pom1-pom2)*pom_dy
4723 #ifdef DEBUG
4724         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4725 #endif
4726 C
4727         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4728      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4729      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4730      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4731      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4732      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4733      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4734      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4735 #ifdef DEBUG
4736         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4737 #endif
4738 C
4739         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4740      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4741      &  +pom1*pom_dt1+pom2*pom_dt2
4742 #ifdef DEBUG
4743         write(2,*), "de_dt = ", de_dt,de_dt_num
4744 #endif
4745 c
4746 C
4747        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4748        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4749        cosfac2xx=cosfac2*xx
4750        sinfac2yy=sinfac2*yy
4751        do k = 1,3
4752          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4753      &      vbld_inv(i+1)
4754          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4755      &      vbld_inv(i)
4756          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4757          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4758 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4759 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4760 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4761 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4762          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4763          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4764          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4765          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4766          dZZ_Ci1(k)=0.0d0
4767          dZZ_Ci(k)=0.0d0
4768          do j=1,3
4769            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4770            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4771          enddo
4772
4773          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4774          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4775          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4776 c
4777          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4778          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4779        enddo
4780
4781        do k=1,3
4782          dXX_Ctab(k,i)=dXX_Ci(k)
4783          dXX_C1tab(k,i)=dXX_Ci1(k)
4784          dYY_Ctab(k,i)=dYY_Ci(k)
4785          dYY_C1tab(k,i)=dYY_Ci1(k)
4786          dZZ_Ctab(k,i)=dZZ_Ci(k)
4787          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4788          dXX_XYZtab(k,i)=dXX_XYZ(k)
4789          dYY_XYZtab(k,i)=dYY_XYZ(k)
4790          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4791        enddo
4792
4793        do k = 1,3
4794 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4795 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4796 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4797 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4798 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4799 c     &    dt_dci(k)
4800 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4801 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4802          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4803      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4804          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4805      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4806          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4807      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4808        enddo
4809 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4810 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4811
4812 C to check gradient call subroutine check_grad
4813
4814     1 continue
4815       enddo
4816       return
4817       end
4818 #endif
4819 c------------------------------------------------------------------------------
4820       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4821 C
4822 C This procedure calculates two-body contact function g(rij) and its derivative:
4823 C
4824 C           eps0ij                                     !       x < -1
4825 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4826 C            0                                         !       x > 1
4827 C
4828 C where x=(rij-r0ij)/delta
4829 C
4830 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4831 C
4832       implicit none
4833       double precision rij,r0ij,eps0ij,fcont,fprimcont
4834       double precision x,x2,x4,delta
4835 c     delta=0.02D0*r0ij
4836 c      delta=0.2D0*r0ij
4837       x=(rij-r0ij)/delta
4838       if (x.lt.-1.0D0) then
4839         fcont=eps0ij
4840         fprimcont=0.0D0
4841       else if (x.le.1.0D0) then
4842         x2=x*x
4843         x4=x2*x2
4844         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4845         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4846       else
4847         fcont=0.0D0
4848         fprimcont=0.0D0
4849       endif
4850       return
4851       end
4852 c------------------------------------------------------------------------------
4853       subroutine splinthet(theti,delta,ss,ssder)
4854       implicit real*8 (a-h,o-z)
4855       include 'DIMENSIONS'
4856       include 'sizesclu.dat'
4857       include 'COMMON.VAR'
4858       include 'COMMON.GEO'
4859       thetup=pi-delta
4860       thetlow=delta
4861       if (theti.gt.pipol) then
4862         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4863       else
4864         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4865         ssder=-ssder
4866       endif
4867       return
4868       end
4869 c------------------------------------------------------------------------------
4870       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4871       implicit none
4872       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4873       double precision ksi,ksi2,ksi3,a1,a2,a3
4874       a1=fprim0*delta/(f1-f0)
4875       a2=3.0d0-2.0d0*a1
4876       a3=a1-2.0d0
4877       ksi=(x-x0)/delta
4878       ksi2=ksi*ksi
4879       ksi3=ksi2*ksi
4880       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4881       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4882       return
4883       end
4884 c------------------------------------------------------------------------------
4885       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4886       implicit none
4887       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4888       double precision ksi,ksi2,ksi3,a1,a2,a3
4889       ksi=(x-x0)/delta
4890       ksi2=ksi*ksi
4891       ksi3=ksi2*ksi
4892       a1=fprim0x*delta
4893       a2=3*(f1x-f0x)-2*fprim0x*delta
4894       a3=fprim0x*delta-2*(f1x-f0x)
4895       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4896       return
4897       end
4898 C-----------------------------------------------------------------------------
4899 #ifdef CRYST_TOR
4900 C-----------------------------------------------------------------------------
4901       subroutine etor(etors,edihcnstr,fact)
4902       implicit real*8 (a-h,o-z)
4903       include 'DIMENSIONS'
4904       include 'sizesclu.dat'
4905       include 'COMMON.VAR'
4906       include 'COMMON.GEO'
4907       include 'COMMON.LOCAL'
4908       include 'COMMON.TORSION'
4909       include 'COMMON.INTERACT'
4910       include 'COMMON.DERIV'
4911       include 'COMMON.CHAIN'
4912       include 'COMMON.NAMES'
4913       include 'COMMON.IOUNITS'
4914       include 'COMMON.FFIELD'
4915       include 'COMMON.TORCNSTR'
4916       logical lprn
4917 C Set lprn=.true. for debugging
4918       lprn=.false.
4919 c      lprn=.true.
4920       etors=0.0D0
4921       do i=iphi_start,iphi_end
4922         itori=itortyp(itype(i-2))
4923         itori1=itortyp(itype(i-1))
4924         phii=phi(i)
4925         gloci=0.0D0
4926 C Proline-Proline pair is a special case...
4927         if (itori.eq.3 .and. itori1.eq.3) then
4928           if (phii.gt.-dwapi3) then
4929             cosphi=dcos(3*phii)
4930             fac=1.0D0/(1.0D0-cosphi)
4931             etorsi=v1(1,3,3)*fac
4932             etorsi=etorsi+etorsi
4933             etors=etors+etorsi-v1(1,3,3)
4934             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4935           endif
4936           do j=1,3
4937             v1ij=v1(j+1,itori,itori1)
4938             v2ij=v2(j+1,itori,itori1)
4939             cosphi=dcos(j*phii)
4940             sinphi=dsin(j*phii)
4941             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4942             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4943           enddo
4944         else
4945           do j=1,nterm_old
4946             v1ij=v1(j,itori,itori1)
4947             v2ij=v2(j,itori,itori1)
4948             cosphi=dcos(j*phii)
4949             sinphi=dsin(j*phii)
4950             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4951             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4952           enddo
4953         endif
4954         if (lprn)
4955      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4956      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4957      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4958         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4959 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4960       enddo
4961 ! 6/20/98 - dihedral angle constraints
4962       edihcnstr=0.0d0
4963       do i=1,ndih_constr
4964         itori=idih_constr(i)
4965         phii=phi(itori)
4966         difi=pinorm(phii-phi0(i))
4967         if (difi.gt.drange(i)) then
4968           difi=difi-drange(i)
4969           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4970           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4971         else if (difi.lt.-drange(i)) then
4972           difi=difi+drange(i)
4973           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4974           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4975         endif
4976 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4977 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4978       enddo
4979       write (iout,*) 'edihcnstr',edihcnstr
4980       return
4981       end
4982 c------------------------------------------------------------------------------
4983 #else
4984       subroutine etor(etors,edihcnstr,fact)
4985       implicit real*8 (a-h,o-z)
4986       include 'DIMENSIONS'
4987       include 'sizesclu.dat'
4988       include 'COMMON.VAR'
4989       include 'COMMON.GEO'
4990       include 'COMMON.LOCAL'
4991       include 'COMMON.TORSION'
4992       include 'COMMON.INTERACT'
4993       include 'COMMON.DERIV'
4994       include 'COMMON.CHAIN'
4995       include 'COMMON.NAMES'
4996       include 'COMMON.IOUNITS'
4997       include 'COMMON.FFIELD'
4998       include 'COMMON.TORCNSTR'
4999       logical lprn
5000 C Set lprn=.true. for debugging
5001       lprn=.false.
5002 c      lprn=.true.
5003       etors=0.0D0
5004       do i=iphi_start,iphi_end
5005         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5006         itori=itortyp(itype(i-2))
5007         itori1=itortyp(itype(i-1))
5008         phii=phi(i)
5009         gloci=0.0D0
5010 C Regular cosine and sine terms
5011         do j=1,nterm(itori,itori1)
5012           v1ij=v1(j,itori,itori1)
5013           v2ij=v2(j,itori,itori1)
5014           cosphi=dcos(j*phii)
5015           sinphi=dsin(j*phii)
5016           etors=etors+v1ij*cosphi+v2ij*sinphi
5017           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5018         enddo
5019 C Lorentz terms
5020 C                         v1
5021 C  E = SUM ----------------------------------- - v1
5022 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5023 C
5024         cosphi=dcos(0.5d0*phii)
5025         sinphi=dsin(0.5d0*phii)
5026         do j=1,nlor(itori,itori1)
5027           vl1ij=vlor1(j,itori,itori1)
5028           vl2ij=vlor2(j,itori,itori1)
5029           vl3ij=vlor3(j,itori,itori1)
5030           pom=vl2ij*cosphi+vl3ij*sinphi
5031           pom1=1.0d0/(pom*pom+1.0d0)
5032           etors=etors+vl1ij*pom1
5033           pom=-pom*pom1*pom1
5034           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5035         enddo
5036 C Subtract the constant term
5037         etors=etors-v0(itori,itori1)
5038         if (lprn)
5039      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5040      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5041      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5042         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5043 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5044  1215   continue
5045       enddo
5046 ! 6/20/98 - dihedral angle constraints
5047       edihcnstr=0.0d0
5048 c      write (iout,*) "Dihedral angle restraint energy"
5049       do i=1,ndih_constr
5050         itori=idih_constr(i)
5051         phii=phi(itori)
5052         difi=pinorm(phii-phi0(i))
5053 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5054 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5055         if (difi.gt.drange(i)) then
5056           difi=difi-drange(i)
5057           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5058           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5059 c          write (iout,*) 0.25d0*ftors*difi**4
5060         else if (difi.lt.-drange(i)) then
5061           difi=difi+drange(i)
5062           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5063           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5064 c          write (iout,*) 0.25d0*ftors*difi**4
5065         endif
5066       enddo
5067 c      write (iout,*) 'edihcnstr',edihcnstr
5068       return
5069       end
5070 c----------------------------------------------------------------------------
5071       subroutine etor_d(etors_d,fact2)
5072 C 6/23/01 Compute double torsional energy
5073       implicit real*8 (a-h,o-z)
5074       include 'DIMENSIONS'
5075       include 'sizesclu.dat'
5076       include 'COMMON.VAR'
5077       include 'COMMON.GEO'
5078       include 'COMMON.LOCAL'
5079       include 'COMMON.TORSION'
5080       include 'COMMON.INTERACT'
5081       include 'COMMON.DERIV'
5082       include 'COMMON.CHAIN'
5083       include 'COMMON.NAMES'
5084       include 'COMMON.IOUNITS'
5085       include 'COMMON.FFIELD'
5086       include 'COMMON.TORCNSTR'
5087       logical lprn
5088 C Set lprn=.true. for debugging
5089       lprn=.false.
5090 c     lprn=.true.
5091       etors_d=0.0D0
5092       do i=iphi_start,iphi_end-1
5093         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5094      &     goto 1215
5095         itori=itortyp(itype(i-2))
5096         itori1=itortyp(itype(i-1))
5097         itori2=itortyp(itype(i))
5098         phii=phi(i)
5099         phii1=phi(i+1)
5100         gloci1=0.0D0
5101         gloci2=0.0D0
5102 C Regular cosine and sine terms
5103         do j=1,ntermd_1(itori,itori1,itori2)
5104           v1cij=v1c(1,j,itori,itori1,itori2)
5105           v1sij=v1s(1,j,itori,itori1,itori2)
5106           v2cij=v1c(2,j,itori,itori1,itori2)
5107           v2sij=v1s(2,j,itori,itori1,itori2)
5108           cosphi1=dcos(j*phii)
5109           sinphi1=dsin(j*phii)
5110           cosphi2=dcos(j*phii1)
5111           sinphi2=dsin(j*phii1)
5112           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5113      &     v2cij*cosphi2+v2sij*sinphi2
5114           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5115           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5116         enddo
5117         do k=2,ntermd_2(itori,itori1,itori2)
5118           do l=1,k-1
5119             v1cdij = v2c(k,l,itori,itori1,itori2)
5120             v2cdij = v2c(l,k,itori,itori1,itori2)
5121             v1sdij = v2s(k,l,itori,itori1,itori2)
5122             v2sdij = v2s(l,k,itori,itori1,itori2)
5123             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5124             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5125             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5126             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5127             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5128      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5129             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5130      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5131             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5132      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5133           enddo
5134         enddo
5135         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5136         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5137  1215   continue
5138       enddo
5139       return
5140       end
5141 #endif
5142 c------------------------------------------------------------------------------
5143       subroutine eback_sc_corr(esccor,fact)
5144 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5145 c        conformational states; temporarily implemented as differences
5146 c        between UNRES torsional potentials (dependent on three types of
5147 c        residues) and the torsional potentials dependent on all 20 types
5148 c        of residues computed from AM1 energy surfaces of terminally-blocked
5149 c        amino-acid residues.
5150       implicit real*8 (a-h,o-z)
5151       include 'DIMENSIONS'
5152       include 'COMMON.VAR'
5153       include 'COMMON.GEO'
5154       include 'COMMON.LOCAL'
5155       include 'COMMON.TORSION'
5156       include 'COMMON.SCCOR'
5157       include 'COMMON.INTERACT'
5158       include 'COMMON.DERIV'
5159       include 'COMMON.CHAIN'
5160       include 'COMMON.NAMES'
5161       include 'COMMON.IOUNITS'
5162       include 'COMMON.FFIELD'
5163       include 'COMMON.CONTROL'
5164       logical lprn
5165 C Set lprn=.true. for debugging
5166       lprn=.false.
5167 c      lprn=.true.
5168 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5169       esccor=0.0D0
5170       do i=itau_start,itau_end
5171         esccor_ii=0.0D0
5172         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5173         isccori=isccortyp(itype(i-2))
5174         isccori1=isccortyp(itype(i-1))
5175         phii=phi(i)
5176 cccc  Added 9 May 2012
5177 cc Tauangle is torsional engle depending on the value of first digit
5178 c(see comment below)
5179 cc Omicron is flat angle depending on the value of first digit
5180 c(see comment below)
5181
5182
5183         do intertyp=1,3 !intertyp
5184 cc Added 09 May 2012 (Adasko)
5185 cc  Intertyp means interaction type of backbone mainchain correlation:
5186 c   1 = SC...Ca...Ca...Ca
5187 c   2 = Ca...Ca...Ca...SC
5188 c   3 = SC...Ca...Ca...SCi
5189         gloci=0.0D0
5190         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5191      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5192      &      (itype(i-1).eq.21)))
5193      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5194      &     .or.(itype(i-2).eq.21)))
5195      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5196      &      (itype(i-1).eq.21)))) cycle
5197         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5198         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5199      & cycle
5200         do j=1,nterm_sccor(isccori,isccori1)
5201           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5202           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5203           cosphi=dcos(j*tauangle(intertyp,i))
5204           sinphi=dsin(j*tauangle(intertyp,i))
5205           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5206 #ifdef DEBUG
5207           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5208 #endif
5209           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5210         enddo
5211         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5212 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5213 c     &gloc_sc(intertyp,i-3,icg)
5214         if (lprn)
5215      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5216      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5217      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5218      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5219         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5220        enddo !intertyp
5221 #ifdef DEBUG
5222        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5223 #endif
5224       enddo
5225
5226       return
5227       end
5228 c------------------------------------------------------------------------------
5229       subroutine multibody(ecorr)
5230 C This subroutine calculates multi-body contributions to energy following
5231 C the idea of Skolnick et al. If side chains I and J make a contact and
5232 C at the same time side chains I+1 and J+1 make a contact, an extra
5233 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5234       implicit real*8 (a-h,o-z)
5235       include 'DIMENSIONS'
5236       include 'COMMON.IOUNITS'
5237       include 'COMMON.DERIV'
5238       include 'COMMON.INTERACT'
5239       include 'COMMON.CONTACTS'
5240       double precision gx(3),gx1(3)
5241       logical lprn
5242
5243 C Set lprn=.true. for debugging
5244       lprn=.false.
5245
5246       if (lprn) then
5247         write (iout,'(a)') 'Contact function values:'
5248         do i=nnt,nct-2
5249           write (iout,'(i2,20(1x,i2,f10.5))')
5250      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5251         enddo
5252       endif
5253       ecorr=0.0D0
5254       do i=nnt,nct
5255         do j=1,3
5256           gradcorr(j,i)=0.0D0
5257           gradxorr(j,i)=0.0D0
5258         enddo
5259       enddo
5260       do i=nnt,nct-2
5261
5262         DO ISHIFT = 3,4
5263
5264         i1=i+ishift
5265         num_conti=num_cont(i)
5266         num_conti1=num_cont(i1)
5267         do jj=1,num_conti
5268           j=jcont(jj,i)
5269           do kk=1,num_conti1
5270             j1=jcont(kk,i1)
5271             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5272 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5273 cd   &                   ' ishift=',ishift
5274 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5275 C The system gains extra energy.
5276               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5277             endif   ! j1==j+-ishift
5278           enddo     ! kk
5279         enddo       ! jj
5280
5281         ENDDO ! ISHIFT
5282
5283       enddo         ! i
5284       return
5285       end
5286 c------------------------------------------------------------------------------
5287       double precision function esccorr(i,j,k,l,jj,kk)
5288       implicit real*8 (a-h,o-z)
5289       include 'DIMENSIONS'
5290       include 'COMMON.IOUNITS'
5291       include 'COMMON.DERIV'
5292       include 'COMMON.INTERACT'
5293       include 'COMMON.CONTACTS'
5294       double precision gx(3),gx1(3)
5295       logical lprn
5296       lprn=.false.
5297       eij=facont(jj,i)
5298       ekl=facont(kk,k)
5299 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5300 C Calculate the multi-body contribution to energy.
5301 C Calculate multi-body contributions to the gradient.
5302 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5303 cd   & k,l,(gacont(m,kk,k),m=1,3)
5304       do m=1,3
5305         gx(m) =ekl*gacont(m,jj,i)
5306         gx1(m)=eij*gacont(m,kk,k)
5307         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5308         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5309         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5310         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5311       enddo
5312       do m=i,j-1
5313         do ll=1,3
5314           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5315         enddo
5316       enddo
5317       do m=k,l-1
5318         do ll=1,3
5319           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5320         enddo
5321       enddo
5322       esccorr=-eij*ekl
5323       return
5324       end
5325 c------------------------------------------------------------------------------
5326 #ifdef MPL
5327       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5328       implicit real*8 (a-h,o-z)
5329       include 'DIMENSIONS'
5330       integer dimen1,dimen2,atom,indx
5331       double precision buffer(dimen1,dimen2)
5332       double precision zapas
5333       common /contacts_hb/ zapas(3,20,maxres,7),
5334      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5335      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5336       num_kont=num_cont_hb(atom)
5337       do i=1,num_kont
5338         do k=1,7
5339           do j=1,3
5340             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5341           enddo ! j
5342         enddo ! k
5343         buffer(i,indx+22)=facont_hb(i,atom)
5344         buffer(i,indx+23)=ees0p(i,atom)
5345         buffer(i,indx+24)=ees0m(i,atom)
5346         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5347       enddo ! i
5348       buffer(1,indx+26)=dfloat(num_kont)
5349       return
5350       end
5351 c------------------------------------------------------------------------------
5352       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5353       implicit real*8 (a-h,o-z)
5354       include 'DIMENSIONS'
5355       integer dimen1,dimen2,atom,indx
5356       double precision buffer(dimen1,dimen2)
5357       double precision zapas
5358       common /contacts_hb/ zapas(3,20,maxres,7),
5359      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5360      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5361       num_kont=buffer(1,indx+26)
5362       num_kont_old=num_cont_hb(atom)
5363       num_cont_hb(atom)=num_kont+num_kont_old
5364       do i=1,num_kont
5365         ii=i+num_kont_old
5366         do k=1,7
5367           do j=1,3
5368             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5369           enddo ! j
5370         enddo ! k
5371         facont_hb(ii,atom)=buffer(i,indx+22)
5372         ees0p(ii,atom)=buffer(i,indx+23)
5373         ees0m(ii,atom)=buffer(i,indx+24)
5374         jcont_hb(ii,atom)=buffer(i,indx+25)
5375       enddo ! i
5376       return
5377       end
5378 c------------------------------------------------------------------------------
5379 #endif
5380       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5381 C This subroutine calculates multi-body contributions to hydrogen-bonding
5382       implicit real*8 (a-h,o-z)
5383       include 'DIMENSIONS'
5384       include 'sizesclu.dat'
5385       include 'COMMON.IOUNITS'
5386 #ifdef MPL
5387       include 'COMMON.INFO'
5388 #endif
5389       include 'COMMON.FFIELD'
5390       include 'COMMON.DERIV'
5391       include 'COMMON.INTERACT'
5392       include 'COMMON.CONTACTS'
5393 #ifdef MPL
5394       parameter (max_cont=maxconts)
5395       parameter (max_dim=2*(8*3+2))
5396       parameter (msglen1=max_cont*max_dim*4)
5397       parameter (msglen2=2*msglen1)
5398       integer source,CorrelType,CorrelID,Error
5399       double precision buffer(max_cont,max_dim)
5400 #endif
5401       double precision gx(3),gx1(3)
5402       logical lprn,ldone
5403
5404 C Set lprn=.true. for debugging
5405       lprn=.false.
5406 #ifdef MPL
5407       n_corr=0
5408       n_corr1=0
5409       if (fgProcs.le.1) goto 30
5410       if (lprn) then
5411         write (iout,'(a)') 'Contact function values:'
5412         do i=nnt,nct-2
5413           write (iout,'(2i3,50(1x,i2,f5.2))')
5414      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5415      &    j=1,num_cont_hb(i))
5416         enddo
5417       endif
5418 C Caution! Following code assumes that electrostatic interactions concerning
5419 C a given atom are split among at most two processors!
5420       CorrelType=477
5421       CorrelID=MyID+1
5422       ldone=.false.
5423       do i=1,max_cont
5424         do j=1,max_dim
5425           buffer(i,j)=0.0D0
5426         enddo
5427       enddo
5428       mm=mod(MyRank,2)
5429 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5430       if (mm) 20,20,10
5431    10 continue
5432 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5433       if (MyRank.gt.0) then
5434 C Send correlation contributions to the preceding processor
5435         msglen=msglen1
5436         nn=num_cont_hb(iatel_s)
5437         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5438 cd      write (iout,*) 'The BUFFER array:'
5439 cd      do i=1,nn
5440 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5441 cd      enddo
5442         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5443           msglen=msglen2
5444             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5445 C Clear the contacts of the atom passed to the neighboring processor
5446         nn=num_cont_hb(iatel_s+1)
5447 cd      do i=1,nn
5448 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5449 cd      enddo
5450             num_cont_hb(iatel_s)=0
5451         endif
5452 cd      write (iout,*) 'Processor ',MyID,MyRank,
5453 cd   & ' is sending correlation contribution to processor',MyID-1,
5454 cd   & ' msglen=',msglen
5455 cd      write (*,*) 'Processor ',MyID,MyRank,
5456 cd   & ' is sending correlation contribution to processor',MyID-1,
5457 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5458         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5459 cd      write (iout,*) 'Processor ',MyID,
5460 cd   & ' has sent correlation contribution to processor',MyID-1,
5461 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5462 cd      write (*,*) 'Processor ',MyID,
5463 cd   & ' has sent correlation contribution to processor',MyID-1,
5464 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5465         msglen=msglen1
5466       endif ! (MyRank.gt.0)
5467       if (ldone) goto 30
5468       ldone=.true.
5469    20 continue
5470 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5471       if (MyRank.lt.fgProcs-1) then
5472 C Receive correlation contributions from the next processor
5473         msglen=msglen1
5474         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5475 cd      write (iout,*) 'Processor',MyID,
5476 cd   & ' is receiving correlation contribution from processor',MyID+1,
5477 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5478 cd      write (*,*) 'Processor',MyID,
5479 cd   & ' is receiving correlation contribution from processor',MyID+1,
5480 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5481         nbytes=-1
5482         do while (nbytes.le.0)
5483           call mp_probe(MyID+1,CorrelType,nbytes)
5484         enddo
5485 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5486         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5487 cd      write (iout,*) 'Processor',MyID,
5488 cd   & ' has received correlation contribution from processor',MyID+1,
5489 cd   & ' msglen=',msglen,' nbytes=',nbytes
5490 cd      write (iout,*) 'The received BUFFER array:'
5491 cd      do i=1,max_cont
5492 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5493 cd      enddo
5494         if (msglen.eq.msglen1) then
5495           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5496         else if (msglen.eq.msglen2)  then
5497           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5498           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5499         else
5500           write (iout,*)
5501      & 'ERROR!!!! message length changed while processing correlations.'
5502           write (*,*)
5503      & 'ERROR!!!! message length changed while processing correlations.'
5504           call mp_stopall(Error)
5505         endif ! msglen.eq.msglen1
5506       endif ! MyRank.lt.fgProcs-1
5507       if (ldone) goto 30
5508       ldone=.true.
5509       goto 10
5510    30 continue
5511 #endif
5512       if (lprn) then
5513         write (iout,'(a)') 'Contact function values:'
5514         do i=nnt,nct-2
5515           write (iout,'(2i3,50(1x,i2,f5.2))')
5516      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5517      &    j=1,num_cont_hb(i))
5518         enddo
5519       endif
5520       ecorr=0.0D0
5521 C Remove the loop below after debugging !!!
5522       do i=nnt,nct
5523         do j=1,3
5524           gradcorr(j,i)=0.0D0
5525           gradxorr(j,i)=0.0D0
5526         enddo
5527       enddo
5528 C Calculate the local-electrostatic correlation terms
5529       do i=iatel_s,iatel_e+1
5530         i1=i+1
5531         num_conti=num_cont_hb(i)
5532         num_conti1=num_cont_hb(i+1)
5533         do jj=1,num_conti
5534           j=jcont_hb(jj,i)
5535           do kk=1,num_conti1
5536             j1=jcont_hb(kk,i1)
5537 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5538 c     &         ' jj=',jj,' kk=',kk
5539             if (j1.eq.j+1 .or. j1.eq.j-1) then
5540 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5541 C The system gains extra energy.
5542               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5543               n_corr=n_corr+1
5544             else if (j1.eq.j) then
5545 C Contacts I-J and I-(J+1) occur simultaneously.
5546 C The system loses extra energy.
5547 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5548             endif
5549           enddo ! kk
5550           do kk=1,num_conti
5551             j1=jcont_hb(kk,i)
5552 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5553 c    &         ' jj=',jj,' kk=',kk
5554             if (j1.eq.j+1) then
5555 C Contacts I-J and (I+1)-J occur simultaneously.
5556 C The system loses extra energy.
5557 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5558             endif ! j1==j+1
5559           enddo ! kk
5560         enddo ! jj
5561       enddo ! i
5562       return
5563       end
5564 c------------------------------------------------------------------------------
5565       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5566      &  n_corr1)
5567 C This subroutine calculates multi-body contributions to hydrogen-bonding
5568       implicit real*8 (a-h,o-z)
5569       include 'DIMENSIONS'
5570       include 'sizesclu.dat'
5571       include 'COMMON.IOUNITS'
5572 #ifdef MPL
5573       include 'COMMON.INFO'
5574 #endif
5575       include 'COMMON.FFIELD'
5576       include 'COMMON.DERIV'
5577       include 'COMMON.INTERACT'
5578       include 'COMMON.CONTACTS'
5579 #ifdef MPL
5580       parameter (max_cont=maxconts)
5581       parameter (max_dim=2*(8*3+2))
5582       parameter (msglen1=max_cont*max_dim*4)
5583       parameter (msglen2=2*msglen1)
5584       integer source,CorrelType,CorrelID,Error
5585       double precision buffer(max_cont,max_dim)
5586 #endif
5587       double precision gx(3),gx1(3)
5588       logical lprn,ldone
5589
5590 C Set lprn=.true. for debugging
5591       lprn=.false.
5592       eturn6=0.0d0
5593       ecorr6=0.0d0
5594 #ifdef MPL
5595       n_corr=0
5596       n_corr1=0
5597       if (fgProcs.le.1) goto 30
5598       if (lprn) then
5599         write (iout,'(a)') 'Contact function values:'
5600         do i=nnt,nct-2
5601           write (iout,'(2i3,50(1x,i2,f5.2))')
5602      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5603      &    j=1,num_cont_hb(i))
5604         enddo
5605       endif
5606 C Caution! Following code assumes that electrostatic interactions concerning
5607 C a given atom are split among at most two processors!
5608       CorrelType=477
5609       CorrelID=MyID+1
5610       ldone=.false.
5611       do i=1,max_cont
5612         do j=1,max_dim
5613           buffer(i,j)=0.0D0
5614         enddo
5615       enddo
5616       mm=mod(MyRank,2)
5617 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5618       if (mm) 20,20,10
5619    10 continue
5620 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5621       if (MyRank.gt.0) then
5622 C Send correlation contributions to the preceding processor
5623         msglen=msglen1
5624         nn=num_cont_hb(iatel_s)
5625         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5626 cd      write (iout,*) 'The BUFFER array:'
5627 cd      do i=1,nn
5628 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5629 cd      enddo
5630         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5631           msglen=msglen2
5632             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5633 C Clear the contacts of the atom passed to the neighboring processor
5634         nn=num_cont_hb(iatel_s+1)
5635 cd      do i=1,nn
5636 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5637 cd      enddo
5638             num_cont_hb(iatel_s)=0
5639         endif
5640 cd      write (iout,*) 'Processor ',MyID,MyRank,
5641 cd   & ' is sending correlation contribution to processor',MyID-1,
5642 cd   & ' msglen=',msglen
5643 cd      write (*,*) 'Processor ',MyID,MyRank,
5644 cd   & ' is sending correlation contribution to processor',MyID-1,
5645 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5646         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5647 cd      write (iout,*) 'Processor ',MyID,
5648 cd   & ' has sent correlation contribution to processor',MyID-1,
5649 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5650 cd      write (*,*) 'Processor ',MyID,
5651 cd   & ' has sent correlation contribution to processor',MyID-1,
5652 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5653         msglen=msglen1
5654       endif ! (MyRank.gt.0)
5655       if (ldone) goto 30
5656       ldone=.true.
5657    20 continue
5658 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5659       if (MyRank.lt.fgProcs-1) then
5660 C Receive correlation contributions from the next processor
5661         msglen=msglen1
5662         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5663 cd      write (iout,*) 'Processor',MyID,
5664 cd   & ' is receiving correlation contribution from processor',MyID+1,
5665 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5666 cd      write (*,*) 'Processor',MyID,
5667 cd   & ' is receiving correlation contribution from processor',MyID+1,
5668 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5669         nbytes=-1
5670         do while (nbytes.le.0)
5671           call mp_probe(MyID+1,CorrelType,nbytes)
5672         enddo
5673 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5674         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5675 cd      write (iout,*) 'Processor',MyID,
5676 cd   & ' has received correlation contribution from processor',MyID+1,
5677 cd   & ' msglen=',msglen,' nbytes=',nbytes
5678 cd      write (iout,*) 'The received BUFFER array:'
5679 cd      do i=1,max_cont
5680 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5681 cd      enddo
5682         if (msglen.eq.msglen1) then
5683           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5684         else if (msglen.eq.msglen2)  then
5685           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5686           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5687         else
5688           write (iout,*)
5689      & 'ERROR!!!! message length changed while processing correlations.'
5690           write (*,*)
5691      & 'ERROR!!!! message length changed while processing correlations.'
5692           call mp_stopall(Error)
5693         endif ! msglen.eq.msglen1
5694       endif ! MyRank.lt.fgProcs-1
5695       if (ldone) goto 30
5696       ldone=.true.
5697       goto 10
5698    30 continue
5699 #endif
5700       if (lprn) then
5701         write (iout,'(a)') 'Contact function values:'
5702         do i=nnt,nct-2
5703           write (iout,'(2i3,50(1x,i2,f5.2))')
5704      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5705      &    j=1,num_cont_hb(i))
5706         enddo
5707       endif
5708       ecorr=0.0D0
5709       ecorr5=0.0d0
5710       ecorr6=0.0d0
5711 C Remove the loop below after debugging !!!
5712       do i=nnt,nct
5713         do j=1,3
5714           gradcorr(j,i)=0.0D0
5715           gradxorr(j,i)=0.0D0
5716         enddo
5717       enddo
5718 C Calculate the dipole-dipole interaction energies
5719       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5720       do i=iatel_s,iatel_e+1
5721         num_conti=num_cont_hb(i)
5722         do jj=1,num_conti
5723           j=jcont_hb(jj,i)
5724           call dipole(i,j,jj)
5725         enddo
5726       enddo
5727       endif
5728 C Calculate the local-electrostatic correlation terms
5729       do i=iatel_s,iatel_e+1
5730         i1=i+1
5731         num_conti=num_cont_hb(i)
5732         num_conti1=num_cont_hb(i+1)
5733         do jj=1,num_conti
5734           j=jcont_hb(jj,i)
5735           do kk=1,num_conti1
5736             j1=jcont_hb(kk,i1)
5737 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5738 c     &         ' jj=',jj,' kk=',kk
5739             if (j1.eq.j+1 .or. j1.eq.j-1) then
5740 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5741 C The system gains extra energy.
5742               n_corr=n_corr+1
5743               sqd1=dsqrt(d_cont(jj,i))
5744               sqd2=dsqrt(d_cont(kk,i1))
5745               sred_geom = sqd1*sqd2
5746               IF (sred_geom.lt.cutoff_corr) THEN
5747                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5748      &            ekont,fprimcont)
5749 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5750 c     &         ' jj=',jj,' kk=',kk
5751                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5752                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5753                 do l=1,3
5754                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5755                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5756                 enddo
5757                 n_corr1=n_corr1+1
5758 cd               write (iout,*) 'sred_geom=',sred_geom,
5759 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5760                 call calc_eello(i,j,i+1,j1,jj,kk)
5761                 if (wcorr4.gt.0.0d0)
5762      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5763                 if (wcorr5.gt.0.0d0)
5764      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5765 c                print *,"wcorr5",ecorr5
5766 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5767 cd                write(2,*)'ijkl',i,j,i+1,j1
5768                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5769      &               .or. wturn6.eq.0.0d0))then
5770 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5771 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5772 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5773 c     &            'ecorr6=',ecorr6, wcorr6
5774 cd                write (iout,'(4e15.5)') sred_geom,
5775 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5776 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5777 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5778                 else if (wturn6.gt.0.0d0
5779      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5780 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5781                   eturn6=eturn6+eello_turn6(i,jj,kk)
5782 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5783                 endif
5784               ENDIF
5785 1111          continue
5786             else if (j1.eq.j) then
5787 C Contacts I-J and I-(J+1) occur simultaneously.
5788 C The system loses extra energy.
5789 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5790             endif
5791           enddo ! kk
5792           do kk=1,num_conti
5793             j1=jcont_hb(kk,i)
5794 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5795 c    &         ' jj=',jj,' kk=',kk
5796             if (j1.eq.j+1) then
5797 C Contacts I-J and (I+1)-J occur simultaneously.
5798 C The system loses extra energy.
5799 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5800             endif ! j1==j+1
5801           enddo ! kk
5802         enddo ! jj
5803       enddo ! i
5804       return
5805       end
5806 c------------------------------------------------------------------------------
5807       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5808       implicit real*8 (a-h,o-z)
5809       include 'DIMENSIONS'
5810       include 'COMMON.IOUNITS'
5811       include 'COMMON.DERIV'
5812       include 'COMMON.INTERACT'
5813       include 'COMMON.CONTACTS'
5814       double precision gx(3),gx1(3)
5815       logical lprn
5816       lprn=.false.
5817       eij=facont_hb(jj,i)
5818       ekl=facont_hb(kk,k)
5819       ees0pij=ees0p(jj,i)
5820       ees0pkl=ees0p(kk,k)
5821       ees0mij=ees0m(jj,i)
5822       ees0mkl=ees0m(kk,k)
5823       ekont=eij*ekl
5824       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5825 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5826 C Following 4 lines for diagnostics.
5827 cd    ees0pkl=0.0D0
5828 cd    ees0pij=1.0D0
5829 cd    ees0mkl=0.0D0
5830 cd    ees0mij=1.0D0
5831 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5832 c    &   ' and',k,l
5833 c     write (iout,*)'Contacts have occurred for peptide groups',
5834 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5835 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5836 C Calculate the multi-body contribution to energy.
5837       ecorr=ecorr+ekont*ees
5838       if (calc_grad) then
5839 C Calculate multi-body contributions to the gradient.
5840       do ll=1,3
5841         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5842         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5843      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5844      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5845         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5846      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5847      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5848         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5849         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5850      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5851      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5852         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5853      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5854      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5855       enddo
5856       do m=i+1,j-1
5857         do ll=1,3
5858           gradcorr(ll,m)=gradcorr(ll,m)+
5859      &     ees*ekl*gacont_hbr(ll,jj,i)-
5860      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5861      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5862         enddo
5863       enddo
5864       do m=k+1,l-1
5865         do ll=1,3
5866           gradcorr(ll,m)=gradcorr(ll,m)+
5867      &     ees*eij*gacont_hbr(ll,kk,k)-
5868      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5869      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5870         enddo
5871       enddo
5872       endif
5873       ehbcorr=ekont*ees
5874       return
5875       end
5876 C---------------------------------------------------------------------------
5877       subroutine dipole(i,j,jj)
5878       implicit real*8 (a-h,o-z)
5879       include 'DIMENSIONS'
5880       include 'sizesclu.dat'
5881       include 'COMMON.IOUNITS'
5882       include 'COMMON.CHAIN'
5883       include 'COMMON.FFIELD'
5884       include 'COMMON.DERIV'
5885       include 'COMMON.INTERACT'
5886       include 'COMMON.CONTACTS'
5887       include 'COMMON.TORSION'
5888       include 'COMMON.VAR'
5889       include 'COMMON.GEO'
5890       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5891      &  auxmat(2,2)
5892       iti1 = itortyp(itype(i+1))
5893       if (j.lt.nres-1) then
5894         itj1 = itortyp(itype(j+1))
5895       else
5896         itj1=ntortyp+1
5897       endif
5898       do iii=1,2
5899         dipi(iii,1)=Ub2(iii,i)
5900         dipderi(iii)=Ub2der(iii,i)
5901         dipi(iii,2)=b1(iii,iti1)
5902         dipj(iii,1)=Ub2(iii,j)
5903         dipderj(iii)=Ub2der(iii,j)
5904         dipj(iii,2)=b1(iii,itj1)
5905       enddo
5906       kkk=0
5907       do iii=1,2
5908         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5909         do jjj=1,2
5910           kkk=kkk+1
5911           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5912         enddo
5913       enddo
5914       if (.not.calc_grad) return
5915       do kkk=1,5
5916         do lll=1,3
5917           mmm=0
5918           do iii=1,2
5919             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5920      &        auxvec(1))
5921             do jjj=1,2
5922               mmm=mmm+1
5923               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5924             enddo
5925           enddo
5926         enddo
5927       enddo
5928       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5929       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5930       do iii=1,2
5931         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5932       enddo
5933       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5934       do iii=1,2
5935         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5936       enddo
5937       return
5938       end
5939 C---------------------------------------------------------------------------
5940       subroutine calc_eello(i,j,k,l,jj,kk)
5941 C
5942 C This subroutine computes matrices and vectors needed to calculate
5943 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5944 C
5945       implicit real*8 (a-h,o-z)
5946       include 'DIMENSIONS'
5947       include 'sizesclu.dat'
5948       include 'COMMON.IOUNITS'
5949       include 'COMMON.CHAIN'
5950       include 'COMMON.DERIV'
5951       include 'COMMON.INTERACT'
5952       include 'COMMON.CONTACTS'
5953       include 'COMMON.TORSION'
5954       include 'COMMON.VAR'
5955       include 'COMMON.GEO'
5956       include 'COMMON.FFIELD'
5957       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5958      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5959       logical lprn
5960       common /kutas/ lprn
5961 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5962 cd     & ' jj=',jj,' kk=',kk
5963 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5964       do iii=1,2
5965         do jjj=1,2
5966           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5967           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5968         enddo
5969       enddo
5970       call transpose2(aa1(1,1),aa1t(1,1))
5971       call transpose2(aa2(1,1),aa2t(1,1))
5972       do kkk=1,5
5973         do lll=1,3
5974           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5975      &      aa1tder(1,1,lll,kkk))
5976           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5977      &      aa2tder(1,1,lll,kkk))
5978         enddo
5979       enddo
5980       if (l.eq.j+1) then
5981 C parallel orientation of the two CA-CA-CA frames.
5982         if (i.gt.1) then
5983           iti=itortyp(itype(i))
5984         else
5985           iti=ntortyp+1
5986         endif
5987         itk1=itortyp(itype(k+1))
5988         itj=itortyp(itype(j))
5989         if (l.lt.nres-1) then
5990           itl1=itortyp(itype(l+1))
5991         else
5992           itl1=ntortyp+1
5993         endif
5994 C A1 kernel(j+1) A2T
5995 cd        do iii=1,2
5996 cd          write (iout,'(3f10.5,5x,3f10.5)')
5997 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5998 cd        enddo
5999         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6000      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6001      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6002 C Following matrices are needed only for 6-th order cumulants
6003         IF (wcorr6.gt.0.0d0) THEN
6004         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6005      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6006      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6007         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6008      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6009      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6010      &   ADtEAderx(1,1,1,1,1,1))
6011         lprn=.false.
6012         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6013      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6014      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6015      &   ADtEA1derx(1,1,1,1,1,1))
6016         ENDIF
6017 C End 6-th order cumulants
6018 cd        lprn=.false.
6019 cd        if (lprn) then
6020 cd        write (2,*) 'In calc_eello6'
6021 cd        do iii=1,2
6022 cd          write (2,*) 'iii=',iii
6023 cd          do kkk=1,5
6024 cd            write (2,*) 'kkk=',kkk
6025 cd            do jjj=1,2
6026 cd              write (2,'(3(2f10.5),5x)')
6027 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6028 cd            enddo
6029 cd          enddo
6030 cd        enddo
6031 cd        endif
6032         call transpose2(EUgder(1,1,k),auxmat(1,1))
6033         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6034         call transpose2(EUg(1,1,k),auxmat(1,1))
6035         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6036         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6037         do iii=1,2
6038           do kkk=1,5
6039             do lll=1,3
6040               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6041      &          EAEAderx(1,1,lll,kkk,iii,1))
6042             enddo
6043           enddo
6044         enddo
6045 C A1T kernel(i+1) A2
6046         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6047      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6048      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6049 C Following matrices are needed only for 6-th order cumulants
6050         IF (wcorr6.gt.0.0d0) THEN
6051         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6052      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6053      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6054         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6055      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6056      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6057      &   ADtEAderx(1,1,1,1,1,2))
6058         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6059      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6060      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6061      &   ADtEA1derx(1,1,1,1,1,2))
6062         ENDIF
6063 C End 6-th order cumulants
6064         call transpose2(EUgder(1,1,l),auxmat(1,1))
6065         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6066         call transpose2(EUg(1,1,l),auxmat(1,1))
6067         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6068         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6069         do iii=1,2
6070           do kkk=1,5
6071             do lll=1,3
6072               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6073      &          EAEAderx(1,1,lll,kkk,iii,2))
6074             enddo
6075           enddo
6076         enddo
6077 C AEAb1 and AEAb2
6078 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6079 C They are needed only when the fifth- or the sixth-order cumulants are
6080 C indluded.
6081         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6082         call transpose2(AEA(1,1,1),auxmat(1,1))
6083         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6084         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6085         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6086         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6087         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6088         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6089         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6090         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6091         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6092         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6093         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6094         call transpose2(AEA(1,1,2),auxmat(1,1))
6095         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6096         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6097         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6098         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6099         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6100         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6101         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6102         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6103         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6104         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6105         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6106 C Calculate the Cartesian derivatives of the vectors.
6107         do iii=1,2
6108           do kkk=1,5
6109             do lll=1,3
6110               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6111               call matvec2(auxmat(1,1),b1(1,iti),
6112      &          AEAb1derx(1,lll,kkk,iii,1,1))
6113               call matvec2(auxmat(1,1),Ub2(1,i),
6114      &          AEAb2derx(1,lll,kkk,iii,1,1))
6115               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6116      &          AEAb1derx(1,lll,kkk,iii,2,1))
6117               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6118      &          AEAb2derx(1,lll,kkk,iii,2,1))
6119               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6120               call matvec2(auxmat(1,1),b1(1,itj),
6121      &          AEAb1derx(1,lll,kkk,iii,1,2))
6122               call matvec2(auxmat(1,1),Ub2(1,j),
6123      &          AEAb2derx(1,lll,kkk,iii,1,2))
6124               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6125      &          AEAb1derx(1,lll,kkk,iii,2,2))
6126               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6127      &          AEAb2derx(1,lll,kkk,iii,2,2))
6128             enddo
6129           enddo
6130         enddo
6131         ENDIF
6132 C End vectors
6133       else
6134 C Antiparallel orientation of the two CA-CA-CA frames.
6135         if (i.gt.1) then
6136           iti=itortyp(itype(i))
6137         else
6138           iti=ntortyp+1
6139         endif
6140         itk1=itortyp(itype(k+1))
6141         itl=itortyp(itype(l))
6142         itj=itortyp(itype(j))
6143         if (j.lt.nres-1) then
6144           itj1=itortyp(itype(j+1))
6145         else
6146           itj1=ntortyp+1
6147         endif
6148 C A2 kernel(j-1)T A1T
6149         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6150      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6151      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6152 C Following matrices are needed only for 6-th order cumulants
6153         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6154      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6155         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6156      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6157      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6158         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6159      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6160      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6161      &   ADtEAderx(1,1,1,1,1,1))
6162         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6163      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6164      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6165      &   ADtEA1derx(1,1,1,1,1,1))
6166         ENDIF
6167 C End 6-th order cumulants
6168         call transpose2(EUgder(1,1,k),auxmat(1,1))
6169         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6170         call transpose2(EUg(1,1,k),auxmat(1,1))
6171         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6172         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6173         do iii=1,2
6174           do kkk=1,5
6175             do lll=1,3
6176               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6177      &          EAEAderx(1,1,lll,kkk,iii,1))
6178             enddo
6179           enddo
6180         enddo
6181 C A2T kernel(i+1)T A1
6182         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6183      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6184      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6185 C Following matrices are needed only for 6-th order cumulants
6186         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6187      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6188         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6189      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6190      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6192      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6193      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6194      &   ADtEAderx(1,1,1,1,1,2))
6195         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6196      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6197      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6198      &   ADtEA1derx(1,1,1,1,1,2))
6199         ENDIF
6200 C End 6-th order cumulants
6201         call transpose2(EUgder(1,1,j),auxmat(1,1))
6202         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6203         call transpose2(EUg(1,1,j),auxmat(1,1))
6204         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6205         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6206         do iii=1,2
6207           do kkk=1,5
6208             do lll=1,3
6209               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6210      &          EAEAderx(1,1,lll,kkk,iii,2))
6211             enddo
6212           enddo
6213         enddo
6214 C AEAb1 and AEAb2
6215 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6216 C They are needed only when the fifth- or the sixth-order cumulants are
6217 C indluded.
6218         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6219      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6220         call transpose2(AEA(1,1,1),auxmat(1,1))
6221         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6222         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6223         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6224         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6225         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6226         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6227         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6228         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6229         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6230         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6231         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6232         call transpose2(AEA(1,1,2),auxmat(1,1))
6233         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6234         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6235         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6236         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6237         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6238         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6239         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6240         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6241         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6242         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6243         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6244 C Calculate the Cartesian derivatives of the vectors.
6245         do iii=1,2
6246           do kkk=1,5
6247             do lll=1,3
6248               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6249               call matvec2(auxmat(1,1),b1(1,iti),
6250      &          AEAb1derx(1,lll,kkk,iii,1,1))
6251               call matvec2(auxmat(1,1),Ub2(1,i),
6252      &          AEAb2derx(1,lll,kkk,iii,1,1))
6253               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6254      &          AEAb1derx(1,lll,kkk,iii,2,1))
6255               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6256      &          AEAb2derx(1,lll,kkk,iii,2,1))
6257               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6258               call matvec2(auxmat(1,1),b1(1,itl),
6259      &          AEAb1derx(1,lll,kkk,iii,1,2))
6260               call matvec2(auxmat(1,1),Ub2(1,l),
6261      &          AEAb2derx(1,lll,kkk,iii,1,2))
6262               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6263      &          AEAb1derx(1,lll,kkk,iii,2,2))
6264               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6265      &          AEAb2derx(1,lll,kkk,iii,2,2))
6266             enddo
6267           enddo
6268         enddo
6269         ENDIF
6270 C End vectors
6271       endif
6272       return
6273       end
6274 C---------------------------------------------------------------------------
6275       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6276      &  KK,KKderg,AKA,AKAderg,AKAderx)
6277       implicit none
6278       integer nderg
6279       logical transp
6280       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6281      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6282      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6283       integer iii,kkk,lll
6284       integer jjj,mmm
6285       logical lprn
6286       common /kutas/ lprn
6287       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6288       do iii=1,nderg
6289         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6290      &    AKAderg(1,1,iii))
6291       enddo
6292 cd      if (lprn) write (2,*) 'In kernel'
6293       do kkk=1,5
6294 cd        if (lprn) write (2,*) 'kkk=',kkk
6295         do lll=1,3
6296           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6297      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6298 cd          if (lprn) then
6299 cd            write (2,*) 'lll=',lll
6300 cd            write (2,*) 'iii=1'
6301 cd            do jjj=1,2
6302 cd              write (2,'(3(2f10.5),5x)')
6303 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6304 cd            enddo
6305 cd          endif
6306           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6307      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6308 cd          if (lprn) then
6309 cd            write (2,*) 'lll=',lll
6310 cd            write (2,*) 'iii=2'
6311 cd            do jjj=1,2
6312 cd              write (2,'(3(2f10.5),5x)')
6313 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6314 cd            enddo
6315 cd          endif
6316         enddo
6317       enddo
6318       return
6319       end
6320 C---------------------------------------------------------------------------
6321       double precision function eello4(i,j,k,l,jj,kk)
6322       implicit real*8 (a-h,o-z)
6323       include 'DIMENSIONS'
6324       include 'sizesclu.dat'
6325       include 'COMMON.IOUNITS'
6326       include 'COMMON.CHAIN'
6327       include 'COMMON.DERIV'
6328       include 'COMMON.INTERACT'
6329       include 'COMMON.CONTACTS'
6330       include 'COMMON.TORSION'
6331       include 'COMMON.VAR'
6332       include 'COMMON.GEO'
6333       double precision pizda(2,2),ggg1(3),ggg2(3)
6334 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6335 cd        eello4=0.0d0
6336 cd        return
6337 cd      endif
6338 cd      print *,'eello4:',i,j,k,l,jj,kk
6339 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6340 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6341 cold      eij=facont_hb(jj,i)
6342 cold      ekl=facont_hb(kk,k)
6343 cold      ekont=eij*ekl
6344       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6345       if (calc_grad) then
6346 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6347       gcorr_loc(k-1)=gcorr_loc(k-1)
6348      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6349       if (l.eq.j+1) then
6350         gcorr_loc(l-1)=gcorr_loc(l-1)
6351      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6352       else
6353         gcorr_loc(j-1)=gcorr_loc(j-1)
6354      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6355       endif
6356       do iii=1,2
6357         do kkk=1,5
6358           do lll=1,3
6359             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6360      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6361 cd            derx(lll,kkk,iii)=0.0d0
6362           enddo
6363         enddo
6364       enddo
6365 cd      gcorr_loc(l-1)=0.0d0
6366 cd      gcorr_loc(j-1)=0.0d0
6367 cd      gcorr_loc(k-1)=0.0d0
6368 cd      eel4=1.0d0
6369 cd      write (iout,*)'Contacts have occurred for peptide groups',
6370 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6371 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6372       if (j.lt.nres-1) then
6373         j1=j+1
6374         j2=j-1
6375       else
6376         j1=j-1
6377         j2=j-2
6378       endif
6379       if (l.lt.nres-1) then
6380         l1=l+1
6381         l2=l-1
6382       else
6383         l1=l-1
6384         l2=l-2
6385       endif
6386       do ll=1,3
6387 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6388         ggg1(ll)=eel4*g_contij(ll,1)
6389         ggg2(ll)=eel4*g_contij(ll,2)
6390         ghalf=0.5d0*ggg1(ll)
6391 cd        ghalf=0.0d0
6392         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6393         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6394         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6395         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6396 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6397         ghalf=0.5d0*ggg2(ll)
6398 cd        ghalf=0.0d0
6399         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6400         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6401         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6402         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6403       enddo
6404 cd      goto 1112
6405       do m=i+1,j-1
6406         do ll=1,3
6407 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6408           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6409         enddo
6410       enddo
6411       do m=k+1,l-1
6412         do ll=1,3
6413 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6414           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6415         enddo
6416       enddo
6417 1112  continue
6418       do m=i+2,j2
6419         do ll=1,3
6420           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6421         enddo
6422       enddo
6423       do m=k+2,l2
6424         do ll=1,3
6425           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6426         enddo
6427       enddo
6428 cd      do iii=1,nres-3
6429 cd        write (2,*) iii,gcorr_loc(iii)
6430 cd      enddo
6431       endif
6432       eello4=ekont*eel4
6433 cd      write (2,*) 'ekont',ekont
6434 cd      write (iout,*) 'eello4',ekont*eel4
6435       return
6436       end
6437 C---------------------------------------------------------------------------
6438       double precision function eello5(i,j,k,l,jj,kk)
6439       implicit real*8 (a-h,o-z)
6440       include 'DIMENSIONS'
6441       include 'sizesclu.dat'
6442       include 'COMMON.IOUNITS'
6443       include 'COMMON.CHAIN'
6444       include 'COMMON.DERIV'
6445       include 'COMMON.INTERACT'
6446       include 'COMMON.CONTACTS'
6447       include 'COMMON.TORSION'
6448       include 'COMMON.VAR'
6449       include 'COMMON.GEO'
6450       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6451       double precision ggg1(3),ggg2(3)
6452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6453 C                                                                              C
6454 C                            Parallel chains                                   C
6455 C                                                                              C
6456 C          o             o                   o             o                   C
6457 C         /l\           / \             \   / \           / \   /              C
6458 C        /   \         /   \             \ /   \         /   \ /               C
6459 C       j| o |l1       | o |              o| o |         | o |o                C
6460 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6461 C      \i/   \         /   \ /             /   \         /   \                 C
6462 C       o    k1             o                                                  C
6463 C         (I)          (II)                (III)          (IV)                 C
6464 C                                                                              C
6465 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6466 C                                                                              C
6467 C                            Antiparallel chains                               C
6468 C                                                                              C
6469 C          o             o                   o             o                   C
6470 C         /j\           / \             \   / \           / \   /              C
6471 C        /   \         /   \             \ /   \         /   \ /               C
6472 C      j1| o |l        | o |              o| o |         | o |o                C
6473 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6474 C      \i/   \         /   \ /             /   \         /   \                 C
6475 C       o     k1            o                                                  C
6476 C         (I)          (II)                (III)          (IV)                 C
6477 C                                                                              C
6478 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6479 C                                                                              C
6480 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6481 C                                                                              C
6482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6483 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6484 cd        eello5=0.0d0
6485 cd        return
6486 cd      endif
6487 cd      write (iout,*)
6488 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6489 cd     &   ' and',k,l
6490       itk=itortyp(itype(k))
6491       itl=itortyp(itype(l))
6492       itj=itortyp(itype(j))
6493       eello5_1=0.0d0
6494       eello5_2=0.0d0
6495       eello5_3=0.0d0
6496       eello5_4=0.0d0
6497 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6498 cd     &   eel5_3_num,eel5_4_num)
6499       do iii=1,2
6500         do kkk=1,5
6501           do lll=1,3
6502             derx(lll,kkk,iii)=0.0d0
6503           enddo
6504         enddo
6505       enddo
6506 cd      eij=facont_hb(jj,i)
6507 cd      ekl=facont_hb(kk,k)
6508 cd      ekont=eij*ekl
6509 cd      write (iout,*)'Contacts have occurred for peptide groups',
6510 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6511 cd      goto 1111
6512 C Contribution from the graph I.
6513 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6514 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6515       call transpose2(EUg(1,1,k),auxmat(1,1))
6516       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6517       vv(1)=pizda(1,1)-pizda(2,2)
6518       vv(2)=pizda(1,2)+pizda(2,1)
6519       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6520      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6521       if (calc_grad) then
6522 C Explicit gradient in virtual-dihedral angles.
6523       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6524      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6525      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6526       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6527       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6528       vv(1)=pizda(1,1)-pizda(2,2)
6529       vv(2)=pizda(1,2)+pizda(2,1)
6530       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6531      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6532      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6533       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6534       vv(1)=pizda(1,1)-pizda(2,2)
6535       vv(2)=pizda(1,2)+pizda(2,1)
6536       if (l.eq.j+1) then
6537         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6538      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6539      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6540       else
6541         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6542      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6543      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6544       endif
6545 C Cartesian gradient
6546       do iii=1,2
6547         do kkk=1,5
6548           do lll=1,3
6549             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6550      &        pizda(1,1))
6551             vv(1)=pizda(1,1)-pizda(2,2)
6552             vv(2)=pizda(1,2)+pizda(2,1)
6553             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6554      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6555      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6556           enddo
6557         enddo
6558       enddo
6559 c      goto 1112
6560       endif
6561 c1111  continue
6562 C Contribution from graph II
6563       call transpose2(EE(1,1,itk),auxmat(1,1))
6564       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6565       vv(1)=pizda(1,1)+pizda(2,2)
6566       vv(2)=pizda(2,1)-pizda(1,2)
6567       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6568      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6569       if (calc_grad) then
6570 C Explicit gradient in virtual-dihedral angles.
6571       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6572      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6573       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6574       vv(1)=pizda(1,1)+pizda(2,2)
6575       vv(2)=pizda(2,1)-pizda(1,2)
6576       if (l.eq.j+1) then
6577         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6578      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6579      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6580       else
6581         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6582      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6583      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6584       endif
6585 C Cartesian gradient
6586       do iii=1,2
6587         do kkk=1,5
6588           do lll=1,3
6589             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6590      &        pizda(1,1))
6591             vv(1)=pizda(1,1)+pizda(2,2)
6592             vv(2)=pizda(2,1)-pizda(1,2)
6593             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6594      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6595      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6596           enddo
6597         enddo
6598       enddo
6599 cd      goto 1112
6600       endif
6601 cd1111  continue
6602       if (l.eq.j+1) then
6603 cd        goto 1110
6604 C Parallel orientation
6605 C Contribution from graph III
6606         call transpose2(EUg(1,1,l),auxmat(1,1))
6607         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6608         vv(1)=pizda(1,1)-pizda(2,2)
6609         vv(2)=pizda(1,2)+pizda(2,1)
6610         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6611      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6612         if (calc_grad) then
6613 C Explicit gradient in virtual-dihedral angles.
6614         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6615      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6616      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6617         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6618         vv(1)=pizda(1,1)-pizda(2,2)
6619         vv(2)=pizda(1,2)+pizda(2,1)
6620         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6621      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6622      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6623         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6624         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6625         vv(1)=pizda(1,1)-pizda(2,2)
6626         vv(2)=pizda(1,2)+pizda(2,1)
6627         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6628      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6629      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6630 C Cartesian gradient
6631         do iii=1,2
6632           do kkk=1,5
6633             do lll=1,3
6634               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6635      &          pizda(1,1))
6636               vv(1)=pizda(1,1)-pizda(2,2)
6637               vv(2)=pizda(1,2)+pizda(2,1)
6638               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6639      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6640      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6641             enddo
6642           enddo
6643         enddo
6644 cd        goto 1112
6645         endif
6646 C Contribution from graph IV
6647 cd1110    continue
6648         call transpose2(EE(1,1,itl),auxmat(1,1))
6649         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6650         vv(1)=pizda(1,1)+pizda(2,2)
6651         vv(2)=pizda(2,1)-pizda(1,2)
6652         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6653      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6654         if (calc_grad) then
6655 C Explicit gradient in virtual-dihedral angles.
6656         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6657      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6658         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6659         vv(1)=pizda(1,1)+pizda(2,2)
6660         vv(2)=pizda(2,1)-pizda(1,2)
6661         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6662      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6663      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6664 C Cartesian gradient
6665         do iii=1,2
6666           do kkk=1,5
6667             do lll=1,3
6668               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6669      &          pizda(1,1))
6670               vv(1)=pizda(1,1)+pizda(2,2)
6671               vv(2)=pizda(2,1)-pizda(1,2)
6672               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6673      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6674      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6675             enddo
6676           enddo
6677         enddo
6678         endif
6679       else
6680 C Antiparallel orientation
6681 C Contribution from graph III
6682 c        goto 1110
6683         call transpose2(EUg(1,1,j),auxmat(1,1))
6684         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6685         vv(1)=pizda(1,1)-pizda(2,2)
6686         vv(2)=pizda(1,2)+pizda(2,1)
6687         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6688      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6689         if (calc_grad) then
6690 C Explicit gradient in virtual-dihedral angles.
6691         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6692      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6693      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6694         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6695         vv(1)=pizda(1,1)-pizda(2,2)
6696         vv(2)=pizda(1,2)+pizda(2,1)
6697         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6698      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6699      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6700         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6701         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6702         vv(1)=pizda(1,1)-pizda(2,2)
6703         vv(2)=pizda(1,2)+pizda(2,1)
6704         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6705      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6706      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6707 C Cartesian gradient
6708         do iii=1,2
6709           do kkk=1,5
6710             do lll=1,3
6711               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6712      &          pizda(1,1))
6713               vv(1)=pizda(1,1)-pizda(2,2)
6714               vv(2)=pizda(1,2)+pizda(2,1)
6715               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6716      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6717      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6718             enddo
6719           enddo
6720         enddo
6721 cd        goto 1112
6722         endif
6723 C Contribution from graph IV
6724 1110    continue
6725         call transpose2(EE(1,1,itj),auxmat(1,1))
6726         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6727         vv(1)=pizda(1,1)+pizda(2,2)
6728         vv(2)=pizda(2,1)-pizda(1,2)
6729         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6730      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6731         if (calc_grad) then
6732 C Explicit gradient in virtual-dihedral angles.
6733         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6734      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6735         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6736         vv(1)=pizda(1,1)+pizda(2,2)
6737         vv(2)=pizda(2,1)-pizda(1,2)
6738         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6739      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6740      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6741 C Cartesian gradient
6742         do iii=1,2
6743           do kkk=1,5
6744             do lll=1,3
6745               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6746      &          pizda(1,1))
6747               vv(1)=pizda(1,1)+pizda(2,2)
6748               vv(2)=pizda(2,1)-pizda(1,2)
6749               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6750      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6751      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6752             enddo
6753           enddo
6754         enddo
6755       endif
6756       endif
6757 1112  continue
6758       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6759 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6760 cd        write (2,*) 'ijkl',i,j,k,l
6761 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6762 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6763 cd      endif
6764 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6765 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6766 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6767 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6768       if (calc_grad) then
6769       if (j.lt.nres-1) then
6770         j1=j+1
6771         j2=j-1
6772       else
6773         j1=j-1
6774         j2=j-2
6775       endif
6776       if (l.lt.nres-1) then
6777         l1=l+1
6778         l2=l-1
6779       else
6780         l1=l-1
6781         l2=l-2
6782       endif
6783 cd      eij=1.0d0
6784 cd      ekl=1.0d0
6785 cd      ekont=1.0d0
6786 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6787       do ll=1,3
6788         ggg1(ll)=eel5*g_contij(ll,1)
6789         ggg2(ll)=eel5*g_contij(ll,2)
6790 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6791         ghalf=0.5d0*ggg1(ll)
6792 cd        ghalf=0.0d0
6793         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6794         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6795         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6796         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6797 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6798         ghalf=0.5d0*ggg2(ll)
6799 cd        ghalf=0.0d0
6800         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6801         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6802         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6803         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6804       enddo
6805 cd      goto 1112
6806       do m=i+1,j-1
6807         do ll=1,3
6808 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6809           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6810         enddo
6811       enddo
6812       do m=k+1,l-1
6813         do ll=1,3
6814 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6815           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6816         enddo
6817       enddo
6818 c1112  continue
6819       do m=i+2,j2
6820         do ll=1,3
6821           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6822         enddo
6823       enddo
6824       do m=k+2,l2
6825         do ll=1,3
6826           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6827         enddo
6828       enddo
6829 cd      do iii=1,nres-3
6830 cd        write (2,*) iii,g_corr5_loc(iii)
6831 cd      enddo
6832       endif
6833       eello5=ekont*eel5
6834 cd      write (2,*) 'ekont',ekont
6835 cd      write (iout,*) 'eello5',ekont*eel5
6836       return
6837       end
6838 c--------------------------------------------------------------------------
6839       double precision function eello6(i,j,k,l,jj,kk)
6840       implicit real*8 (a-h,o-z)
6841       include 'DIMENSIONS'
6842       include 'sizesclu.dat'
6843       include 'COMMON.IOUNITS'
6844       include 'COMMON.CHAIN'
6845       include 'COMMON.DERIV'
6846       include 'COMMON.INTERACT'
6847       include 'COMMON.CONTACTS'
6848       include 'COMMON.TORSION'
6849       include 'COMMON.VAR'
6850       include 'COMMON.GEO'
6851       include 'COMMON.FFIELD'
6852       double precision ggg1(3),ggg2(3)
6853 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6854 cd        eello6=0.0d0
6855 cd        return
6856 cd      endif
6857 cd      write (iout,*)
6858 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6859 cd     &   ' and',k,l
6860       eello6_1=0.0d0
6861       eello6_2=0.0d0
6862       eello6_3=0.0d0
6863       eello6_4=0.0d0
6864       eello6_5=0.0d0
6865       eello6_6=0.0d0
6866 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6867 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6868       do iii=1,2
6869         do kkk=1,5
6870           do lll=1,3
6871             derx(lll,kkk,iii)=0.0d0
6872           enddo
6873         enddo
6874       enddo
6875 cd      eij=facont_hb(jj,i)
6876 cd      ekl=facont_hb(kk,k)
6877 cd      ekont=eij*ekl
6878 cd      eij=1.0d0
6879 cd      ekl=1.0d0
6880 cd      ekont=1.0d0
6881       if (l.eq.j+1) then
6882         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6883         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6884         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6885         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6886         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6887         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6888       else
6889         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6890         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6891         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6892         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6893         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6894           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6895         else
6896           eello6_5=0.0d0
6897         endif
6898         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6899       endif
6900 C If turn contributions are considered, they will be handled separately.
6901       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6902 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6903 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6904 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6905 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6906 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6907 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6908 cd      goto 1112
6909       if (calc_grad) then
6910       if (j.lt.nres-1) then
6911         j1=j+1
6912         j2=j-1
6913       else
6914         j1=j-1
6915         j2=j-2
6916       endif
6917       if (l.lt.nres-1) then
6918         l1=l+1
6919         l2=l-1
6920       else
6921         l1=l-1
6922         l2=l-2
6923       endif
6924       do ll=1,3
6925         ggg1(ll)=eel6*g_contij(ll,1)
6926         ggg2(ll)=eel6*g_contij(ll,2)
6927 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6928         ghalf=0.5d0*ggg1(ll)
6929 cd        ghalf=0.0d0
6930         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6931         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6932         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6933         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6934         ghalf=0.5d0*ggg2(ll)
6935 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6936 cd        ghalf=0.0d0
6937         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6938         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6939         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6940         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6941       enddo
6942 cd      goto 1112
6943       do m=i+1,j-1
6944         do ll=1,3
6945 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6946           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6947         enddo
6948       enddo
6949       do m=k+1,l-1
6950         do ll=1,3
6951 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6952           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6953         enddo
6954       enddo
6955 1112  continue
6956       do m=i+2,j2
6957         do ll=1,3
6958           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6959         enddo
6960       enddo
6961       do m=k+2,l2
6962         do ll=1,3
6963           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6964         enddo
6965       enddo
6966 cd      do iii=1,nres-3
6967 cd        write (2,*) iii,g_corr6_loc(iii)
6968 cd      enddo
6969       endif
6970       eello6=ekont*eel6
6971 cd      write (2,*) 'ekont',ekont
6972 cd      write (iout,*) 'eello6',ekont*eel6
6973       return
6974       end
6975 c--------------------------------------------------------------------------
6976       double precision function eello6_graph1(i,j,k,l,imat,swap)
6977       implicit real*8 (a-h,o-z)
6978       include 'DIMENSIONS'
6979       include 'sizesclu.dat'
6980       include 'COMMON.IOUNITS'
6981       include 'COMMON.CHAIN'
6982       include 'COMMON.DERIV'
6983       include 'COMMON.INTERACT'
6984       include 'COMMON.CONTACTS'
6985       include 'COMMON.TORSION'
6986       include 'COMMON.VAR'
6987       include 'COMMON.GEO'
6988       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6989       logical swap
6990       logical lprn
6991       common /kutas/ lprn
6992 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6993 C                                                                              C
6994 C      Parallel       Antiparallel                                             C
6995 C                                                                              C
6996 C          o             o                                                     C
6997 C         /l\           /j\                                                    C
6998 C        /   \         /   \                                                   C
6999 C       /| o |         | o |\                                                  C
7000 C     \ j|/k\|  /   \  |/k\|l /                                                C
7001 C      \ /   \ /     \ /   \ /                                                 C
7002 C       o     o       o     o                                                  C
7003 C       i             i                                                        C
7004 C                                                                              C
7005 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7006       itk=itortyp(itype(k))
7007       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7008       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7009       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7010       call transpose2(EUgC(1,1,k),auxmat(1,1))
7011       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7012       vv1(1)=pizda1(1,1)-pizda1(2,2)
7013       vv1(2)=pizda1(1,2)+pizda1(2,1)
7014       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7015       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7016       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7017       s5=scalar2(vv(1),Dtobr2(1,i))
7018 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7019       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7020       if (.not. calc_grad) return
7021       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7022      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7023      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7024      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7025      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7026      & +scalar2(vv(1),Dtobr2der(1,i)))
7027       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7028       vv1(1)=pizda1(1,1)-pizda1(2,2)
7029       vv1(2)=pizda1(1,2)+pizda1(2,1)
7030       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7031       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7032       if (l.eq.j+1) then
7033         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7034      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7035      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7036      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7037      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7038       else
7039         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7040      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7041      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7042      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7043      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7044       endif
7045       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7046       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7047       vv1(1)=pizda1(1,1)-pizda1(2,2)
7048       vv1(2)=pizda1(1,2)+pizda1(2,1)
7049       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7050      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7051      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7052      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7053       do iii=1,2
7054         if (swap) then
7055           ind=3-iii
7056         else
7057           ind=iii
7058         endif
7059         do kkk=1,5
7060           do lll=1,3
7061             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7062             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7063             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7064             call transpose2(EUgC(1,1,k),auxmat(1,1))
7065             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7066      &        pizda1(1,1))
7067             vv1(1)=pizda1(1,1)-pizda1(2,2)
7068             vv1(2)=pizda1(1,2)+pizda1(2,1)
7069             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7070             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7071      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7072             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7073      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7074             s5=scalar2(vv(1),Dtobr2(1,i))
7075             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7076           enddo
7077         enddo
7078       enddo
7079       return
7080       end
7081 c----------------------------------------------------------------------------
7082       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7083       implicit real*8 (a-h,o-z)
7084       include 'DIMENSIONS'
7085       include 'sizesclu.dat'
7086       include 'COMMON.IOUNITS'
7087       include 'COMMON.CHAIN'
7088       include 'COMMON.DERIV'
7089       include 'COMMON.INTERACT'
7090       include 'COMMON.CONTACTS'
7091       include 'COMMON.TORSION'
7092       include 'COMMON.VAR'
7093       include 'COMMON.GEO'
7094       logical swap
7095       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7096      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7097       logical lprn
7098       common /kutas/ lprn
7099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7100 C                                                                              C
7101 C      Parallel       Antiparallel                                             C
7102 C                                                                              C
7103 C          o             o                                                     C
7104 C     \   /l\           /j\   /                                                C
7105 C      \ /   \         /   \ /                                                 C
7106 C       o| o |         | o |o                                                  C
7107 C     \ j|/k\|      \  |/k\|l                                                  C
7108 C      \ /   \       \ /   \                                                   C
7109 C       o             o                                                        C
7110 C       i             i                                                        C
7111 C                                                                              C
7112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7113 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7114 C AL 7/4/01 s1 would occur in the sixth-order moment,
7115 C           but not in a cluster cumulant
7116 #ifdef MOMENT
7117       s1=dip(1,jj,i)*dip(1,kk,k)
7118 #endif
7119       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7120       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7121       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7122       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7123       call transpose2(EUg(1,1,k),auxmat(1,1))
7124       call matmat2(ADtEA1(1,1,1),auxmat(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 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7129 #ifdef MOMENT
7130       eello6_graph2=-(s1+s2+s3+s4)
7131 #else
7132       eello6_graph2=-(s2+s3+s4)
7133 #endif
7134 c      eello6_graph2=-s3
7135       if (.not. calc_grad) return
7136 C Derivatives in gamma(i-1)
7137       if (i.gt.1) then
7138 #ifdef MOMENT
7139         s1=dipderg(1,jj,i)*dip(1,kk,k)
7140 #endif
7141         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7142         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7143         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7144         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7145 #ifdef MOMENT
7146         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7147 #else
7148         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7149 #endif
7150 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7151       endif
7152 C Derivatives in gamma(k-1)
7153 #ifdef MOMENT
7154       s1=dip(1,jj,i)*dipderg(1,kk,k)
7155 #endif
7156       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7157       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7158       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7159       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7160       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7161       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7162       vv(1)=pizda(1,1)-pizda(2,2)
7163       vv(2)=pizda(1,2)+pizda(2,1)
7164       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7165 #ifdef MOMENT
7166       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7167 #else
7168       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7169 #endif
7170 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7171 C Derivatives in gamma(j-1) or gamma(l-1)
7172       if (j.gt.1) then
7173 #ifdef MOMENT
7174         s1=dipderg(3,jj,i)*dip(1,kk,k)
7175 #endif
7176         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7177         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7178         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7179         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7180         vv(1)=pizda(1,1)-pizda(2,2)
7181         vv(2)=pizda(1,2)+pizda(2,1)
7182         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7183 #ifdef MOMENT
7184         if (swap) then
7185           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7186         else
7187           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7188         endif
7189 #endif
7190         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7191 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7192       endif
7193 C Derivatives in gamma(l-1) or gamma(j-1)
7194       if (l.gt.1) then
7195 #ifdef MOMENT
7196         s1=dip(1,jj,i)*dipderg(3,kk,k)
7197 #endif
7198         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7199         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7200         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7201         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7202         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7203         vv(1)=pizda(1,1)-pizda(2,2)
7204         vv(2)=pizda(1,2)+pizda(2,1)
7205         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7206 #ifdef MOMENT
7207         if (swap) then
7208           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7209         else
7210           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7211         endif
7212 #endif
7213         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7214 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7215       endif
7216 C Cartesian derivatives.
7217       if (lprn) then
7218         write (2,*) 'In eello6_graph2'
7219         do iii=1,2
7220           write (2,*) 'iii=',iii
7221           do kkk=1,5
7222             write (2,*) 'kkk=',kkk
7223             do jjj=1,2
7224               write (2,'(3(2f10.5),5x)')
7225      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7226             enddo
7227           enddo
7228         enddo
7229       endif
7230       do iii=1,2
7231         do kkk=1,5
7232           do lll=1,3
7233 #ifdef MOMENT
7234             if (iii.eq.1) then
7235               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7236             else
7237               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7238             endif
7239 #endif
7240             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7241      &        auxvec(1))
7242             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7243             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7244      &        auxvec(1))
7245             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7246             call transpose2(EUg(1,1,k),auxmat(1,1))
7247             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7248      &        pizda(1,1))
7249             vv(1)=pizda(1,1)-pizda(2,2)
7250             vv(2)=pizda(1,2)+pizda(2,1)
7251             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7252 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7253 #ifdef MOMENT
7254             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7255 #else
7256             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7257 #endif
7258             if (swap) then
7259               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7260             else
7261               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7262             endif
7263           enddo
7264         enddo
7265       enddo
7266       return
7267       end
7268 c----------------------------------------------------------------------------
7269       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7270       implicit real*8 (a-h,o-z)
7271       include 'DIMENSIONS'
7272       include 'sizesclu.dat'
7273       include 'COMMON.IOUNITS'
7274       include 'COMMON.CHAIN'
7275       include 'COMMON.DERIV'
7276       include 'COMMON.INTERACT'
7277       include 'COMMON.CONTACTS'
7278       include 'COMMON.TORSION'
7279       include 'COMMON.VAR'
7280       include 'COMMON.GEO'
7281       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7282       logical swap
7283 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7284 C                                                                              C
7285 C      Parallel       Antiparallel                                             C
7286 C                                                                              C
7287 C          o             o                                                     C
7288 C         /l\   /   \   /j\                                                    C
7289 C        /   \ /     \ /   \                                                   C
7290 C       /| o |o       o| o |\                                                  C
7291 C       j|/k\|  /      |/k\|l /                                                C
7292 C        /   \ /       /   \ /                                                 C
7293 C       /     o       /     o                                                  C
7294 C       i             i                                                        C
7295 C                                                                              C
7296 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7297 C
7298 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7299 C           energy moment and not to the cluster cumulant.
7300       iti=itortyp(itype(i))
7301       if (j.lt.nres-1) then
7302         itj1=itortyp(itype(j+1))
7303       else
7304         itj1=ntortyp+1
7305       endif
7306       itk=itortyp(itype(k))
7307       itk1=itortyp(itype(k+1))
7308       if (l.lt.nres-1) then
7309         itl1=itortyp(itype(l+1))
7310       else
7311         itl1=ntortyp+1
7312       endif
7313 #ifdef MOMENT
7314       s1=dip(4,jj,i)*dip(4,kk,k)
7315 #endif
7316       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7317       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7318       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7319       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7320       call transpose2(EE(1,1,itk),auxmat(1,1))
7321       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7322       vv(1)=pizda(1,1)+pizda(2,2)
7323       vv(2)=pizda(2,1)-pizda(1,2)
7324       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7325 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7326 #ifdef MOMENT
7327       eello6_graph3=-(s1+s2+s3+s4)
7328 #else
7329       eello6_graph3=-(s2+s3+s4)
7330 #endif
7331 c      eello6_graph3=-s4
7332       if (.not. calc_grad) return
7333 C Derivatives in gamma(k-1)
7334       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7335       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7336       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7337       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7338 C Derivatives in gamma(l-1)
7339       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7340       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7341       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7342       vv(1)=pizda(1,1)+pizda(2,2)
7343       vv(2)=pizda(2,1)-pizda(1,2)
7344       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7345       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7346 C Cartesian derivatives.
7347       do iii=1,2
7348         do kkk=1,5
7349           do lll=1,3
7350 #ifdef MOMENT
7351             if (iii.eq.1) then
7352               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7353             else
7354               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7355             endif
7356 #endif
7357             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7358      &        auxvec(1))
7359             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7360             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7361      &        auxvec(1))
7362             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7363             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7364      &        pizda(1,1))
7365             vv(1)=pizda(1,1)+pizda(2,2)
7366             vv(2)=pizda(2,1)-pizda(1,2)
7367             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7368 #ifdef MOMENT
7369             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7370 #else
7371             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7372 #endif
7373             if (swap) then
7374               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7375             else
7376               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7377             endif
7378 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7379           enddo
7380         enddo
7381       enddo
7382       return
7383       end
7384 c----------------------------------------------------------------------------
7385       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7386       implicit real*8 (a-h,o-z)
7387       include 'DIMENSIONS'
7388       include 'sizesclu.dat'
7389       include 'COMMON.IOUNITS'
7390       include 'COMMON.CHAIN'
7391       include 'COMMON.DERIV'
7392       include 'COMMON.INTERACT'
7393       include 'COMMON.CONTACTS'
7394       include 'COMMON.TORSION'
7395       include 'COMMON.VAR'
7396       include 'COMMON.GEO'
7397       include 'COMMON.FFIELD'
7398       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7399      & auxvec1(2),auxmat1(2,2)
7400       logical swap
7401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7402 C                                                                              C
7403 C      Parallel       Antiparallel                                             C
7404 C                                                                              C
7405 C          o             o                                                     C
7406 C         /l\   /   \   /j\                                                    C
7407 C        /   \ /     \ /   \                                                   C
7408 C       /| o |o       o| o |\                                                  C
7409 C     \ j|/k\|      \  |/k\|l                                                  C
7410 C      \ /   \       \ /   \                                                   C
7411 C       o     \       o     \                                                  C
7412 C       i             i                                                        C
7413 C                                                                              C
7414 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7415 C
7416 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7417 C           energy moment and not to the cluster cumulant.
7418 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7419       iti=itortyp(itype(i))
7420       itj=itortyp(itype(j))
7421       if (j.lt.nres-1) then
7422         itj1=itortyp(itype(j+1))
7423       else
7424         itj1=ntortyp+1
7425       endif
7426       itk=itortyp(itype(k))
7427       if (k.lt.nres-1) then
7428         itk1=itortyp(itype(k+1))
7429       else
7430         itk1=ntortyp+1
7431       endif
7432       itl=itortyp(itype(l))
7433       if (l.lt.nres-1) then
7434         itl1=itortyp(itype(l+1))
7435       else
7436         itl1=ntortyp+1
7437       endif
7438 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7439 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7440 cd     & ' itl',itl,' itl1',itl1
7441 #ifdef MOMENT
7442       if (imat.eq.1) then
7443         s1=dip(3,jj,i)*dip(3,kk,k)
7444       else
7445         s1=dip(2,jj,j)*dip(2,kk,l)
7446       endif
7447 #endif
7448       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7449       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7450       if (j.eq.l+1) then
7451         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7452         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7453       else
7454         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7455         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7456       endif
7457       call transpose2(EUg(1,1,k),auxmat(1,1))
7458       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7459       vv(1)=pizda(1,1)-pizda(2,2)
7460       vv(2)=pizda(2,1)+pizda(1,2)
7461       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7462 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7463 #ifdef MOMENT
7464       eello6_graph4=-(s1+s2+s3+s4)
7465 #else
7466       eello6_graph4=-(s2+s3+s4)
7467 #endif
7468       if (.not. calc_grad) return
7469 C Derivatives in gamma(i-1)
7470       if (i.gt.1) then
7471 #ifdef MOMENT
7472         if (imat.eq.1) then
7473           s1=dipderg(2,jj,i)*dip(3,kk,k)
7474         else
7475           s1=dipderg(4,jj,j)*dip(2,kk,l)
7476         endif
7477 #endif
7478         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7479         if (j.eq.l+1) then
7480           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7481           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7482         else
7483           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7484           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7485         endif
7486         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7487         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7488 cd          write (2,*) 'turn6 derivatives'
7489 #ifdef MOMENT
7490           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7491 #else
7492           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7493 #endif
7494         else
7495 #ifdef MOMENT
7496           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7497 #else
7498           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7499 #endif
7500         endif
7501       endif
7502 C Derivatives in gamma(k-1)
7503 #ifdef MOMENT
7504       if (imat.eq.1) then
7505         s1=dip(3,jj,i)*dipderg(2,kk,k)
7506       else
7507         s1=dip(2,jj,j)*dipderg(4,kk,l)
7508       endif
7509 #endif
7510       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7511       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7512       if (j.eq.l+1) then
7513         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7514         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7515       else
7516         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7517         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7518       endif
7519       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7520       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7521       vv(1)=pizda(1,1)-pizda(2,2)
7522       vv(2)=pizda(2,1)+pizda(1,2)
7523       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7524       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7525 #ifdef MOMENT
7526         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7527 #else
7528         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7529 #endif
7530       else
7531 #ifdef MOMENT
7532         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7533 #else
7534         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7535 #endif
7536       endif
7537 C Derivatives in gamma(j-1) or gamma(l-1)
7538       if (l.eq.j+1 .and. l.gt.1) then
7539         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7540         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7541         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7542         vv(1)=pizda(1,1)-pizda(2,2)
7543         vv(2)=pizda(2,1)+pizda(1,2)
7544         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7545         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7546       else if (j.gt.1) then
7547         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7548         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7549         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7550         vv(1)=pizda(1,1)-pizda(2,2)
7551         vv(2)=pizda(2,1)+pizda(1,2)
7552         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7553         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7554           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7555         else
7556           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7557         endif
7558       endif
7559 C Cartesian derivatives.
7560       do iii=1,2
7561         do kkk=1,5
7562           do lll=1,3
7563 #ifdef MOMENT
7564             if (iii.eq.1) then
7565               if (imat.eq.1) then
7566                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7567               else
7568                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7569               endif
7570             else
7571               if (imat.eq.1) then
7572                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7573               else
7574                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7575               endif
7576             endif
7577 #endif
7578             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7579      &        auxvec(1))
7580             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7581             if (j.eq.l+1) then
7582               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7583      &          b1(1,itj1),auxvec(1))
7584               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7585             else
7586               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7587      &          b1(1,itl1),auxvec(1))
7588               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7589             endif
7590             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7591      &        pizda(1,1))
7592             vv(1)=pizda(1,1)-pizda(2,2)
7593             vv(2)=pizda(2,1)+pizda(1,2)
7594             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7595             if (swap) then
7596               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7597 #ifdef MOMENT
7598                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7599      &             -(s1+s2+s4)
7600 #else
7601                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7602      &             -(s2+s4)
7603 #endif
7604                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7605               else
7606 #ifdef MOMENT
7607                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7608 #else
7609                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7610 #endif
7611                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7612               endif
7613             else
7614 #ifdef MOMENT
7615               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7616 #else
7617               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7618 #endif
7619               if (l.eq.j+1) then
7620                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7621               else
7622                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7623               endif
7624             endif
7625           enddo
7626         enddo
7627       enddo
7628       return
7629       end
7630 c----------------------------------------------------------------------------
7631       double precision function eello_turn6(i,jj,kk)
7632       implicit real*8 (a-h,o-z)
7633       include 'DIMENSIONS'
7634       include 'sizesclu.dat'
7635       include 'COMMON.IOUNITS'
7636       include 'COMMON.CHAIN'
7637       include 'COMMON.DERIV'
7638       include 'COMMON.INTERACT'
7639       include 'COMMON.CONTACTS'
7640       include 'COMMON.TORSION'
7641       include 'COMMON.VAR'
7642       include 'COMMON.GEO'
7643       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7644      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7645      &  ggg1(3),ggg2(3)
7646       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7647      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7648 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7649 C           the respective energy moment and not to the cluster cumulant.
7650       eello_turn6=0.0d0
7651       j=i+4
7652       k=i+1
7653       l=i+3
7654       iti=itortyp(itype(i))
7655       itk=itortyp(itype(k))
7656       itk1=itortyp(itype(k+1))
7657       itl=itortyp(itype(l))
7658       itj=itortyp(itype(j))
7659 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7660 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7661 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7662 cd        eello6=0.0d0
7663 cd        return
7664 cd      endif
7665 cd      write (iout,*)
7666 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7667 cd     &   ' and',k,l
7668 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7669       do iii=1,2
7670         do kkk=1,5
7671           do lll=1,3
7672             derx_turn(lll,kkk,iii)=0.0d0
7673           enddo
7674         enddo
7675       enddo
7676 cd      eij=1.0d0
7677 cd      ekl=1.0d0
7678 cd      ekont=1.0d0
7679       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7680 cd      eello6_5=0.0d0
7681 cd      write (2,*) 'eello6_5',eello6_5
7682 #ifdef MOMENT
7683       call transpose2(AEA(1,1,1),auxmat(1,1))
7684       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7685       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7686       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7687 #else
7688       s1 = 0.0d0
7689 #endif
7690       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7691       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7692       s2 = scalar2(b1(1,itk),vtemp1(1))
7693 #ifdef MOMENT
7694       call transpose2(AEA(1,1,2),atemp(1,1))
7695       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7696       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7697       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7698 #else
7699       s8=0.0d0
7700 #endif
7701       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7702       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7703       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7704 #ifdef MOMENT
7705       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7706       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7707       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7708       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7709       ss13 = scalar2(b1(1,itk),vtemp4(1))
7710       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7711 #else
7712       s13=0.0d0
7713 #endif
7714 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7715 c      s1=0.0d0
7716 c      s2=0.0d0
7717 c      s8=0.0d0
7718 c      s12=0.0d0
7719 c      s13=0.0d0
7720       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7721       if (calc_grad) then
7722 C Derivatives in gamma(i+2)
7723 #ifdef MOMENT
7724       call transpose2(AEA(1,1,1),auxmatd(1,1))
7725       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7726       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7727       call transpose2(AEAderg(1,1,2),atempd(1,1))
7728       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7729       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7730 #else
7731       s8d=0.0d0
7732 #endif
7733       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7734       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7735       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7736 c      s1d=0.0d0
7737 c      s2d=0.0d0
7738 c      s8d=0.0d0
7739 c      s12d=0.0d0
7740 c      s13d=0.0d0
7741       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7742 C Derivatives in gamma(i+3)
7743 #ifdef MOMENT
7744       call transpose2(AEA(1,1,1),auxmatd(1,1))
7745       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7746       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7747       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7748 #else
7749       s1d=0.0d0
7750 #endif
7751       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7752       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7753       s2d = scalar2(b1(1,itk),vtemp1d(1))
7754 #ifdef MOMENT
7755       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7756       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7757 #endif
7758       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7759 #ifdef MOMENT
7760       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7761       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7762       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7763 #else
7764       s13d=0.0d0
7765 #endif
7766 c      s1d=0.0d0
7767 c      s2d=0.0d0
7768 c      s8d=0.0d0
7769 c      s12d=0.0d0
7770 c      s13d=0.0d0
7771 #ifdef MOMENT
7772       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7773      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7774 #else
7775       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7776      &               -0.5d0*ekont*(s2d+s12d)
7777 #endif
7778 C Derivatives in gamma(i+4)
7779       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7780       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7781       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7782 #ifdef MOMENT
7783       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7784       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7785       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
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+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7796 #else
7797       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7798 #endif
7799 C Derivatives in gamma(i+5)
7800 #ifdef MOMENT
7801       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7802       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7803       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7804 #else
7805       s1d = 0.0d0
7806 #endif
7807       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7808       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7809       s2d = scalar2(b1(1,itk),vtemp1d(1))
7810 #ifdef MOMENT
7811       call transpose2(AEA(1,1,2),atempd(1,1))
7812       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7813       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7814 #else
7815       s8d = 0.0d0
7816 #endif
7817       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7818       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7819 #ifdef MOMENT
7820       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7821       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7822       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7823 #else
7824       s13d = 0.0d0
7825 #endif
7826 c      s1d=0.0d0
7827 c      s2d=0.0d0
7828 c      s8d=0.0d0
7829 c      s12d=0.0d0
7830 c      s13d=0.0d0
7831 #ifdef MOMENT
7832       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7833      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7834 #else
7835       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7836      &               -0.5d0*ekont*(s2d+s12d)
7837 #endif
7838 C Cartesian derivatives
7839       do iii=1,2
7840         do kkk=1,5
7841           do lll=1,3
7842 #ifdef MOMENT
7843             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7844             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7845             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7846 #else
7847             s1d = 0.0d0
7848 #endif
7849             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7850             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7851      &          vtemp1d(1))
7852             s2d = scalar2(b1(1,itk),vtemp1d(1))
7853 #ifdef MOMENT
7854             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7855             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7856             s8d = -(atempd(1,1)+atempd(2,2))*
7857      &           scalar2(cc(1,1,itl),vtemp2(1))
7858 #else
7859             s8d = 0.0d0
7860 #endif
7861             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7862      &           auxmatd(1,1))
7863             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7864             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7865 c      s1d=0.0d0
7866 c      s2d=0.0d0
7867 c      s8d=0.0d0
7868 c      s12d=0.0d0
7869 c      s13d=0.0d0
7870 #ifdef MOMENT
7871             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7872      &        - 0.5d0*(s1d+s2d)
7873 #else
7874             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7875      &        - 0.5d0*s2d
7876 #endif
7877 #ifdef MOMENT
7878             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7879      &        - 0.5d0*(s8d+s12d)
7880 #else
7881             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7882      &        - 0.5d0*s12d
7883 #endif
7884           enddo
7885         enddo
7886       enddo
7887 #ifdef MOMENT
7888       do kkk=1,5
7889         do lll=1,3
7890           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7891      &      achuj_tempd(1,1))
7892           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7893           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7894           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7895           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7896           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7897      &      vtemp4d(1))
7898           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7899           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7900           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7901         enddo
7902       enddo
7903 #endif
7904 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7905 cd     &  16*eel_turn6_num
7906 cd      goto 1112
7907       if (j.lt.nres-1) then
7908         j1=j+1
7909         j2=j-1
7910       else
7911         j1=j-1
7912         j2=j-2
7913       endif
7914       if (l.lt.nres-1) then
7915         l1=l+1
7916         l2=l-1
7917       else
7918         l1=l-1
7919         l2=l-2
7920       endif
7921       do ll=1,3
7922         ggg1(ll)=eel_turn6*g_contij(ll,1)
7923         ggg2(ll)=eel_turn6*g_contij(ll,2)
7924         ghalf=0.5d0*ggg1(ll)
7925 cd        ghalf=0.0d0
7926         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7927      &    +ekont*derx_turn(ll,2,1)
7928         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7929         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7930      &    +ekont*derx_turn(ll,4,1)
7931         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7932         ghalf=0.5d0*ggg2(ll)
7933 cd        ghalf=0.0d0
7934         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7935      &    +ekont*derx_turn(ll,2,2)
7936         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7937         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7938      &    +ekont*derx_turn(ll,4,2)
7939         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7940       enddo
7941 cd      goto 1112
7942       do m=i+1,j-1
7943         do ll=1,3
7944           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7945         enddo
7946       enddo
7947       do m=k+1,l-1
7948         do ll=1,3
7949           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7950         enddo
7951       enddo
7952 1112  continue
7953       do m=i+2,j2
7954         do ll=1,3
7955           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7956         enddo
7957       enddo
7958       do m=k+2,l2
7959         do ll=1,3
7960           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7961         enddo
7962       enddo
7963 cd      do iii=1,nres-3
7964 cd        write (2,*) iii,g_corr6_loc(iii)
7965 cd      enddo
7966       endif
7967       eello_turn6=ekont*eel_turn6
7968 cd      write (2,*) 'ekont',ekont
7969 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7970       return
7971       end
7972 crc-------------------------------------------------
7973       SUBROUTINE MATVEC2(A1,V1,V2)
7974       implicit real*8 (a-h,o-z)
7975       include 'DIMENSIONS'
7976       DIMENSION A1(2,2),V1(2),V2(2)
7977 c      DO 1 I=1,2
7978 c        VI=0.0
7979 c        DO 3 K=1,2
7980 c    3     VI=VI+A1(I,K)*V1(K)
7981 c        Vaux(I)=VI
7982 c    1 CONTINUE
7983
7984       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7985       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7986
7987       v2(1)=vaux1
7988       v2(2)=vaux2
7989       END
7990 C---------------------------------------
7991       SUBROUTINE MATMAT2(A1,A2,A3)
7992       implicit real*8 (a-h,o-z)
7993       include 'DIMENSIONS'
7994       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7995 c      DIMENSION AI3(2,2)
7996 c        DO  J=1,2
7997 c          A3IJ=0.0
7998 c          DO K=1,2
7999 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8000 c          enddo
8001 c          A3(I,J)=A3IJ
8002 c       enddo
8003 c      enddo
8004
8005       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8006       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8007       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8008       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8009
8010       A3(1,1)=AI3_11
8011       A3(2,1)=AI3_21
8012       A3(1,2)=AI3_12
8013       A3(2,2)=AI3_22
8014       END
8015
8016 c-------------------------------------------------------------------------
8017       double precision function scalar2(u,v)
8018       implicit none
8019       double precision u(2),v(2)
8020       double precision sc
8021       integer i
8022       scalar2=u(1)*v(1)+u(2)*v(2)
8023       return
8024       end
8025
8026 C-----------------------------------------------------------------------------
8027
8028       subroutine transpose2(a,at)
8029       implicit none
8030       double precision a(2,2),at(2,2)
8031       at(1,1)=a(1,1)
8032       at(1,2)=a(2,1)
8033       at(2,1)=a(1,2)
8034       at(2,2)=a(2,2)
8035       return
8036       end
8037 c--------------------------------------------------------------------------
8038       subroutine transpose(n,a,at)
8039       implicit none
8040       integer n,i,j
8041       double precision a(n,n),at(n,n)
8042       do i=1,n
8043         do j=1,n
8044           at(j,i)=a(i,j)
8045         enddo
8046       enddo
8047       return
8048       end
8049 C---------------------------------------------------------------------------
8050       subroutine prodmat3(a1,a2,kk,transp,prod)
8051       implicit none
8052       integer i,j
8053       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8054       logical transp
8055 crc      double precision auxmat(2,2),prod_(2,2)
8056
8057       if (transp) then
8058 crc        call transpose2(kk(1,1),auxmat(1,1))
8059 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8060 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8061
8062            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8063      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8064            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8065      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8066            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8067      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8068            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8069      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8070
8071       else
8072 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8073 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8074
8075            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8076      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8077            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8078      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8079            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8080      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8081            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8082      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8083
8084       endif
8085 c      call transpose2(a2(1,1),a2t(1,1))
8086
8087 crc      print *,transp
8088 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8089 crc      print *,((prod(i,j),i=1,2),j=1,2)
8090
8091       return
8092       end
8093 C-----------------------------------------------------------------------------
8094       double precision function scalar(u,v)
8095       implicit none
8096       double precision u(3),v(3)
8097       double precision sc
8098       integer i
8099       sc=0.0d0
8100       do i=1,3
8101         sc=sc+u(i)*v(i)
8102       enddo
8103       scalar=sc
8104       return
8105       end
8106