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       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       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 cd    call enerprint(energia(0),fact)
 266 cd    call intout
 267 cd    stop
 268       return
 269       end
 270 C------------------------------------------------------------------------
 271       subroutine enerprint(energia,fact)
 272       implicit real*8 (a-h,o-z)
 273       include 'DIMENSIONS'
 274       include 'sizesclu.dat'
 275       include 'COMMON.IOUNITS'
 276       include 'COMMON.FFIELD'
 277       include 'COMMON.SBRIDGE'
 278       double precision energia(0:max_ene),fact(5)
 279       etot=energia(0)
 280       evdw=energia(1)
 281 #ifdef SCP14
 282       evdw2=energia(2)+energia(17)
 283 #else
 284       evdw2=energia(2)
 285 #endif
 286       ees=energia(3)
 287 #ifdef SPLITELE
 288       evdw1=energia(16)
 289 #endif
 290       ecorr=energia(4)
 291       ecorr5=energia(5)
 292       ecorr6=energia(6)
 293       eel_loc=energia(7)
 294       eello_turn3=energia(8)
 295       eello_turn4=energia(9)
 296       eello_turn6=energia(10)
 297       ebe=energia(11)
 298       escloc=energia(12)
 299       etors=energia(13)
 300       etors_d=energia(14)
 301       ehpb=energia(15)
 302       esccor=energia(19)
 303       edihcnstr=energia(20)
 304       estr=energia(18)
 305       ehomology_constr=energia(21)
 306       edfadis=energia(22)
 307       edfator=energia(23)
 308       edfanei=energia(24)
 309       edfabet=energia(25)
 310 #ifdef SPLITELE
 311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 312      &  wvdwpp,
 313      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 314      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 315      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 316      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 317      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 318      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 320      &  wdfa_beta,etot
 321    10 format (/'Virtual-chain energies:'//
 322      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 323      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 324      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 325      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 332      & ' (SS bridges & dist. cnstr.)'/
 333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 341      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 342      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 344      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 345      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 346      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 347      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #else
 350       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 351      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 352      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 353      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 354      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 355      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 356      &  edihcnstr,ehomology_constr,ebr*nss,
 357      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 358      &  wdfa_beta,etot
 359    10 format (/'Virtual-chain energies:'//
 360      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 361      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 362      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 363      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 364      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 365      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 366      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 367      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 368      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 369      & ' (SS bridges & dist. cnstr.)'/
 370      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 372      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 373      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 374      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 375      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 376      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 377      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 378      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 379      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 380      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 381      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 382      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 383      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 384      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 385      & 'ETOT=  ',1pE16.6,' (total)')
 386 #endif
 387       return
 388       end
 389 C-----------------------------------------------------------------------
 390       subroutine elj(evdw)
 391 C
 392 C This subroutine calculates the interaction energy of nonbonded side chains
 393 C assuming the LJ potential of interaction.
 394 C
 395       implicit real*8 (a-h,o-z)
 396       include 'DIMENSIONS'
 397       include 'sizesclu.dat'
 398 c      include "DIMENSIONS.COMPAR"
 399       parameter (accur=1.0d-10)
 400       include 'COMMON.GEO'
 401       include 'COMMON.VAR'
 402       include 'COMMON.LOCAL'
 403       include 'COMMON.CHAIN'
 404       include 'COMMON.DERIV'
 405       include 'COMMON.INTERACT'
 406       include 'COMMON.TORSION'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.NAMES'
 409       include 'COMMON.IOUNITS'
 410       include 'COMMON.CONTACTS'
 411       dimension gg(3)
 412       integer icant
 413       external icant
 414 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 415       evdw=0.0D0
 416       do i=iatsc_s,iatsc_e
 417         itypi=itype(i)
 418         itypi1=itype(i+1)
 419         xi=c(1,nres+i)
 420         yi=c(2,nres+i)
 421         zi=c(3,nres+i)
 422 C Change 12/1/95
 423         num_conti=0
 424 C
 425 C Calculate SC interaction energy.
 426 C
 427         do iint=1,nint_gr(i)
 428 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 429 cd   &                  'iend=',iend(i,iint)
 430           do j=istart(i,iint),iend(i,iint)
 431             itypj=itype(j)
 432             xj=c(1,nres+j)-xi
 433             yj=c(2,nres+j)-yi
 434             zj=c(3,nres+j)-zi
 435 C Change 12/1/95 to calculate four-body interactions
 436             rij=xj*xj+yj*yj+zj*zj
 437             rrij=1.0D0/rij
 438 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 439             eps0ij=eps(itypi,itypj)
 440             fac=rrij**expon2
 441             e1=fac*fac*aa(itypi,itypj)
 442             e2=fac*bb(itypi,itypj)
 443             evdwij=e1+e2
 444             ij=icant(itypi,itypj)
 445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 447 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 449 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 450 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 451             evdw=evdw+evdwij
 452             if (calc_grad) then
 453 C
 454 C Calculate the components of the gradient in DC and X
 455 C
 456             fac=-rrij*(e1+evdwij)
 457             gg(1)=xj*fac
 458             gg(2)=yj*fac
 459             gg(3)=zj*fac
 460             do k=1,3
 461               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 462               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 463             enddo
 464             do k=i,j-1
 465               do l=1,3
 466                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 467               enddo
 468             enddo
 469             endif
 470 C
 471 C 12/1/95, revised on 5/20/97
 472 C
 473 C Calculate the contact function. The ith column of the array JCONT will
 474 C contain the numbers of atoms that make contacts with the atom I (of numbers
 475 C greater than I). The arrays FACONT and GACONT will contain the values of
 476 C the contact function and its derivative.
 477 C
 478 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 479 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 480 C Uncomment next line, if the correlation interactions are contact function only
 481             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 482               rij=dsqrt(rij)
 483               sigij=sigma(itypi,itypj)
 484               r0ij=rs0(itypi,itypj)
 485 C
 486 C Check whether the SC's are not too far to make a contact.
 487 C
 488               rcut=1.5d0*r0ij
 489               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 490 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 491 C
 492               if (fcont.gt.0.0D0) then
 493 C If the SC-SC distance if close to sigma, apply spline.
 494 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 495 cAdam &             fcont1,fprimcont1)
 496 cAdam           fcont1=1.0d0-fcont1
 497 cAdam           if (fcont1.gt.0.0d0) then
 498 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 499 cAdam             fcont=fcont*fcont1
 500 cAdam           endif
 501 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 502 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 503 cga             do k=1,3
 504 cga               gg(k)=gg(k)*eps0ij
 505 cga             enddo
 506 cga             eps0ij=-evdwij*eps0ij
 507 C Uncomment for AL's type of SC correlation interactions.
 508 cadam           eps0ij=-evdwij
 509                 num_conti=num_conti+1
 510                 jcont(num_conti,i)=j
 511                 facont(num_conti,i)=fcont*eps0ij
 512                 fprimcont=eps0ij*fprimcont/rij
 513                 fcont=expon*fcont
 514 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 515 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 516 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 517 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 518                 gacont(1,num_conti,i)=-fprimcont*xj
 519                 gacont(2,num_conti,i)=-fprimcont*yj
 520                 gacont(3,num_conti,i)=-fprimcont*zj
 521 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 522 cd              write (iout,'(2i3,3f10.5)')
 523 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 524               endif
 525             endif
 526           enddo      ! j
 527         enddo        ! iint
 528 C Change 12/1/95
 529         num_cont(i)=num_conti
 530       enddo          ! i
 531       if (calc_grad) then
 532       do i=1,nct
 533         do j=1,3
 534           gvdwc(j,i)=expon*gvdwc(j,i)
 535           gvdwx(j,i)=expon*gvdwx(j,i)
 536         enddo
 537       enddo
 538       endif
 539 C******************************************************************************
 540 C
 541 C                              N O T E !!!
 542 C
 543 C To save time, the factor of EXPON has been extracted from ALL components
 544 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 545 C use!
 546 C
 547 C******************************************************************************
 548       return
 549       end
 550 C-----------------------------------------------------------------------------
 551       subroutine eljk(evdw)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJK potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'sizesclu.dat'
 559 c      include "DIMENSIONS.COMPAR"
 560       include 'COMMON.GEO'
 561       include 'COMMON.VAR'
 562       include 'COMMON.LOCAL'
 563       include 'COMMON.CHAIN'
 564       include 'COMMON.DERIV'
 565       include 'COMMON.INTERACT'
 566       include 'COMMON.IOUNITS'
 567       include 'COMMON.NAMES'
 568       dimension gg(3)
 569       logical scheck
 570       integer icant
 571       external icant
 572 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 573       evdw=0.0D0
 574       do i=iatsc_s,iatsc_e
 575         itypi=itype(i)
 576         itypi1=itype(i+1)
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=itype(j)
 586             xj=c(1,nres+j)-xi
 587             yj=c(2,nres+j)-yi
 588             zj=c(3,nres+j)-zi
 589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 590             fac_augm=rrij**expon
 591             e_augm=augm(itypi,itypj)*fac_augm
 592             r_inv_ij=dsqrt(rrij)
 593             rij=1.0D0/r_inv_ij
 594             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 595             fac=r_shift_inv**expon
 596             e1=fac*fac*aa(itypi,itypj)
 597             e2=fac*bb(itypi,itypj)
 598             evdwij=e_augm+e1+e2
 599             ij=icant(itypi,itypj)
 600 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 601 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 602 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 603 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 604 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 605 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 606 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 607             evdw=evdw+evdwij
 608             if (calc_grad) then
 609 C
 610 C Calculate the components of the gradient in DC and X
 611 C
 612             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 613             gg(1)=xj*fac
 614             gg(2)=yj*fac
 615             gg(3)=zj*fac
 616             do k=1,3
 617               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 618               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 619             enddo
 620             do k=i,j-1
 621               do l=1,3
 622                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 623               enddo
 624             enddo
 625             endif
 626           enddo      ! j
 627         enddo        ! iint
 628       enddo          ! i
 629       if (calc_grad) then
 630       do i=1,nct
 631         do j=1,3
 632           gvdwc(j,i)=expon*gvdwc(j,i)
 633           gvdwx(j,i)=expon*gvdwx(j,i)
 634         enddo
 635       enddo
 636       endif
 637       return
 638       end
 639 C-----------------------------------------------------------------------------
 640       subroutine ebp(evdw)
 641 C
 642 C This subroutine calculates the interaction energy of nonbonded side chains
 643 C assuming the Berne-Pechukas potential of interaction.
 644 C
 645       implicit real*8 (a-h,o-z)
 646       include 'DIMENSIONS'
 647       include 'sizesclu.dat'
 648 c      include "DIMENSIONS.COMPAR"
 649       include 'COMMON.GEO'
 650       include 'COMMON.VAR'
 651       include 'COMMON.LOCAL'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.DERIV'
 654       include 'COMMON.NAMES'
 655       include 'COMMON.INTERACT'
 656       include 'COMMON.IOUNITS'
 657       include 'COMMON.CALC'
 658       common /srutu/ icall
 659 c     double precision rrsave(maxdim)
 660       logical lprn
 661       integer icant
 662       external icant
 663       evdw=0.0D0
 664 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 665       evdw=0.0D0
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=itype(i)
 674         itypi1=itype(i+1)
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678         dxi=dc_norm(1,nres+i)
 679         dyi=dc_norm(2,nres+i)
 680         dzi=dc_norm(3,nres+i)
 681         dsci_inv=vbld_inv(i+nres)
 682 C
 683 C Calculate SC interaction energy.
 684 C
 685         do iint=1,nint_gr(i)
 686           do j=istart(i,iint),iend(i,iint)
 687             ind=ind+1
 688             itypj=itype(j)
 689             dscj_inv=vbld_inv(j+nres)
 690             chi1=chi(itypi,itypj)
 691             chi2=chi(itypj,itypi)
 692             chi12=chi1*chi2
 693             chip1=chip(itypi)
 694             chip2=chip(itypj)
 695             chip12=chip1*chip2
 696             alf1=alp(itypi)
 697             alf2=alp(itypj)
 698             alf12=0.5D0*(alf1+alf2)
 699 C For diagnostics only!!!
 700 c           chi1=0.0D0
 701 c           chi2=0.0D0
 702 c           chi12=0.0D0
 703 c           chip1=0.0D0
 704 c           chip2=0.0D0
 705 c           chip12=0.0D0
 706 c           alf1=0.0D0
 707 c           alf2=0.0D0
 708 c           alf12=0.0D0
 709             xj=c(1,nres+j)-xi
 710             yj=c(2,nres+j)-yi
 711             zj=c(3,nres+j)-zi
 712             dxj=dc_norm(1,nres+j)
 713             dyj=dc_norm(2,nres+j)
 714             dzj=dc_norm(3,nres+j)
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716 cd          if (icall.eq.0) then
 717 cd            rrsave(ind)=rrij
 718 cd          else
 719 cd            rrij=rrsave(ind)
 720 cd          endif
 721             rij=dsqrt(rrij)
 722 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 723             call sc_angular
 724 C Calculate whole angle-dependent part of epsilon and contributions
 725 C to its derivatives
 726             fac=(rrij*sigsq)**expon2
 727             e1=fac*fac*aa(itypi,itypj)
 728             e2=fac*bb(itypi,itypj)
 729             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 730             eps2der=evdwij*eps3rt
 731             eps3der=evdwij*eps2rt
 732             evdwij=evdwij*eps2rt*eps3rt
 733             ij=icant(itypi,itypj)
 734             aux=eps1*eps2rt**2*eps3rt**2
 735             evdw=evdw+evdwij
 736             if (calc_grad) then
 737             if (lprn) then
 738             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 741 cd     &        restyp(itypi),i,restyp(itypj),j,
 742 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 743 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 744 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 745 cd     &        evdwij
 746             endif
 747 C Calculate gradient components.
 748             e1=e1*eps1*eps2rt**2*eps3rt**2
 749             fac=-expon*(e1+evdwij)
 750             sigder=fac/sigsq
 751             fac=rrij*fac
 752 C Calculate radial part of the gradient
 753             gg(1)=xj*fac
 754             gg(2)=yj*fac
 755             gg(3)=zj*fac
 756 C Calculate the angular part of the gradient and sum add the contributions
 757 C to the appropriate components of the Cartesian gradient.
 758             call sc_grad
 759             endif
 760           enddo      ! j
 761         enddo        ! iint
 762       enddo          ! i
 763 c     stop
 764       return
 765       end
 766 C-----------------------------------------------------------------------------
 767       subroutine egb(evdw)
 768 C
 769 C This subroutine calculates the interaction energy of nonbonded side chains
 770 C assuming the Gay-Berne potential of interaction.
 771 C
 772       implicit real*8 (a-h,o-z)
 773       include 'DIMENSIONS'
 774       include 'sizesclu.dat'
 775 c      include "DIMENSIONS.COMPAR"
 776       include 'COMMON.GEO'
 777       include 'COMMON.VAR'
 778       include 'COMMON.LOCAL'
 779       include 'COMMON.CHAIN'
 780       include 'COMMON.DERIV'
 781       include 'COMMON.NAMES'
 782       include 'COMMON.INTERACT'
 783       include 'COMMON.IOUNITS'
 784       include 'COMMON.CALC'
 785       include 'COMMON.SBRIDGE'
 786       logical lprn
 787       common /srutu/icall
 788       integer icant
 789       external icant
 790       evdw=0.0D0
 791 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 792       evdw=0.0D0
 793       lprn=.false.
 794 c      if (icall.gt.0) lprn=.true.
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=itype(i)
 798         itypi1=itype(i+1)
 799         xi=c(1,nres+i)
 800         yi=c(2,nres+i)
 801         zi=c(3,nres+i)
 802         dxi=dc_norm(1,nres+i)
 803         dyi=dc_norm(2,nres+i)
 804         dzi=dc_norm(3,nres+i)
 805         dsci_inv=vbld_inv(i+nres)
 806 C
 807 C Calculate SC interaction energy.
 808 C
 809         do iint=1,nint_gr(i)
 810           do j=istart(i,iint),iend(i,iint)
 811             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 812               call dyn_ssbond_ene(i,j,evdwij)
 813               evdw=evdw+evdwij
 814 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 815 c     &                        'evdw',i,j,evdwij,' ss'
 816             ELSE
 817             ind=ind+1
 818             itypj=itype(j)
 819             dscj_inv=vbld_inv(j+nres)
 820             sig0ij=sigma(itypi,itypj)
 821             chi1=chi(itypi,itypj)
 822             chi2=chi(itypj,itypi)
 823             chi12=chi1*chi2
 824             chip1=chip(itypi)
 825             chip2=chip(itypj)
 826             chip12=chip1*chip2
 827             alf1=alp(itypi)
 828             alf2=alp(itypj)
 829             alf12=0.5D0*(alf1+alf2)
 830 C For diagnostics only!!!
 831 c           chi1=0.0D0
 832 c           chi2=0.0D0
 833 c           chi12=0.0D0
 834 c           chip1=0.0D0
 835 c           chip2=0.0D0
 836 c           chip12=0.0D0
 837 c           alf1=0.0D0
 838 c           alf2=0.0D0
 839 c           alf12=0.0D0
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843             dxj=dc_norm(1,nres+j)
 844             dyj=dc_norm(2,nres+j)
 845             dzj=dc_norm(3,nres+j)
 846 c            write (iout,*) i,j,xj,yj,zj
 847             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 848             rij=dsqrt(rrij)
 849 C Calculate angle-dependent terms of energy and contributions to their
 850 C derivatives.
 851             call sc_angular
 852             sigsq=1.0D0/sigsq
 853             sig=sig0ij*dsqrt(sigsq)
 854             rij_shift=1.0D0/rij-sig+sig0ij
 855 C I hate to put IF's in the loops, but here don't have another choice!!!!
 856             if (rij_shift.le.0.0D0) then
 857               evdw=1.0D20
 858               return
 859             endif
 860             sigder=-sig*sigsq
 861 c---------------------------------------------------------------
 862             rij_shift=1.0D0/rij_shift
 863             fac=rij_shift**expon
 864             e1=fac*fac*aa(itypi,itypj)
 865             e2=fac*bb(itypi,itypj)
 866             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 867             eps2der=evdwij*eps3rt
 868             eps3der=evdwij*eps2rt
 869             evdwij=evdwij*eps2rt*eps3rt
 870             evdw=evdw+evdwij
 871             ij=icant(itypi,itypj)
 872             aux=eps1*eps2rt**2*eps3rt**2
 873 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 874 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 875 c     &         aux*e2/eps(itypi,itypj)
 876             if (lprn) then
 877             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 878             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 879             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 880      &        restyp(itypi),i,restyp(itypj),j,
 881      &        epsi,sigm,chi1,chi2,chip1,chip2,
 882      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 883      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 884      &        evdwij
 885             endif
 886             if (calc_grad) then
 887 C Calculate gradient components.
 888             e1=e1*eps1*eps2rt**2*eps3rt**2
 889             fac=-expon*(e1+evdwij)*rij_shift
 890             sigder=fac*sigder
 891             fac=rij*fac
 892 C Calculate the radial part of the gradient
 893             gg(1)=xj*fac
 894             gg(2)=yj*fac
 895             gg(3)=zj*fac
 896 C Calculate angular part of the gradient.
 897             call sc_grad
 898             endif
 899             ENDIF    ! SSBOND
 900           enddo      ! j
 901         enddo        ! iint
 902       enddo          ! i
 903       return
 904       end
 905 C-----------------------------------------------------------------------------
 906       subroutine egbv(evdw)
 907 C
 908 C This subroutine calculates the interaction energy of nonbonded side chains
 909 C assuming the Gay-Berne-Vorobjev potential of interaction.
 910 C
 911       implicit real*8 (a-h,o-z)
 912       include 'DIMENSIONS'
 913       include 'sizesclu.dat'
 914 c      include "DIMENSIONS.COMPAR"
 915       include 'COMMON.GEO'
 916       include 'COMMON.VAR'
 917       include 'COMMON.LOCAL'
 918       include 'COMMON.CHAIN'
 919       include 'COMMON.DERIV'
 920       include 'COMMON.NAMES'
 921       include 'COMMON.INTERACT'
 922       include 'COMMON.IOUNITS'
 923       include 'COMMON.CALC'
 924       include 'COMMON.SBRIDGE'
 925       common /srutu/ icall
 926       logical lprn
 927       integer icant
 928       external icant
 929       evdw=0.0D0
 930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 931       evdw=0.0D0
 932       lprn=.false.
 933 c      if (icall.gt.0) lprn=.true.
 934       ind=0
 935       do i=iatsc_s,iatsc_e
 936         itypi=itype(i)
 937         itypi1=itype(i+1)
 938         xi=c(1,nres+i)
 939         yi=c(2,nres+i)
 940         zi=c(3,nres+i)
 941         dxi=dc_norm(1,nres+i)
 942         dyi=dc_norm(2,nres+i)
 943         dzi=dc_norm(3,nres+i)
 944         dsci_inv=vbld_inv(i+nres)
 945 C
 946 C Calculate SC interaction energy.
 947 C
 948         do iint=1,nint_gr(i)
 949           do j=istart(i,iint),iend(i,iint)
 950 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 951             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 952               call dyn_ssbond_ene(i,j,evdwij)
 953               evdw=evdw+evdwij
 954 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 955 c     &                        'evdw',i,j,evdwij,' ss'
 956             ELSE
 957             ind=ind+1
 958             itypj=itype(j)
 959             dscj_inv=vbld_inv(j+nres)
 960             sig0ij=sigma(itypi,itypj)
 961             r0ij=r0(itypi,itypj)
 962             chi1=chi(itypi,itypj)
 963             chi2=chi(itypj,itypi)
 964             chi12=chi1*chi2
 965             chip1=chip(itypi)
 966             chip2=chip(itypj)
 967             chip12=chip1*chip2
 968             alf1=alp(itypi)
 969             alf2=alp(itypj)
 970             alf12=0.5D0*(alf1+alf2)
 971 C For diagnostics only!!!
 972 c           chi1=0.0D0
 973 c           chi2=0.0D0
 974 c           chi12=0.0D0
 975 c           chip1=0.0D0
 976 c           chip2=0.0D0
 977 c           chip12=0.0D0
 978 c           alf1=0.0D0
 979 c           alf2=0.0D0
 980 c           alf12=0.0D0
 981             xj=c(1,nres+j)-xi
 982             yj=c(2,nres+j)-yi
 983             zj=c(3,nres+j)-zi
 984             dxj=dc_norm(1,nres+j)
 985             dyj=dc_norm(2,nres+j)
 986             dzj=dc_norm(3,nres+j)
 987             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 988             rij=dsqrt(rrij)
 989 C Calculate angle-dependent terms of energy and contributions to their
 990 C derivatives.
 991             call sc_angular
 992             sigsq=1.0D0/sigsq
 993             sig=sig0ij*dsqrt(sigsq)
 994             rij_shift=1.0D0/rij-sig+r0ij
 995 C I hate to put IF's in the loops, but here don't have another choice!!!!
 996             if (rij_shift.le.0.0D0) then
 997               evdw=1.0D20
 998               return
 999             endif
1000             sigder=-sig*sigsq
1001 c---------------------------------------------------------------
1002             rij_shift=1.0D0/rij_shift
1003             fac=rij_shift**expon
1004             e1=fac*fac*aa(itypi,itypj)
1005             e2=fac*bb(itypi,itypj)
1006             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1007             eps2der=evdwij*eps3rt
1008             eps3der=evdwij*eps2rt
1009             fac_augm=rrij**expon
1010             e_augm=augm(itypi,itypj)*fac_augm
1011             evdwij=evdwij*eps2rt*eps3rt
1012             evdw=evdw+evdwij+e_augm
1013             ij=icant(itypi,itypj)
1014             aux=eps1*eps2rt**2*eps3rt**2
1015 c            if (lprn) then
1016 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1017 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1018 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1019 c     &        restyp(itypi),i,restyp(itypj),j,
1020 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1021 c     &        chi1,chi2,chip1,chip2,
1022 c     &        eps1,eps2rt**2,eps3rt**2,
1023 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1024 c     &        evdwij+e_augm
1025 c            endif
1026             if (calc_grad) then
1027 C Calculate gradient components.
1028             e1=e1*eps1*eps2rt**2*eps3rt**2
1029             fac=-expon*(e1+evdwij)*rij_shift
1030             sigder=fac*sigder
1031             fac=rij*fac-2*expon*rrij*e_augm
1032 C Calculate the radial part of the gradient
1033             gg(1)=xj*fac
1034             gg(2)=yj*fac
1035             gg(3)=zj*fac
1036 C Calculate angular part of the gradient.
1037             call sc_grad
1038             endif
1039             ENDIF    ! dyn_ss
1040           enddo      ! j
1041         enddo        ! iint
1042       enddo          ! i
1043       return
1044       end
1045 C-----------------------------------------------------------------------------
1046       subroutine sc_angular
1047 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1048 C om12. Called by ebp, egb, and egbv.
1049       implicit none
1050       include 'COMMON.CALC'
1051       erij(1)=xj*rij
1052       erij(2)=yj*rij
1053       erij(3)=zj*rij
1054       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1055       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1056       om12=dxi*dxj+dyi*dyj+dzi*dzj
1057       chiom12=chi12*om12
1058 C Calculate eps1(om12) and its derivative in om12
1059       faceps1=1.0D0-om12*chiom12
1060       faceps1_inv=1.0D0/faceps1
1061       eps1=dsqrt(faceps1_inv)
1062 C Following variable is eps1*deps1/dom12
1063       eps1_om12=faceps1_inv*chiom12
1064 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1065 C and om12.
1066       om1om2=om1*om2
1067       chiom1=chi1*om1
1068       chiom2=chi2*om2
1069       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1070       sigsq=1.0D0-facsig*faceps1_inv
1071       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1072       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1073       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1074 C Calculate eps2 and its derivatives in om1, om2, and om12.
1075       chipom1=chip1*om1
1076       chipom2=chip2*om2
1077       chipom12=chip12*om12
1078       facp=1.0D0-om12*chipom12
1079       facp_inv=1.0D0/facp
1080       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1081 C Following variable is the square root of eps2
1082       eps2rt=1.0D0-facp1*facp_inv
1083 C Following three variables are the derivatives of the square root of eps
1084 C in om1, om2, and om12.
1085       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1086       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1087       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1088 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1089       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1090 C Calculate whole angle-dependent part of epsilon and contributions
1091 C to its derivatives
1092       return
1093       end
1094 C----------------------------------------------------------------------------
1095       subroutine sc_grad
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       include 'sizesclu.dat'
1099       include 'COMMON.CHAIN'
1100       include 'COMMON.DERIV'
1101       include 'COMMON.CALC'
1102       double precision dcosom1(3),dcosom2(3)
1103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1104       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1105       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1106      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1107       do k=1,3
1108         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1109         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1110       enddo
1111       do k=1,3
1112         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1113       enddo
1114       do k=1,3
1115         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1117      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1118         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1119      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1120      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1121       enddo
1122 C
1123 C Calculate the components of the gradient in DC and X
1124 C
1125       do k=i,j-1
1126         do l=1,3
1127           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128         enddo
1129       enddo
1130       return
1131       end
1132 c------------------------------------------------------------------------------
1133       subroutine vec_and_deriv
1134       implicit real*8 (a-h,o-z)
1135       include 'DIMENSIONS'
1136       include 'sizesclu.dat'
1137       include 'COMMON.IOUNITS'
1138       include 'COMMON.GEO'
1139       include 'COMMON.VAR'
1140       include 'COMMON.LOCAL'
1141       include 'COMMON.CHAIN'
1142       include 'COMMON.VECTORS'
1143       include 'COMMON.DERIV'
1144       include 'COMMON.INTERACT'
1145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1146 C Compute the local reference systems. For reference system (i), the
1147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1149       do i=1,nres-1
1150 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1151           if (i.eq.nres-1) then
1152 C Case of the last full residue
1153 C Compute the Z-axis
1154             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1155             costh=dcos(pi-theta(nres))
1156             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1157             do k=1,3
1158               uz(k,i)=fac*uz(k,i)
1159             enddo
1160             if (calc_grad) then
1161 C Compute the derivatives of uz
1162             uzder(1,1,1)= 0.0d0
1163             uzder(2,1,1)=-dc_norm(3,i-1)
1164             uzder(3,1,1)= dc_norm(2,i-1)
1165             uzder(1,2,1)= dc_norm(3,i-1)
1166             uzder(2,2,1)= 0.0d0
1167             uzder(3,2,1)=-dc_norm(1,i-1)
1168             uzder(1,3,1)=-dc_norm(2,i-1)
1169             uzder(2,3,1)= dc_norm(1,i-1)
1170             uzder(3,3,1)= 0.0d0
1171             uzder(1,1,2)= 0.0d0
1172             uzder(2,1,2)= dc_norm(3,i)
1173             uzder(3,1,2)=-dc_norm(2,i)
1174             uzder(1,2,2)=-dc_norm(3,i)
1175             uzder(2,2,2)= 0.0d0
1176             uzder(3,2,2)= dc_norm(1,i)
1177             uzder(1,3,2)= dc_norm(2,i)
1178             uzder(2,3,2)=-dc_norm(1,i)
1179             uzder(3,3,2)= 0.0d0
1180             endif
1181 C Compute the Y-axis
1182             facy=fac
1183             do k=1,3
1184               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1185             enddo
1186             if (calc_grad) then
1187 C Compute the derivatives of uy
1188             do j=1,3
1189               do k=1,3
1190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1193               enddo
1194               uyder(j,j,1)=uyder(j,j,1)-costh
1195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1196             enddo
1197             do j=1,2
1198               do k=1,3
1199                 do l=1,3
1200                   uygrad(l,k,j,i)=uyder(l,k,j)
1201                   uzgrad(l,k,j,i)=uzder(l,k,j)
1202                 enddo
1203               enddo
1204             enddo
1205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1209             endif
1210           else
1211 C Other residues
1212 C Compute the Z-axis
1213             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1214             costh=dcos(pi-theta(i+2))
1215             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1216             do k=1,3
1217               uz(k,i)=fac*uz(k,i)
1218             enddo
1219             if (calc_grad) then
1220 C Compute the derivatives of uz
1221             uzder(1,1,1)= 0.0d0
1222             uzder(2,1,1)=-dc_norm(3,i+1)
1223             uzder(3,1,1)= dc_norm(2,i+1)
1224             uzder(1,2,1)= dc_norm(3,i+1)
1225             uzder(2,2,1)= 0.0d0
1226             uzder(3,2,1)=-dc_norm(1,i+1)
1227             uzder(1,3,1)=-dc_norm(2,i+1)
1228             uzder(2,3,1)= dc_norm(1,i+1)
1229             uzder(3,3,1)= 0.0d0
1230             uzder(1,1,2)= 0.0d0
1231             uzder(2,1,2)= dc_norm(3,i)
1232             uzder(3,1,2)=-dc_norm(2,i)
1233             uzder(1,2,2)=-dc_norm(3,i)
1234             uzder(2,2,2)= 0.0d0
1235             uzder(3,2,2)= dc_norm(1,i)
1236             uzder(1,3,2)= dc_norm(2,i)
1237             uzder(2,3,2)=-dc_norm(1,i)
1238             uzder(3,3,2)= 0.0d0
1239             endif
1240 C Compute the Y-axis
1241             facy=fac
1242             do k=1,3
1243               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1244             enddo
1245             if (calc_grad) then
1246 C Compute the derivatives of uy
1247             do j=1,3
1248               do k=1,3
1249                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1250      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1251                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1252               enddo
1253               uyder(j,j,1)=uyder(j,j,1)-costh
1254               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1255             enddo
1256             do j=1,2
1257               do k=1,3
1258                 do l=1,3
1259                   uygrad(l,k,j,i)=uyder(l,k,j)
1260                   uzgrad(l,k,j,i)=uzder(l,k,j)
1261                 enddo
1262               enddo
1263             enddo
1264             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1265             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1266             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1267             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1268           endif
1269           endif
1270       enddo
1271       if (calc_grad) then
1272       do i=1,nres-1
1273         vbld_inv_temp(1)=vbld_inv(i+1)
1274         if (i.lt.nres-1) then
1275           vbld_inv_temp(2)=vbld_inv(i+2)
1276         else
1277           vbld_inv_temp(2)=vbld_inv(i)
1278         endif
1279         do j=1,2
1280           do k=1,3
1281             do l=1,3
1282               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1283               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1284             enddo
1285           enddo
1286         enddo
1287       enddo
1288       endif
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine vec_and_deriv_test
1293       implicit real*8 (a-h,o-z)
1294       include 'DIMENSIONS'
1295       include 'sizesclu.dat'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.VECTORS'
1302       dimension uyder(3,3,2),uzder(3,3,2)
1303 C Compute the local reference systems. For reference system (i), the
1304 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1305 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1306       do i=1,nres-1
1307           if (i.eq.nres-1) then
1308 C Case of the last full residue
1309 C Compute the Z-axis
1310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1311             costh=dcos(pi-theta(nres))
1312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1313 c            write (iout,*) 'fac',fac,
1314 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1315             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1316             do k=1,3
1317               uz(k,i)=fac*uz(k,i)
1318             enddo
1319 C Compute the derivatives of uz
1320             uzder(1,1,1)= 0.0d0
1321             uzder(2,1,1)=-dc_norm(3,i-1)
1322             uzder(3,1,1)= dc_norm(2,i-1)
1323             uzder(1,2,1)= dc_norm(3,i-1)
1324             uzder(2,2,1)= 0.0d0
1325             uzder(3,2,1)=-dc_norm(1,i-1)
1326             uzder(1,3,1)=-dc_norm(2,i-1)
1327             uzder(2,3,1)= dc_norm(1,i-1)
1328             uzder(3,3,1)= 0.0d0
1329             uzder(1,1,2)= 0.0d0
1330             uzder(2,1,2)= dc_norm(3,i)
1331             uzder(3,1,2)=-dc_norm(2,i)
1332             uzder(1,2,2)=-dc_norm(3,i)
1333             uzder(2,2,2)= 0.0d0
1334             uzder(3,2,2)= dc_norm(1,i)
1335             uzder(1,3,2)= dc_norm(2,i)
1336             uzder(2,3,2)=-dc_norm(1,i)
1337             uzder(3,3,2)= 0.0d0
1338 C Compute the Y-axis
1339             do k=1,3
1340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1341             enddo
1342             facy=fac
1343             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1344      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1345      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1346             do k=1,3
1347 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348               uy(k,i)=
1349 c     &        facy*(
1350      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1351      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1352 c     &        )
1353             enddo
1354 c            write (iout,*) 'facy',facy,
1355 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1356             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1357             do k=1,3
1358               uy(k,i)=facy*uy(k,i)
1359             enddo
1360 C Compute the derivatives of uy
1361             do j=1,3
1362               do k=1,3
1363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1366               enddo
1367 c              uyder(j,j,1)=uyder(j,j,1)-costh
1368 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1369               uyder(j,j,1)=uyder(j,j,1)
1370      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1371               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1372      &          +uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386           else
1387 C Other residues
1388 C Compute the Z-axis
1389             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1390             costh=dcos(pi-theta(i+2))
1391             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i+1)
1399             uzder(3,1,1)= dc_norm(2,i+1)
1400             uzder(1,2,1)= dc_norm(3,i+1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i+1)
1403             uzder(1,3,1)=-dc_norm(2,i+1)
1404             uzder(2,3,1)= dc_norm(1,i+1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             facy=fac
1417             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1418      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1419      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1420             do k=1,3
1421 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1422               uy(k,i)=
1423 c     &        facy*(
1424      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1425      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1426 c     &        )
1427             enddo
1428 c            write (iout,*) 'facy',facy,
1429 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1430             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1431             do k=1,3
1432               uy(k,i)=facy*uy(k,i)
1433             enddo
1434 C Compute the derivatives of uy
1435             do j=1,3
1436               do k=1,3
1437                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1438      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1439                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1440               enddo
1441 c              uyder(j,j,1)=uyder(j,j,1)-costh
1442 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1443               uyder(j,j,1)=uyder(j,j,1)
1444      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1445               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1446      &          +uyder(j,j,2)
1447             enddo
1448             do j=1,2
1449               do k=1,3
1450                 do l=1,3
1451                   uygrad(l,k,j,i)=uyder(l,k,j)
1452                   uzgrad(l,k,j,i)=uzder(l,k,j)
1453                 enddo
1454               enddo
1455             enddo
1456             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1457             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1458             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1459             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1460           endif
1461       enddo
1462       do i=1,nres-1
1463         do j=1,2
1464           do k=1,3
1465             do l=1,3
1466               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1467               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1468             enddo
1469           enddo
1470         enddo
1471       enddo
1472       return
1473       end
1474 C-----------------------------------------------------------------------------
1475       subroutine check_vecgrad
1476       implicit real*8 (a-h,o-z)
1477       include 'DIMENSIONS'
1478       include 'sizesclu.dat'
1479       include 'COMMON.IOUNITS'
1480       include 'COMMON.GEO'
1481       include 'COMMON.VAR'
1482       include 'COMMON.LOCAL'
1483       include 'COMMON.CHAIN'
1484       include 'COMMON.VECTORS'
1485       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1486       dimension uyt(3,maxres),uzt(3,maxres)
1487       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1488       double precision delta /1.0d-7/
1489       call vec_and_deriv
1490 cd      do i=1,nres
1491 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1492 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1493 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1494 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1495 cd     &     (dc_norm(if90,i),if90=1,3)
1496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1497 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1498 cd          write(iout,'(a)')
1499 cd      enddo
1500       do i=1,nres
1501         do j=1,2
1502           do k=1,3
1503             do l=1,3
1504               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1505               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1506             enddo
1507           enddo
1508         enddo
1509       enddo
1510       call vec_and_deriv
1511       do i=1,nres
1512         do j=1,3
1513           uyt(j,i)=uy(j,i)
1514           uzt(j,i)=uz(j,i)
1515         enddo
1516       enddo
1517       do i=1,nres
1518 cd        write (iout,*) 'i=',i
1519         do k=1,3
1520           erij(k)=dc_norm(k,i)
1521         enddo
1522         do j=1,3
1523           do k=1,3
1524             dc_norm(k,i)=erij(k)
1525           enddo
1526           dc_norm(j,i)=dc_norm(j,i)+delta
1527 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1528 c          do k=1,3
1529 c            dc_norm(k,i)=dc_norm(k,i)/fac
1530 c          enddo
1531 c          write (iout,*) (dc_norm(k,i),k=1,3)
1532 c          write (iout,*) (erij(k),k=1,3)
1533           call vec_and_deriv
1534           do k=1,3
1535             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1536             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1537             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1538             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1539           enddo
1540 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1541 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1542 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1543         enddo
1544         do k=1,3
1545           dc_norm(k,i)=erij(k)
1546         enddo
1547 cd        do k=1,3
1548 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1549 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1550 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1551 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1552 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1553 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1554 cd          write (iout,'(a)')
1555 cd        enddo
1556       enddo
1557       return
1558       end
1559 C--------------------------------------------------------------------------
1560       subroutine set_matrices
1561       implicit real*8 (a-h,o-z)
1562       include 'DIMENSIONS'
1563       include 'sizesclu.dat'
1564       include 'COMMON.IOUNITS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.CONTACTS'
1572       include 'COMMON.TORSION'
1573       include 'COMMON.VECTORS'
1574       include 'COMMON.FFIELD'
1575       double precision auxvec(2),auxmat(2,2)
1576 C
1577 C Compute the virtual-bond-torsional-angle dependent quantities needed
1578 C to calculate the el-loc multibody terms of various order.
1579 C
1580       do i=3,nres+1
1581         if (i .lt. nres+1) then
1582           sin1=dsin(phi(i))
1583           cos1=dcos(phi(i))
1584           sintab(i-2)=sin1
1585           costab(i-2)=cos1
1586           obrot(1,i-2)=cos1
1587           obrot(2,i-2)=sin1
1588           sin2=dsin(2*phi(i))
1589           cos2=dcos(2*phi(i))
1590           sintab2(i-2)=sin2
1591           costab2(i-2)=cos2
1592           obrot2(1,i-2)=cos2
1593           obrot2(2,i-2)=sin2
1594           Ug(1,1,i-2)=-cos1
1595           Ug(1,2,i-2)=-sin1
1596           Ug(2,1,i-2)=-sin1
1597           Ug(2,2,i-2)= cos1
1598           Ug2(1,1,i-2)=-cos2
1599           Ug2(1,2,i-2)=-sin2
1600           Ug2(2,1,i-2)=-sin2
1601           Ug2(2,2,i-2)= cos2
1602         else
1603           costab(i-2)=1.0d0
1604           sintab(i-2)=0.0d0
1605           obrot(1,i-2)=1.0d0
1606           obrot(2,i-2)=0.0d0
1607           obrot2(1,i-2)=0.0d0
1608           obrot2(2,i-2)=0.0d0
1609           Ug(1,1,i-2)=1.0d0
1610           Ug(1,2,i-2)=0.0d0
1611           Ug(2,1,i-2)=0.0d0
1612           Ug(2,2,i-2)=1.0d0
1613           Ug2(1,1,i-2)=0.0d0
1614           Ug2(1,2,i-2)=0.0d0
1615           Ug2(2,1,i-2)=0.0d0
1616           Ug2(2,2,i-2)=0.0d0
1617         endif
1618         if (i .gt. 3 .and. i .lt. nres+1) then
1619           obrot_der(1,i-2)=-sin1
1620           obrot_der(2,i-2)= cos1
1621           Ugder(1,1,i-2)= sin1
1622           Ugder(1,2,i-2)=-cos1
1623           Ugder(2,1,i-2)=-cos1
1624           Ugder(2,2,i-2)=-sin1
1625           dwacos2=cos2+cos2
1626           dwasin2=sin2+sin2
1627           obrot2_der(1,i-2)=-dwasin2
1628           obrot2_der(2,i-2)= dwacos2
1629           Ug2der(1,1,i-2)= dwasin2
1630           Ug2der(1,2,i-2)=-dwacos2
1631           Ug2der(2,1,i-2)=-dwacos2
1632           Ug2der(2,2,i-2)=-dwasin2
1633         else
1634           obrot_der(1,i-2)=0.0d0
1635           obrot_der(2,i-2)=0.0d0
1636           Ugder(1,1,i-2)=0.0d0
1637           Ugder(1,2,i-2)=0.0d0
1638           Ugder(2,1,i-2)=0.0d0
1639           Ugder(2,2,i-2)=0.0d0
1640           obrot2_der(1,i-2)=0.0d0
1641           obrot2_der(2,i-2)=0.0d0
1642           Ug2der(1,1,i-2)=0.0d0
1643           Ug2der(1,2,i-2)=0.0d0
1644           Ug2der(2,1,i-2)=0.0d0
1645           Ug2der(2,2,i-2)=0.0d0
1646         endif
1647         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1648           iti = itortyp(itype(i-2))
1649         else
1650           iti=ntortyp+1
1651         endif
1652         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1653           iti1 = itortyp(itype(i-1))
1654         else
1655           iti1=ntortyp+1
1656         endif
1657 cd        write (iout,*) '*******i',i,' iti1',iti
1658 cd        write (iout,*) 'b1',b1(:,iti)
1659 cd        write (iout,*) 'b2',b2(:,iti)
1660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1661         if (i .gt. iatel_s+2) then
1662           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1663           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1664           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1665           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1666           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1667           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1668           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1669         else
1670           do k=1,2
1671             Ub2(k,i-2)=0.0d0
1672             Ctobr(k,i-2)=0.0d0
1673             Dtobr2(k,i-2)=0.0d0
1674             do l=1,2
1675               EUg(l,k,i-2)=0.0d0
1676               CUg(l,k,i-2)=0.0d0
1677               DUg(l,k,i-2)=0.0d0
1678               DtUg2(l,k,i-2)=0.0d0
1679             enddo
1680           enddo
1681         endif
1682         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1683         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1684         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1685         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1686         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1687         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1688         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1689         do k=1,2
1690           muder(k,i-2)=Ub2der(k,i-2)
1691         enddo
1692         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1693           iti1 = itortyp(itype(i-1))
1694         else
1695           iti1=ntortyp+1
1696         endif
1697         do k=1,2
1698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1699         enddo
1700 C Vectors and matrices dependent on a single virtual-bond dihedral.
1701         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1702         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1703         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1704         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1705         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1706         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1707         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1708         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1709         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1710 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1711 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1712       enddo
1713 C Matrices dependent on two consecutive virtual-bond dihedrals.
1714 C The order of matrices is from left to right.
1715       do i=2,nres-1
1716         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1717         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1718         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1719         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1720         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1721         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1722         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1723         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1724       enddo
1725 cd      do i=1,nres
1726 cd        iti = itortyp(itype(i))
1727 cd        write (iout,*) i
1728 cd        do j=1,2
1729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1731 cd        enddo
1732 cd      enddo
1733       return
1734       end
1735 C--------------------------------------------------------------------------
1736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1737 C
1738 C This subroutine calculates the average interaction energy and its gradient
1739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1741 C The potential depends both on the distance of peptide-group centers and on
1742 C the orientation of the CA-CA virtual bonds.
1743 C
1744       implicit real*8 (a-h,o-z)
1745       include 'DIMENSIONS'
1746       include 'sizesclu.dat'
1747       include 'COMMON.CONTROL'
1748       include 'COMMON.IOUNITS'
1749       include 'COMMON.GEO'
1750       include 'COMMON.VAR'
1751       include 'COMMON.LOCAL'
1752       include 'COMMON.CHAIN'
1753       include 'COMMON.DERIV'
1754       include 'COMMON.INTERACT'
1755       include 'COMMON.CONTACTS'
1756       include 'COMMON.TORSION'
1757       include 'COMMON.VECTORS'
1758       include 'COMMON.FFIELD'
1759       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1760      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1761       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1765       double precision scal_el /0.5d0/
1766 C 12/13/98
1767 C 13-go grudnia roku pamietnego...
1768       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1769      &                   0.0d0,1.0d0,0.0d0,
1770      &                   0.0d0,0.0d0,1.0d0/
1771 cd      write(iout,*) 'In EELEC'
1772 cd      do i=1,nloctyp
1773 cd        write(iout,*) 'Type',i
1774 cd        write(iout,*) 'B1',B1(:,i)
1775 cd        write(iout,*) 'B2',B2(:,i)
1776 cd        write(iout,*) 'CC',CC(:,:,i)
1777 cd        write(iout,*) 'DD',DD(:,:,i)
1778 cd        write(iout,*) 'EE',EE(:,:,i)
1779 cd      enddo
1780 cd      call check_vecgrad
1781 cd      stop
1782       if (icheckgrad.eq.1) then
1783         do i=1,nres-1
1784           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1785           do k=1,3
1786             dc_norm(k,i)=dc(k,i)*fac
1787           enddo
1788 c          write (iout,*) 'i',i,' fac',fac
1789         enddo
1790       endif
1791       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1792      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1793      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1794 cd      if (wel_loc.gt.0.0d0) then
1795         if (icheckgrad.eq.1) then
1796         call vec_and_deriv_test
1797         else
1798         call vec_and_deriv
1799         endif
1800         call set_matrices
1801       endif
1802 cd      do i=1,nres-1
1803 cd        write (iout,*) 'i=',i
1804 cd        do k=1,3
1805 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1806 cd        enddo
1807 cd        do k=1,3
1808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1810 cd        enddo
1811 cd      enddo
1812       num_conti_hb=0
1813       ees=0.0D0
1814       evdw1=0.0D0
1815       eel_loc=0.0d0
1816       eello_turn3=0.0d0
1817       eello_turn4=0.0d0
1818       ind=0
1819       do i=1,nres
1820         num_cont_hb(i)=0
1821       enddo
1822 cd      print '(a)','Enter EELEC'
1823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1824       do i=1,nres
1825         gel_loc_loc(i)=0.0d0
1826         gcorr_loc(i)=0.0d0
1827       enddo
1828       do i=iatel_s,iatel_e
1829         if (itel(i).eq.0) goto 1215
1830         dxi=dc(1,i)
1831         dyi=dc(2,i)
1832         dzi=dc(3,i)
1833         dx_normi=dc_norm(1,i)
1834         dy_normi=dc_norm(2,i)
1835         dz_normi=dc_norm(3,i)
1836         xmedi=c(1,i)+0.5d0*dxi
1837         ymedi=c(2,i)+0.5d0*dyi
1838         zmedi=c(3,i)+0.5d0*dzi
1839         num_conti=0
1840 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1841         do j=ielstart(i),ielend(i)
1842           if (itel(j).eq.0) goto 1216
1843           ind=ind+1
1844           iteli=itel(i)
1845           itelj=itel(j)
1846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1847           aaa=app(iteli,itelj)
1848           bbb=bpp(iteli,itelj)
1849 C Diagnostics only!!!
1850 c         aaa=0.0D0
1851 c         bbb=0.0D0
1852 c         ael6i=0.0D0
1853 c         ael3i=0.0D0
1854 C End diagnostics
1855           ael6i=ael6(iteli,itelj)
1856           ael3i=ael3(iteli,itelj)
1857           dxj=dc(1,j)
1858           dyj=dc(2,j)
1859           dzj=dc(3,j)
1860           dx_normj=dc_norm(1,j)
1861           dy_normj=dc_norm(2,j)
1862           dz_normj=dc_norm(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           rrmij=1.0D0/rij
1868           rij=dsqrt(rij)
1869           rmij=1.0D0/rij
1870           r3ij=rrmij*rmij
1871           r6ij=r3ij*r3ij
1872           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1873           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1874           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1875           fac=cosa-3.0D0*cosb*cosg
1876           ev1=aaa*r6ij*r6ij
1877 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1878           if (j.eq.i+2) ev1=scal_el*ev1
1879           ev2=bbb*r6ij
1880           fac3=ael6i*r6ij
1881           fac4=ael3i*r3ij
1882           evdwij=ev1+ev2
1883           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1884           el2=fac4*fac
1885           eesij=el1+el2
1886 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1887 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1888           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1889           ees=ees+eesij
1890           evdw1=evdw1+evdwij
1891 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1892 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1893 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1894 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1895 C
1896 C Calculate contributions to the Cartesian gradient.
1897 C
1898 #ifdef SPLITELE
1899           facvdw=-6*rrmij*(ev1+evdwij)
1900           facel=-3*rrmij*(el1+eesij)
1901           fac1=fac
1902           erij(1)=xj*rmij
1903           erij(2)=yj*rmij
1904           erij(3)=zj*rmij
1905           if (calc_grad) then
1906 *
1907 * Radial derivatives. First process both termini of the fragment (i,j)
1908 *
1909           ggg(1)=facel*xj
1910           ggg(2)=facel*yj
1911           ggg(3)=facel*zj
1912           do k=1,3
1913             ghalf=0.5D0*ggg(k)
1914             gelc(k,i)=gelc(k,i)+ghalf
1915             gelc(k,j)=gelc(k,j)+ghalf
1916           enddo
1917 *
1918 * Loop over residues i+1 thru j-1.
1919 *
1920           do k=i+1,j-1
1921             do l=1,3
1922               gelc(l,k)=gelc(l,k)+ggg(l)
1923             enddo
1924           enddo
1925           ggg(1)=facvdw*xj
1926           ggg(2)=facvdw*yj
1927           ggg(3)=facvdw*zj
1928           do k=1,3
1929             ghalf=0.5D0*ggg(k)
1930             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1931             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1932           enddo
1933 *
1934 * Loop over residues i+1 thru j-1.
1935 *
1936           do k=i+1,j-1
1937             do l=1,3
1938               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1939             enddo
1940           enddo
1941 #else
1942           facvdw=ev1+evdwij
1943           facel=el1+eesij
1944           fac1=fac
1945           fac=-3*rrmij*(facvdw+facvdw+facel)
1946           erij(1)=xj*rmij
1947           erij(2)=yj*rmij
1948           erij(3)=zj*rmij
1949           if (calc_grad) then
1950 *
1951 * Radial derivatives. First process both termini of the fragment (i,j)
1952 *
1953           ggg(1)=fac*xj
1954           ggg(2)=fac*yj
1955           ggg(3)=fac*zj
1956           do k=1,3
1957             ghalf=0.5D0*ggg(k)
1958             gelc(k,i)=gelc(k,i)+ghalf
1959             gelc(k,j)=gelc(k,j)+ghalf
1960           enddo
1961 *
1962 * Loop over residues i+1 thru j-1.
1963 *
1964           do k=i+1,j-1
1965             do l=1,3
1966               gelc(l,k)=gelc(l,k)+ggg(l)
1967             enddo
1968           enddo
1969 #endif
1970 *
1971 * Angular part
1972 *
1973           ecosa=2.0D0*fac3*fac1+fac4
1974           fac4=-3.0D0*fac4
1975           fac3=-6.0D0*fac3
1976           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1977           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1978           do k=1,3
1979             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1980             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1981           enddo
1982 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1983 cd   &          (dcosg(k),k=1,3)
1984           do k=1,3
1985             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1986           enddo
1987           do k=1,3
1988             ghalf=0.5D0*ggg(k)
1989             gelc(k,i)=gelc(k,i)+ghalf
1990      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1991      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1992             gelc(k,j)=gelc(k,j)+ghalf
1993      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1994      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1995           enddo
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           endif
2002
2003           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2004      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2005      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2006 C
2007 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2008 C   energy of a peptide unit is assumed in the form of a second-order
2009 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2010 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2011 C   are computed for EVERY pair of non-contiguous peptide groups.
2012 C
2013           if (j.lt.nres-1) then
2014             j1=j+1
2015             j2=j-1
2016           else
2017             j1=j-1
2018             j2=j-2
2019           endif
2020           kkk=0
2021           do k=1,2
2022             do l=1,2
2023               kkk=kkk+1
2024               muij(kkk)=mu(k,i)*mu(l,j)
2025             enddo
2026           enddo
2027 cd         write (iout,*) 'EELEC: i',i,' j',j
2028 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2029 cd          write(iout,*) 'muij',muij
2030           ury=scalar(uy(1,i),erij)
2031           urz=scalar(uz(1,i),erij)
2032           vry=scalar(uy(1,j),erij)
2033           vrz=scalar(uz(1,j),erij)
2034           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2035           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2036           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2037           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2038 C For diagnostics only
2039 cd          a22=1.0d0
2040 cd          a23=1.0d0
2041 cd          a32=1.0d0
2042 cd          a33=1.0d0
2043           fac=dsqrt(-ael6i)*r3ij
2044 cd          write (2,*) 'fac=',fac
2045 C For diagnostics only
2046 cd          fac=1.0d0
2047           a22=a22*fac
2048           a23=a23*fac
2049           a32=a32*fac
2050           a33=a33*fac
2051 cd          write (iout,'(4i5,4f10.5)')
2052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2055 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2056 cd          write (iout,'(4f10.5)')
2057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2060 cd           write (iout,'(2i3,9f10.5/)') i,j,
2061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2062           if (calc_grad) then
2063 C Derivatives of the elements of A in virtual-bond vectors
2064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2065 cd          do k=1,3
2066 cd            do l=1,3
2067 cd              erder(k,l)=0.0d0
2068 cd            enddo
2069 cd          enddo
2070           do k=1,3
2071             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2072             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2073             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2074             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2075             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2076             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2077             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2078             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2079             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2080             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2081             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2082             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2083           enddo
2084 cd          do k=1,3
2085 cd            do l=1,3
2086 cd              uryg(k,l)=0.0d0
2087 cd              urzg(k,l)=0.0d0
2088 cd              vryg(k,l)=0.0d0
2089 cd              vrzg(k,l)=0.0d0
2090 cd            enddo
2091 cd          enddo
2092 C Compute radial contributions to the gradient
2093           facr=-3.0d0*rrmij
2094           a22der=a22*facr
2095           a23der=a23*facr
2096           a32der=a32*facr
2097           a33der=a33*facr
2098 cd          a22der=0.0d0
2099 cd          a23der=0.0d0
2100 cd          a32der=0.0d0
2101 cd          a33der=0.0d0
2102           agg(1,1)=a22der*xj
2103           agg(2,1)=a22der*yj
2104           agg(3,1)=a22der*zj
2105           agg(1,2)=a23der*xj
2106           agg(2,2)=a23der*yj
2107           agg(3,2)=a23der*zj
2108           agg(1,3)=a32der*xj
2109           agg(2,3)=a32der*yj
2110           agg(3,3)=a32der*zj
2111           agg(1,4)=a33der*xj
2112           agg(2,4)=a33der*yj
2113           agg(3,4)=a33der*zj
2114 C Add the contributions coming from er
2115           fac3=-3.0d0*fac
2116           do k=1,3
2117             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2118             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2119             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2120             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2121           enddo
2122           do k=1,3
2123 C Derivatives in DC(i)
2124             ghalf1=0.5d0*agg(k,1)
2125             ghalf2=0.5d0*agg(k,2)
2126             ghalf3=0.5d0*agg(k,3)
2127             ghalf4=0.5d0*agg(k,4)
2128             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2129      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2130             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2131      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2132             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2133      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2134             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2135      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2136 C Derivatives in DC(i+1)
2137             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2138      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2139             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2140      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2141             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2142      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2143             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2144      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2145 C Derivatives in DC(j)
2146             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2147      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2148             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2149      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2150             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2151      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2152             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2153      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2154 C Derivatives in DC(j+1) or DC(nres-1)
2155             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2156      &      -3.0d0*vryg(k,3)*ury)
2157             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2158      &      -3.0d0*vrzg(k,3)*ury)
2159             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2160      &      -3.0d0*vryg(k,3)*urz)
2161             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2162      &      -3.0d0*vrzg(k,3)*urz)
2163 cd            aggi(k,1)=ghalf1
2164 cd            aggi(k,2)=ghalf2
2165 cd            aggi(k,3)=ghalf3
2166 cd            aggi(k,4)=ghalf4
2167 C Derivatives in DC(i+1)
2168 cd            aggi1(k,1)=agg(k,1)
2169 cd            aggi1(k,2)=agg(k,2)
2170 cd            aggi1(k,3)=agg(k,3)
2171 cd            aggi1(k,4)=agg(k,4)
2172 C Derivatives in DC(j)
2173 cd            aggj(k,1)=ghalf1
2174 cd            aggj(k,2)=ghalf2
2175 cd            aggj(k,3)=ghalf3
2176 cd            aggj(k,4)=ghalf4
2177 C Derivatives in DC(j+1)
2178 cd            aggj1(k,1)=0.0d0
2179 cd            aggj1(k,2)=0.0d0
2180 cd            aggj1(k,3)=0.0d0
2181 cd            aggj1(k,4)=0.0d0
2182             if (j.eq.nres-1 .and. i.lt.j-2) then
2183               do l=1,4
2184                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2185 cd                aggj1(k,l)=agg(k,l)
2186               enddo
2187             endif
2188           enddo
2189           endif
2190 c          goto 11111
2191 C Check the loc-el terms by numerical integration
2192           acipa(1,1)=a22
2193           acipa(1,2)=a23
2194           acipa(2,1)=a32
2195           acipa(2,2)=a33
2196           a22=-a22
2197           a23=-a23
2198           do l=1,2
2199             do k=1,3
2200               agg(k,l)=-agg(k,l)
2201               aggi(k,l)=-aggi(k,l)
2202               aggi1(k,l)=-aggi1(k,l)
2203               aggj(k,l)=-aggj(k,l)
2204               aggj1(k,l)=-aggj1(k,l)
2205             enddo
2206           enddo
2207           if (j.lt.nres-1) then
2208             a22=-a22
2209             a32=-a32
2210             do l=1,3,2
2211               do k=1,3
2212                 agg(k,l)=-agg(k,l)
2213                 aggi(k,l)=-aggi(k,l)
2214                 aggi1(k,l)=-aggi1(k,l)
2215                 aggj(k,l)=-aggj(k,l)
2216                 aggj1(k,l)=-aggj1(k,l)
2217               enddo
2218             enddo
2219           else
2220             a22=-a22
2221             a23=-a23
2222             a32=-a32
2223             a33=-a33
2224             do l=1,4
2225               do k=1,3
2226                 agg(k,l)=-agg(k,l)
2227                 aggi(k,l)=-aggi(k,l)
2228                 aggi1(k,l)=-aggi1(k,l)
2229                 aggj(k,l)=-aggj(k,l)
2230                 aggj1(k,l)=-aggj1(k,l)
2231               enddo
2232             enddo
2233           endif
2234           ENDIF ! WCORR
2235 11111     continue
2236           IF (wel_loc.gt.0.0d0) THEN
2237 C Contribution to the local-electrostatic energy coming from the i-j pair
2238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2239      &     +a33*muij(4)
2240 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2241 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2242           eel_loc=eel_loc+eel_loc_ij
2243 C Partial derivatives in virtual-bond dihedral angles gamma
2244           if (calc_grad) then
2245           if (i.gt.1)
2246      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2247      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2248      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2249           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2250      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2251      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2252 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2253 cd          write(iout,*) 'agg  ',agg
2254 cd          write(iout,*) 'aggi ',aggi
2255 cd          write(iout,*) 'aggi1',aggi1
2256 cd          write(iout,*) 'aggj ',aggj
2257 cd          write(iout,*) 'aggj1',aggj1
2258
2259 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2260           do l=1,3
2261             ggg(l)=agg(l,1)*muij(1)+
2262      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2263           enddo
2264           do k=i+2,j2
2265             do l=1,3
2266               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2267             enddo
2268           enddo
2269 C Remaining derivatives of eello
2270           do l=1,3
2271             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2272      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2273             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2274      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2275             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2276      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2277             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2278      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2279           enddo
2280           endif
2281           ENDIF
2282           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2283 C Contributions from turns
2284             a_temp(1,1)=a22
2285             a_temp(1,2)=a23
2286             a_temp(2,1)=a32
2287             a_temp(2,2)=a33
2288             call eturn34(i,j,eello_turn3,eello_turn4)
2289           endif
2290 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2291           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2292 C
2293 C Calculate the contact function. The ith column of the array JCONT will
2294 C contain the numbers of atoms that make contacts with the atom I (of numbers
2295 C greater than I). The arrays FACONT and GACONT will contain the values of
2296 C the contact function and its derivative.
2297 c           r0ij=1.02D0*rpp(iteli,itelj)
2298 c           r0ij=1.11D0*rpp(iteli,itelj)
2299             r0ij=2.20D0*rpp(iteli,itelj)
2300 c           r0ij=1.55D0*rpp(iteli,itelj)
2301             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2302             if (fcont.gt.0.0D0) then
2303               num_conti=num_conti+1
2304               if (num_conti.gt.maxconts) then
2305                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2306      &                         ' will skip next contacts for this conf.'
2307               else
2308                 jcont_hb(num_conti,i)=j
2309                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2310      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2311 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2312 C  terms.
2313                 d_cont(num_conti,i)=rij
2314 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2315 C     --- Electrostatic-interaction matrix ---
2316                 a_chuj(1,1,num_conti,i)=a22
2317                 a_chuj(1,2,num_conti,i)=a23
2318                 a_chuj(2,1,num_conti,i)=a32
2319                 a_chuj(2,2,num_conti,i)=a33
2320 C     --- Gradient of rij
2321                 do kkk=1,3
2322                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2323                 enddo
2324 c             if (i.eq.1) then
2325 c                a_chuj(1,1,num_conti,i)=-0.61d0
2326 c                a_chuj(1,2,num_conti,i)= 0.4d0
2327 c                a_chuj(2,1,num_conti,i)= 0.65d0
2328 c                a_chuj(2,2,num_conti,i)= 0.50d0
2329 c             else if (i.eq.2) then
2330 c                a_chuj(1,1,num_conti,i)= 0.0d0
2331 c                a_chuj(1,2,num_conti,i)= 0.0d0
2332 c                a_chuj(2,1,num_conti,i)= 0.0d0
2333 c                a_chuj(2,2,num_conti,i)= 0.0d0
2334 c             endif
2335 C     --- and its gradients
2336 cd                write (iout,*) 'i',i,' j',j
2337 cd                do kkk=1,3
2338 cd                write (iout,*) 'iii 1 kkk',kkk
2339 cd                write (iout,*) agg(kkk,:)
2340 cd                enddo
2341 cd                do kkk=1,3
2342 cd                write (iout,*) 'iii 2 kkk',kkk
2343 cd                write (iout,*) aggi(kkk,:)
2344 cd                enddo
2345 cd                do kkk=1,3
2346 cd                write (iout,*) 'iii 3 kkk',kkk
2347 cd                write (iout,*) aggi1(kkk,:)
2348 cd                enddo
2349 cd                do kkk=1,3
2350 cd                write (iout,*) 'iii 4 kkk',kkk
2351 cd                write (iout,*) aggj(kkk,:)
2352 cd                enddo
2353 cd                do kkk=1,3
2354 cd                write (iout,*) 'iii 5 kkk',kkk
2355 cd                write (iout,*) aggj1(kkk,:)
2356 cd                enddo
2357                 kkll=0
2358                 do k=1,2
2359                   do l=1,2
2360                     kkll=kkll+1
2361                     do m=1,3
2362                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2363                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2364                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2365                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2366                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2367 c                      do mm=1,5
2368 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2369 c                      enddo
2370                     enddo
2371                   enddo
2372                 enddo
2373                 ENDIF
2374                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2375 C Calculate contact energies
2376                 cosa4=4.0D0*cosa
2377                 wij=cosa-3.0D0*cosb*cosg
2378                 cosbg1=cosb+cosg
2379                 cosbg2=cosb-cosg
2380 c               fac3=dsqrt(-ael6i)/r0ij**3
2381                 fac3=dsqrt(-ael6i)*r3ij
2382                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2383                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2384 c               ees0mij=0.0D0
2385                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2386                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2387 C Diagnostics. Comment out or remove after debugging!
2388 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2389 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2390 c               ees0m(num_conti,i)=0.0D0
2391 C End diagnostics.
2392 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2393 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2394                 facont_hb(num_conti,i)=fcont
2395                 if (calc_grad) then
2396 C Angular derivatives of the contact function
2397                 ees0pij1=fac3/ees0pij
2398                 ees0mij1=fac3/ees0mij
2399                 fac3p=-3.0D0*fac3*rrmij
2400                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2401                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2402 c               ees0mij1=0.0D0
2403                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2404                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2405                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2406                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2407                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2408                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2409                 ecosap=ecosa1+ecosa2
2410                 ecosbp=ecosb1+ecosb2
2411                 ecosgp=ecosg1+ecosg2
2412                 ecosam=ecosa1-ecosa2
2413                 ecosbm=ecosb1-ecosb2
2414                 ecosgm=ecosg1-ecosg2
2415 C Diagnostics
2416 c               ecosap=ecosa1
2417 c               ecosbp=ecosb1
2418 c               ecosgp=ecosg1
2419 c               ecosam=0.0D0
2420 c               ecosbm=0.0D0
2421 c               ecosgm=0.0D0
2422 C End diagnostics
2423                 fprimcont=fprimcont/rij
2424 cd              facont_hb(num_conti,i)=1.0D0
2425 C Following line is for diagnostics.
2426 cd              fprimcont=0.0D0
2427                 do k=1,3
2428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2430                 enddo
2431                 do k=1,3
2432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2434                 enddo
2435                 gggp(1)=gggp(1)+ees0pijp*xj
2436                 gggp(2)=gggp(2)+ees0pijp*yj
2437                 gggp(3)=gggp(3)+ees0pijp*zj
2438                 gggm(1)=gggm(1)+ees0mijp*xj
2439                 gggm(2)=gggm(2)+ees0mijp*yj
2440                 gggm(3)=gggm(3)+ees0mijp*zj
2441 C Derivatives due to the contact function
2442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2445                 do k=1,3
2446                   ghalfp=0.5D0*gggp(k)
2447                   ghalfm=0.5D0*gggm(k)
2448                   gacontp_hb1(k,num_conti,i)=ghalfp
2449      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2450      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2451                   gacontp_hb2(k,num_conti,i)=ghalfp
2452      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2453      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2454                   gacontp_hb3(k,num_conti,i)=gggp(k)
2455                   gacontm_hb1(k,num_conti,i)=ghalfm
2456      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2457      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2458                   gacontm_hb2(k,num_conti,i)=ghalfm
2459      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2460      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2461                   gacontm_hb3(k,num_conti,i)=gggm(k)
2462                 enddo
2463                 endif
2464 C Diagnostics. Comment out or remove after debugging!
2465 cdiag           do k=1,3
2466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2472 cdiag           enddo
2473               ENDIF ! wcorr
2474               endif  ! num_conti.le.maxconts
2475             endif  ! fcont.gt.0
2476           endif    ! j.gt.i+1
2477  1216     continue
2478         enddo ! j
2479         num_cont_hb(i)=num_conti
2480  1215   continue
2481       enddo   ! i
2482 cd      do i=1,nres
2483 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2484 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2485 cd      enddo
2486 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2487 ccc      eel_loc=eel_loc+eello_turn3
2488       return
2489       end
2490 C-----------------------------------------------------------------------------
2491       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2492 C Third- and fourth-order contributions from turns
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'sizesclu.dat'
2496       include 'COMMON.IOUNITS'
2497       include 'COMMON.GEO'
2498       include 'COMMON.VAR'
2499       include 'COMMON.LOCAL'
2500       include 'COMMON.CHAIN'
2501       include 'COMMON.DERIV'
2502       include 'COMMON.INTERACT'
2503       include 'COMMON.CONTACTS'
2504       include 'COMMON.TORSION'
2505       include 'COMMON.VECTORS'
2506       include 'COMMON.FFIELD'
2507       dimension ggg(3)
2508       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2509      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2510      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2511       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2512      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2514       if (j.eq.i+2) then
2515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2516 C
2517 C               Third-order contributions
2518 C
2519 C                 (i+2)o----(i+3)
2520 C                      | |
2521 C                      | |
2522 C                 (i+1)o----i
2523 C
2524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2525 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2526         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2527         call transpose2(auxmat(1,1),auxmat1(1,1))
2528         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2529         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2530 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2531 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2532 cd     &    ' eello_turn3_num',4*eello_turn3_num
2533         if (calc_grad) then
2534 C Derivatives in gamma(i)
2535         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2536         call transpose2(auxmat2(1,1),pizda(1,1))
2537         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2538         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2539 C Derivatives in gamma(i+1)
2540         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2541         call transpose2(auxmat2(1,1),pizda(1,1))
2542         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2543         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2544      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2545 C Cartesian derivatives
2546         do l=1,3
2547           a_temp(1,1)=aggi(l,1)
2548           a_temp(1,2)=aggi(l,2)
2549           a_temp(2,1)=aggi(l,3)
2550           a_temp(2,2)=aggi(l,4)
2551           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2552           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2553      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2554           a_temp(1,1)=aggi1(l,1)
2555           a_temp(1,2)=aggi1(l,2)
2556           a_temp(2,1)=aggi1(l,3)
2557           a_temp(2,2)=aggi1(l,4)
2558           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2559           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2560      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2561           a_temp(1,1)=aggj(l,1)
2562           a_temp(1,2)=aggj(l,2)
2563           a_temp(2,1)=aggj(l,3)
2564           a_temp(2,2)=aggj(l,4)
2565           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2566           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2567      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2568           a_temp(1,1)=aggj1(l,1)
2569           a_temp(1,2)=aggj1(l,2)
2570           a_temp(2,1)=aggj1(l,3)
2571           a_temp(2,2)=aggj1(l,4)
2572           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2573           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2574      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2575         enddo
2576         endif
2577       else if (j.eq.i+3) then
2578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2579 C
2580 C               Fourth-order contributions
2581 C
2582 C                 (i+3)o----(i+4)
2583 C                     /  |
2584 C               (i+2)o   |
2585 C                     \  |
2586 C                 (i+1)o----i
2587 C
2588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2589 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2590         iti1=itortyp(itype(i+1))
2591         iti2=itortyp(itype(i+2))
2592         iti3=itortyp(itype(i+3))
2593         call transpose2(EUg(1,1,i+1),e1t(1,1))
2594         call transpose2(Eug(1,1,i+2),e2t(1,1))
2595         call transpose2(Eug(1,1,i+3),e3t(1,1))
2596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2597         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2598         s1=scalar2(b1(1,iti2),auxvec(1))
2599         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2601         s2=scalar2(b1(1,iti1),auxvec(1))
2602         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2603         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2604         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2605         eello_turn4=eello_turn4-(s1+s2+s3)
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2607 cd     &    ' eello_turn4_num',8*eello_turn4_num
2608 C Derivatives in gamma(i)
2609         if (calc_grad) then
2610         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2611         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2613         s1=scalar2(b1(1,iti2),auxvec(1))
2614         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2615         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2617 C Derivatives in gamma(i+1)
2618         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2619         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2620         s2=scalar2(b1(1,iti1),auxvec(1))
2621         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2622         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2623         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2624         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2625 C Derivatives in gamma(i+2)
2626         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2627         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2628         s1=scalar2(b1(1,iti2),auxvec(1))
2629         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2631         s2=scalar2(b1(1,iti1),auxvec(1))
2632         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2633         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2634         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2636 C Cartesian derivatives
2637 C Derivatives of this turn contributions in DC(i+2)
2638         if (j.lt.nres-1) then
2639           do l=1,3
2640             a_temp(1,1)=agg(l,1)
2641             a_temp(1,2)=agg(l,2)
2642             a_temp(2,1)=agg(l,3)
2643             a_temp(2,2)=agg(l,4)
2644             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2645             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2646             s1=scalar2(b1(1,iti2),auxvec(1))
2647             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2648             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2649             s2=scalar2(b1(1,iti1),auxvec(1))
2650             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2651             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2652             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653             ggg(l)=-(s1+s2+s3)
2654             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2655           enddo
2656         endif
2657 C Remaining derivatives of this turn contribution
2658         do l=1,3
2659           a_temp(1,1)=aggi(l,1)
2660           a_temp(1,2)=aggi(l,2)
2661           a_temp(2,1)=aggi(l,3)
2662           a_temp(2,2)=aggi(l,4)
2663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2665           s1=scalar2(b1(1,iti2),auxvec(1))
2666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2668           s2=scalar2(b1(1,iti1),auxvec(1))
2669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2672           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2673           a_temp(1,1)=aggi1(l,1)
2674           a_temp(1,2)=aggi1(l,2)
2675           a_temp(2,1)=aggi1(l,3)
2676           a_temp(2,2)=aggi1(l,4)
2677           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2678           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2679           s1=scalar2(b1(1,iti2),auxvec(1))
2680           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2681           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2682           s2=scalar2(b1(1,iti1),auxvec(1))
2683           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2684           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2685           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2686           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2687           a_temp(1,1)=aggj(l,1)
2688           a_temp(1,2)=aggj(l,2)
2689           a_temp(2,1)=aggj(l,3)
2690           a_temp(2,2)=aggj(l,4)
2691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2693           s1=scalar2(b1(1,iti2),auxvec(1))
2694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2696           s2=scalar2(b1(1,iti1),auxvec(1))
2697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2701           a_temp(1,1)=aggj1(l,1)
2702           a_temp(1,2)=aggj1(l,2)
2703           a_temp(2,1)=aggj1(l,3)
2704           a_temp(2,2)=aggj1(l,4)
2705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2707           s1=scalar2(b1(1,iti2),auxvec(1))
2708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2710           s2=scalar2(b1(1,iti1),auxvec(1))
2711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2714           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2715         enddo
2716         endif
2717       endif
2718       return
2719       end
2720 C-----------------------------------------------------------------------------
2721       subroutine vecpr(u,v,w)
2722       implicit real*8(a-h,o-z)
2723       dimension u(3),v(3),w(3)
2724       w(1)=u(2)*v(3)-u(3)*v(2)
2725       w(2)=-u(1)*v(3)+u(3)*v(1)
2726       w(3)=u(1)*v(2)-u(2)*v(1)
2727       return
2728       end
2729 C-----------------------------------------------------------------------------
2730       subroutine unormderiv(u,ugrad,unorm,ungrad)
2731 C This subroutine computes the derivatives of a normalized vector u, given
2732 C the derivatives computed without normalization conditions, ugrad. Returns
2733 C ungrad.
2734       implicit none
2735       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2736       double precision vec(3)
2737       double precision scalar
2738       integer i,j
2739 c      write (2,*) 'ugrad',ugrad
2740 c      write (2,*) 'u',u
2741       do i=1,3
2742         vec(i)=scalar(ugrad(1,i),u(1))
2743       enddo
2744 c      write (2,*) 'vec',vec
2745       do i=1,3
2746         do j=1,3
2747           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2748         enddo
2749       enddo
2750 c      write (2,*) 'ungrad',ungrad
2751       return
2752       end
2753 C-----------------------------------------------------------------------------
2754       subroutine escp(evdw2,evdw2_14)
2755 C
2756 C This subroutine calculates the excluded-volume interaction energy between
2757 C peptide-group centers and side chains and its gradient in virtual-bond and
2758 C side-chain vectors.
2759 C
2760       implicit real*8 (a-h,o-z)
2761       include 'DIMENSIONS'
2762       include 'sizesclu.dat'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.FFIELD'
2770       include 'COMMON.IOUNITS'
2771       dimension ggg(3)
2772       evdw2=0.0D0
2773       evdw2_14=0.0d0
2774 cd    print '(a)','Enter ESCP'
2775 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2776 c     &  ' scal14',scal14
2777       do i=iatscp_s,iatscp_e
2778         iteli=itel(i)
2779 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2780 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2781         if (iteli.eq.0) goto 1225
2782         xi=0.5D0*(c(1,i)+c(1,i+1))
2783         yi=0.5D0*(c(2,i)+c(2,i+1))
2784         zi=0.5D0*(c(3,i)+c(3,i+1))
2785
2786         do iint=1,nscp_gr(i)
2787
2788         do j=iscpstart(i,iint),iscpend(i,iint)
2789           itypj=itype(j)
2790 C Uncomment following three lines for SC-p interactions
2791 c         xj=c(1,nres+j)-xi
2792 c         yj=c(2,nres+j)-yi
2793 c         zj=c(3,nres+j)-zi
2794 C Uncomment following three lines for Ca-p interactions
2795           xj=c(1,j)-xi
2796           yj=c(2,j)-yi
2797           zj=c(3,j)-zi
2798           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2799           fac=rrij**expon2
2800           e1=fac*fac*aad(itypj,iteli)
2801           e2=fac*bad(itypj,iteli)
2802           if (iabs(j-i) .le. 2) then
2803             e1=scal14*e1
2804             e2=scal14*e2
2805             evdw2_14=evdw2_14+e1+e2
2806           endif
2807           evdwij=e1+e2
2808 c          write (iout,*) i,j,evdwij
2809           evdw2=evdw2+evdwij
2810           if (calc_grad) then
2811 C
2812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2813 C
2814           fac=-(evdwij+e1)*rrij
2815           ggg(1)=xj*fac
2816           ggg(2)=yj*fac
2817           ggg(3)=zj*fac
2818           if (j.lt.i) then
2819 cd          write (iout,*) 'j<i'
2820 C Uncomment following three lines for SC-p interactions
2821 c           do k=1,3
2822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2823 c           enddo
2824           else
2825 cd          write (iout,*) 'j>i'
2826             do k=1,3
2827               ggg(k)=-ggg(k)
2828 C Uncomment following line for SC-p interactions
2829 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2830             enddo
2831           endif
2832           do k=1,3
2833             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2834           enddo
2835           kstart=min0(i+1,j)
2836           kend=max0(i-1,j-1)
2837 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2838 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2839           do k=kstart,kend
2840             do l=1,3
2841               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2842             enddo
2843           enddo
2844           endif
2845         enddo
2846         enddo ! iint
2847  1225   continue
2848       enddo ! i
2849       do i=1,nct
2850         do j=1,3
2851           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2852           gradx_scp(j,i)=expon*gradx_scp(j,i)
2853         enddo
2854       enddo
2855 C******************************************************************************
2856 C
2857 C                              N O T E !!!
2858 C
2859 C To save time the factor EXPON has been extracted from ALL components
2860 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2861 C use!
2862 C
2863 C******************************************************************************
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine edis(ehpb)
2868 C
2869 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2870 C
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873       include 'COMMON.SBRIDGE'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.VAR'
2877       include 'COMMON.INTERACT'
2878       include 'COMMON.IOUNITS'
2879       dimension ggg(3)
2880       ehpb=0.0D0
2881 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2882 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2883       if (link_end.eq.0) return
2884       do i=link_start,link_end
2885 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2886 C CA-CA distance used in regularization of structure.
2887         ii=ihpb(i)
2888         jj=jhpb(i)
2889 C iii and jjj point to the residues for which the distance is assigned.
2890         if (ii.gt.nres) then
2891           iii=ii-nres
2892           jjj=jj-nres
2893         else
2894           iii=ii
2895           jjj=jj
2896         endif
2897 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2898 c     &    dhpb(i),dhpb1(i),forcon(i)
2899 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2900 C    distance and angle dependent SS bond potential.
2901         if (.not.dyn_ss .and. i.le.nss) then
2902 C 15/02/13 CC dynamic SSbond - additional check
2903         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2904           call ssbond_ene(iii,jjj,eij)
2905           ehpb=ehpb+2*eij
2906 cd          write (iout,*) "eij",eij
2907         endif
2908         else if (ii.gt.nres .and. jj.gt.nres) then
2909 c Restraints from contact prediction
2910           dd=dist(ii,jj)
2911           if (dhpb1(i).gt.0.0d0) then
2912             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2913             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2914 c            write (iout,*) "beta nmr",
2915 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2916           else
2917             dd=dist(ii,jj)
2918             rdis=dd-dhpb(i)
2919 C Get the force constant corresponding to this distance.
2920             waga=forcon(i)
2921 C Calculate the contribution to energy.
2922             ehpb=ehpb+waga*rdis*rdis
2923 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2924 C
2925 C Evaluate gradient.
2926 C
2927             fac=waga*rdis/dd
2928           endif
2929           do j=1,3
2930             ggg(j)=fac*(c(j,jj)-c(j,ii))
2931           enddo
2932           do j=1,3
2933             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2934             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2935           enddo
2936           do k=1,3
2937             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2938             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2939           enddo
2940         else
2941 C Calculate the distance between the two points and its difference from the
2942 C target distance.
2943           dd=dist(ii,jj)
2944           if (dhpb1(i).gt.0.0d0) then
2945             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2946             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2947 c            write (iout,*) "alph nmr",
2948 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2949           else
2950             rdis=dd-dhpb(i)
2951 C Get the force constant corresponding to this distance.
2952             waga=forcon(i)
2953 C Calculate the contribution to energy.
2954             ehpb=ehpb+waga*rdis*rdis
2955 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2956 C
2957 C Evaluate gradient.
2958 C
2959             fac=waga*rdis/dd
2960           endif
2961 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2962 cd   &   ' waga=',waga,' fac=',fac
2963             do j=1,3
2964               ggg(j)=fac*(c(j,jj)-c(j,ii))
2965             enddo
2966 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2967 C If this is a SC-SC distance, we need to calculate the contributions to the
2968 C Cartesian gradient in the SC vectors (ghpbx).
2969           if (iii.lt.ii) then
2970           do j=1,3
2971             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2972             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2973           enddo
2974           endif
2975           do k=1,3
2976             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2977             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2978           enddo
2979         endif
2980       enddo
2981       ehpb=0.5D0*ehpb
2982       return
2983       end
2984 C--------------------------------------------------------------------------
2985       subroutine ssbond_ene(i,j,eij)
2986 C
2987 C Calculate the distance and angle dependent SS-bond potential energy
2988 C using a free-energy function derived based on RHF/6-31G** ab initio
2989 C calculations of diethyl disulfide.
2990 C
2991 C A. Liwo and U. Kozlowska, 11/24/03
2992 C
2993       implicit real*8 (a-h,o-z)
2994       include 'DIMENSIONS'
2995       include 'sizesclu.dat'
2996       include 'COMMON.SBRIDGE'
2997       include 'COMMON.CHAIN'
2998       include 'COMMON.DERIV'
2999       include 'COMMON.LOCAL'
3000       include 'COMMON.INTERACT'
3001       include 'COMMON.VAR'
3002       include 'COMMON.IOUNITS'
3003       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3004       itypi=itype(i)
3005       xi=c(1,nres+i)
3006       yi=c(2,nres+i)
3007       zi=c(3,nres+i)
3008       dxi=dc_norm(1,nres+i)
3009       dyi=dc_norm(2,nres+i)
3010       dzi=dc_norm(3,nres+i)
3011       dsci_inv=dsc_inv(itypi)
3012       itypj=itype(j)
3013       dscj_inv=dsc_inv(itypj)
3014       xj=c(1,nres+j)-xi
3015       yj=c(2,nres+j)-yi
3016       zj=c(3,nres+j)-zi
3017       dxj=dc_norm(1,nres+j)
3018       dyj=dc_norm(2,nres+j)
3019       dzj=dc_norm(3,nres+j)
3020       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3021       rij=dsqrt(rrij)
3022       erij(1)=xj*rij
3023       erij(2)=yj*rij
3024       erij(3)=zj*rij
3025       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3026       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3027       om12=dxi*dxj+dyi*dyj+dzi*dzj
3028       do k=1,3
3029         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3030         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3031       enddo
3032       rij=1.0d0/rij
3033       deltad=rij-d0cm
3034       deltat1=1.0d0-om1
3035       deltat2=1.0d0+om2
3036       deltat12=om2-om1+2.0d0
3037       cosphi=om12-om1*om2
3038       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3039      &  +akct*deltad*deltat12+ebr
3040      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3041 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3042 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3043 c     &  " deltat12",deltat12," eij",eij
3044       ed=2*akcm*deltad+akct*deltat12
3045       pom1=akct*deltad
3046       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3047       eom1=-2*akth*deltat1-pom1-om2*pom2
3048       eom2= 2*akth*deltat2+pom1-om1*pom2
3049       eom12=pom2
3050       do k=1,3
3051         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3052       enddo
3053       do k=1,3
3054         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3055      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3056         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3057      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3058       enddo
3059 C
3060 C Calculate the components of the gradient in DC and X
3061 C
3062       do k=i,j-1
3063         do l=1,3
3064           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3065         enddo
3066       enddo
3067       return
3068       end
3069
3070 C--------------------------------------------------------------------------
3071
3072
3073 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3074       subroutine e_modeller(ehomology_constr)
3075       implicit real*8 (a-h,o-z)
3076
3077       include 'DIMENSIONS'
3078
3079       integer nnn, i, j, k, ki, irec, l
3080       integer katy, odleglosci, test7
3081       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3082       real*8 distance(max_template),distancek(max_template),
3083      &    min_odl,godl(max_template),dih_diff(max_template)
3084
3085 c
3086 c     FP - 30/10/2014 Temporary specifications for homology restraints
3087 c
3088       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3089      &                 sgtheta
3090       double precision, dimension (maxres) :: guscdiff,usc_diff
3091       double precision, dimension (max_template) ::
3092      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3093      &           theta_diff
3094
3095       include 'COMMON.SBRIDGE'
3096       include 'COMMON.CHAIN'
3097       include 'COMMON.GEO'
3098       include 'COMMON.DERIV'
3099       include 'COMMON.LOCAL'
3100       include 'COMMON.INTERACT'
3101       include 'COMMON.VAR'
3102       include 'COMMON.IOUNITS'
3103       include 'COMMON.CONTROL'
3104       include 'COMMON.HOMRESTR'
3105 c
3106       include 'COMMON.SETUP'
3107       include 'COMMON.NAMES'
3108
3109       do i=1,19
3110         distancek(i)=9999999.9
3111       enddo
3112
3113       odleg=0.0d0
3114
3115 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3116 c function)
3117 C AL 5/2/14 - Introduce list of restraints
3118 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3119 #ifdef DEBUG
3120       write(iout,*) "------- dist restrs start -------"
3121       write (iout,*) "link_start_homo",link_start_homo,
3122      &    " link_end_homo",link_end_homo
3123 #endif
3124       do ii = link_start_homo,link_end_homo
3125          i = ires_homo(ii)
3126          j = jres_homo(ii)
3127          dij=dist(i,j)
3128 c        write (iout,*) "dij(",i,j,") =",dij
3129          do k=1,constr_homology
3130            distance(k)=odl(k,ii)-dij
3131 c          write (iout,*) "distance(",k,") =",distance(k)
3132 c
3133 c          For Gaussian-type Urestr
3134 c
3135            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3136 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3137 c          write (iout,*) "distancek(",k,") =",distancek(k)
3138 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3139 c
3140 c          For Lorentzian-type Urestr
3141 c
3142            if (waga_dist.lt.0.0d0) then
3143               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3144               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3145      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3146            endif
3147          enddo
3148
3149          min_odl=minval(distancek)
3150 c        write (iout,* )"min_odl",min_odl
3151 #ifdef DEBUG
3152          write (iout,*) "ij dij",i,j,dij
3153          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3154          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3155          write (iout,* )"min_odl",min_odl
3156 #endif
3157          odleg2=0.0d0
3158          do k=1,constr_homology
3159 c Nie wiem po co to liczycie jeszcze raz!
3160 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3161 c     &              (2*(sigma_odl(i,j,k))**2))
3162            if (waga_dist.ge.0.0d0) then
3163 c
3164 c          For Gaussian-type Urestr
3165 c
3166             godl(k)=dexp(-distancek(k)+min_odl)
3167             odleg2=odleg2+godl(k)
3168 c
3169 c          For Lorentzian-type Urestr
3170 c
3171            else
3172             odleg2=odleg2+distancek(k)
3173            endif
3174
3175 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3176 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3177 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3178 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3179
3180          enddo
3181 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3182 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3183 #ifdef DEBUG
3184          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3185          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3186 #endif
3187            if (waga_dist.ge.0.0d0) then
3188 c
3189 c          For Gaussian-type Urestr
3190 c
3191               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3192 c
3193 c          For Lorentzian-type Urestr
3194 c
3195            else
3196               odleg=odleg+odleg2/constr_homology
3197            endif
3198 c
3199 #ifdef GRAD
3200 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3201 c Gradient
3202 c
3203 c          For Gaussian-type Urestr
3204 c
3205          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3206          sum_sgodl=0.0d0
3207          do k=1,constr_homology
3208 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3209 c     &           *waga_dist)+min_odl
3210 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3211 c
3212          if (waga_dist.ge.0.0d0) then
3213 c          For Gaussian-type Urestr
3214 c
3215            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3216 c
3217 c          For Lorentzian-type Urestr
3218 c
3219          else
3220            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3221      &           sigma_odlir(k,ii)**2)**2)
3222          endif
3223            sum_sgodl=sum_sgodl+sgodl
3224
3225 c            sgodl2=sgodl2+sgodl
3226 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3227 c      write(iout,*) "constr_homology=",constr_homology
3228 c      write(iout,*) i, j, k, "TEST K"
3229          enddo
3230          if (waga_dist.ge.0.0d0) then
3231 c
3232 c          For Gaussian-type Urestr
3233 c
3234             grad_odl3=waga_homology(iset)*waga_dist
3235      &                *sum_sgodl/(sum_godl*dij)
3236 c
3237 c          For Lorentzian-type Urestr
3238 c
3239          else
3240 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3241 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3242             grad_odl3=-waga_homology(iset)*waga_dist*
3243      &                sum_sgodl/(constr_homology*dij)
3244          endif
3245 c
3246 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3247
3248
3249 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3250 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3251 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3252
3253 ccc      write(iout,*) godl, sgodl, grad_odl3
3254
3255 c          grad_odl=grad_odl+grad_odl3
3256
3257          do jik=1,3
3258             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3259 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3260 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3261 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3262             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3263             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3264 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3265 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3266 c         if (i.eq.25.and.j.eq.27) then
3267 c         write(iout,*) "jik",jik,"i",i,"j",j
3268 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3269 c         write(iout,*) "grad_odl3",grad_odl3
3270 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3271 c         write(iout,*) "ggodl",ggodl
3272 c         write(iout,*) "ghpbc(",jik,i,")",
3273 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3274 c     &                 ghpbc(jik,j)
3275 c         endif
3276          enddo
3277 #endif
3278 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3279 ccc     & dLOG(odleg2),"-odleg=", -odleg
3280
3281       enddo ! ii-loop for dist
3282 #ifdef DEBUG
3283       write(iout,*) "------- dist restrs end -------"
3284 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3285 c    &     waga_d.eq.1.0d0) call sum_gradient
3286 #endif
3287 c Pseudo-energy and gradient from dihedral-angle restraints from
3288 c homology templates
3289 c      write (iout,*) "End of distance loop"
3290 c      call flush(iout)
3291       kat=0.0d0
3292 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3293 #ifdef DEBUG
3294       write(iout,*) "------- dih restrs start -------"
3295       do i=idihconstr_start_homo,idihconstr_end_homo
3296         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3297       enddo
3298 #endif
3299       do i=idihconstr_start_homo,idihconstr_end_homo
3300         kat2=0.0d0
3301 c        betai=beta(i,i+1,i+2,i+3)
3302         betai = phi(i+3)
3303 c       write (iout,*) "betai =",betai
3304         do k=1,constr_homology
3305           dih_diff(k)=pinorm(dih(k,i)-betai)
3306 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3307 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3308 c     &                                   -(6.28318-dih_diff(i,k))
3309 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3310 c     &                                   6.28318+dih_diff(i,k)
3311
3312           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3313 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3314           gdih(k)=dexp(kat3)
3315           kat2=kat2+gdih(k)
3316 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3317 c          write(*,*)""
3318         enddo
3319 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3320 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3321 #ifdef DEBUG
3322         write (iout,*) "i",i," betai",betai," kat2",kat2
3323         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3324 #endif
3325         if (kat2.le.1.0d-14) cycle
3326         kat=kat-dLOG(kat2/constr_homology)
3327 c       write (iout,*) "kat",kat ! sum of -ln-s
3328
3329 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3330 ccc     & dLOG(kat2), "-kat=", -kat
3331
3332 #ifdef GRAD
3333 c ----------------------------------------------------------------------
3334 c Gradient
3335 c ----------------------------------------------------------------------
3336
3337         sum_gdih=kat2
3338         sum_sgdih=0.0d0
3339         do k=1,constr_homology
3340           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3341 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3342           sum_sgdih=sum_sgdih+sgdih
3343         enddo
3344 c       grad_dih3=sum_sgdih/sum_gdih
3345         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3346
3347 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3348 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3349 ccc     & gloc(nphi+i-3,icg)
3350         gloc(i,icg)=gloc(i,icg)+grad_dih3
3351 c        if (i.eq.25) then
3352 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3353 c        endif
3354 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3355 ccc     & gloc(nphi+i-3,icg)
3356 #endif
3357       enddo ! i-loop for dih
3358 #ifdef DEBUG
3359       write(iout,*) "------- dih restrs end -------"
3360 #endif
3361
3362 c Pseudo-energy and gradient for theta angle restraints from
3363 c homology templates
3364 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3365 c adapted
3366
3367 c
3368 c     For constr_homology reference structures (FP)
3369 c
3370 c     Uconst_back_tot=0.0d0
3371       Eval=0.0d0
3372       Erot=0.0d0
3373 c     Econstr_back legacy
3374 #ifdef GRAD
3375       do i=1,nres
3376 c     do i=ithet_start,ithet_end
3377        dutheta(i)=0.0d0
3378 c     enddo
3379 c     do i=loc_start,loc_end
3380         do j=1,3
3381           duscdiff(j,i)=0.0d0
3382           duscdiffx(j,i)=0.0d0
3383         enddo
3384       enddo
3385 #endif
3386 c
3387 c     do iref=1,nref
3388 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3389 c     write (iout,*) "waga_theta",waga_theta
3390       if (waga_theta.gt.0.0d0) then
3391 #ifdef DEBUG
3392       write (iout,*) "usampl",usampl
3393       write(iout,*) "------- theta restrs start -------"
3394 c     do i=ithet_start,ithet_end
3395 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3396 c     enddo
3397 #endif
3398 c     write (iout,*) "maxres",maxres,"nres",nres
3399
3400       do i=ithet_start,ithet_end
3401 c
3402 c     do i=1,nfrag_back
3403 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3404 c
3405 c Deviation of theta angles wrt constr_homology ref structures
3406 c
3407         utheta_i=0.0d0 ! argument of Gaussian for single k
3408         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3409 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3410 c       over residues in a fragment
3411 c       write (iout,*) "theta(",i,")=",theta(i)
3412         do k=1,constr_homology
3413 c
3414 c         dtheta_i=theta(j)-thetaref(j,iref)
3415 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3416           theta_diff(k)=thetatpl(k,i)-theta(i)
3417 c
3418           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3419 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3420           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3421           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3422 c         Gradient for single Gaussian restraint in subr Econstr_back
3423 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3424 c
3425         enddo
3426 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3427 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3428
3429 c
3430 #ifdef GRAD
3431 c         Gradient for multiple Gaussian restraint
3432         sum_gtheta=gutheta_i
3433         sum_sgtheta=0.0d0
3434         do k=1,constr_homology
3435 c        New generalized expr for multiple Gaussian from Econstr_back
3436          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3437 c
3438 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3439           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3440         enddo
3441 c       grad_theta3=sum_sgtheta/sum_gtheta 1/*theta(i)? s. line below
3442 c       grad_theta3=sum_sgtheta/sum_gtheta
3443 c
3444 c       Final value of gradient using same var as in Econstr_back
3445         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3446      &               *waga_homology(iset)
3447 c       dutheta(i)=sum_sgtheta/sum_gtheta
3448 c
3449 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3450 #endif
3451         Eval=Eval-dLOG(gutheta_i/constr_homology)
3452 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3453 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3454 c       Uconst_back=Uconst_back+utheta(i)
3455       enddo ! (i-loop for theta)
3456 #ifdef DEBUG
3457       write(iout,*) "------- theta restrs end -------"
3458 #endif
3459       endif
3460 c
3461 c Deviation of local SC geometry
3462 c
3463 c Separation of two i-loops (instructed by AL - 11/3/2014)
3464 c
3465 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3466 c     write (iout,*) "waga_d",waga_d
3467
3468 #ifdef DEBUG
3469       write(iout,*) "------- SC restrs start -------"
3470       write (iout,*) "Initial duscdiff,duscdiffx"
3471       do i=loc_start,loc_end
3472         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3473      &                 (duscdiffx(jik,i),jik=1,3)
3474       enddo
3475 #endif
3476       do i=loc_start,loc_end
3477         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3478         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3479 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3480 c       write(iout,*) "xxtab, yytab, zztab"
3481 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3482         do k=1,constr_homology
3483 c
3484           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3485 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3486           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3487           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3488 c         write(iout,*) "dxx, dyy, dzz"
3489 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3490 c
3491           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3492 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3493 c         uscdiffk(k)=usc_diff(i)
3494           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3495           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3496 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3497 c     &      xxref(j),yyref(j),zzref(j)
3498         enddo
3499 c
3500 c       Gradient
3501 c
3502 c       Generalized expression for multiple Gaussian acc to that for a single
3503 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3504 c
3505 c       Original implementation
3506 c       sum_guscdiff=guscdiff(i)
3507 c
3508 c       sum_sguscdiff=0.0d0
3509 c       do k=1,constr_homology
3510 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3511 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3512 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3513 c       enddo
3514 c
3515 c       Implementation of new expressions for gradient (Jan. 2015)
3516 c
3517 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3518 #ifdef GRAD
3519         do k=1,constr_homology
3520 c
3521 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3522 c       before. Now the drivatives should be correct
3523 c
3524           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3525 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3526           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3527           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3528 c
3529 c         New implementation
3530 c
3531           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3532      &                 sigma_d(k,i) ! for the grad wrt r'
3533 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3534 c
3535 c
3536 c        New implementation
3537          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3538          do jik=1,3
3539             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3540      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3541      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3542             duscdiff(jik,i)=duscdiff(jik,i)+
3543      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3544      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3545             duscdiffx(jik,i)=duscdiffx(jik,i)+
3546      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3547      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3548 c
3549 #ifdef DEBUG
3550              write(iout,*) "jik",jik,"i",i
3551              write(iout,*) "dxx, dyy, dzz"
3552              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3553              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3554 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3555 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3556 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3557 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3558 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3559 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3560 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3561 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3562 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3563 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3564 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3565 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3566 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3567 c            endif
3568 #endif
3569          enddo
3570         enddo
3571 #endif
3572 c
3573 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3574 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3575 c
3576 c        write (iout,*) i," uscdiff",uscdiff(i)
3577 c
3578 c Put together deviations from local geometry
3579
3580 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3581 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3582         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3583 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3584 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3585 c       Uconst_back=Uconst_back+usc_diff(i)
3586 c
3587 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3588 c
3589 c     New implment: multiplied by sum_sguscdiff
3590 c
3591
3592       enddo ! (i-loop for dscdiff)
3593
3594 c      endif
3595
3596 #ifdef DEBUG
3597       write(iout,*) "------- SC restrs end -------"
3598         write (iout,*) "------ After SC loop in e_modeller ------"
3599         do i=loc_start,loc_end
3600          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3601          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3602         enddo
3603       if (waga_theta.eq.1.0d0) then
3604       write (iout,*) "in e_modeller after SC restr end: dutheta"
3605       do i=ithet_start,ithet_end
3606         write (iout,*) i,dutheta(i)
3607       enddo
3608       endif
3609       if (waga_d.eq.1.0d0) then
3610       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3611       do i=1,nres
3612         write (iout,*) i,(duscdiff(j,i),j=1,3)
3613         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3614       enddo
3615       endif
3616 #endif
3617
3618 c Total energy from homology restraints
3619 #ifdef DEBUG
3620       write (iout,*) "odleg",odleg," kat",kat
3621       write (iout,*) "odleg",odleg," kat",kat
3622       write (iout,*) "Eval",Eval," Erot",Erot
3623       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3624       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3625       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3626       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3627 #endif
3628 c
3629 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3630 c
3631 c     ehomology_constr=odleg+kat
3632 c
3633 c     For Lorentzian-type Urestr
3634 c
3635
3636       if (waga_dist.ge.0.0d0) then
3637 c
3638 c          For Gaussian-type Urestr
3639 c
3640         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3641      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3642 c     write (iout,*) "ehomology_constr=",ehomology_constr
3643       else
3644 c
3645 c          For Lorentzian-type Urestr
3646 c
3647         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3648      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3649 c     write (iout,*) "ehomology_constr=",ehomology_constr
3650       endif
3651 c      write (iout,*) "odleg",odleg," kat",kat," Eval",Eval," Erot",Erot
3652 c     write (iout,*) "ehomology_constr",ehomology_constr
3653 c     ehomology_constr=odleg+kat+Uconst_back
3654       return
3655
3656   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3657   747 format(a12,i4,i4,i4,f8.3,f8.3)
3658   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3659   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3660   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3661      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3662       end
3663 C--------------------------------------------------------------------------
3664       subroutine ebond(estr)
3665 c
3666 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3667 c
3668       implicit real*8 (a-h,o-z)
3669       include 'DIMENSIONS'
3670       include 'COMMON.LOCAL'
3671       include 'COMMON.GEO'
3672       include 'COMMON.INTERACT'
3673       include 'COMMON.DERIV'
3674       include 'COMMON.VAR'
3675       include 'COMMON.CHAIN'
3676       include 'COMMON.IOUNITS'
3677       include 'COMMON.NAMES'
3678       include 'COMMON.FFIELD'
3679       include 'COMMON.CONTROL'
3680       double precision u(3),ud(3)
3681       estr=0.0d0
3682       do i=nnt+1,nct
3683         diff = vbld(i)-vbldp0
3684 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3685         estr=estr+diff*diff
3686         do j=1,3
3687           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3688         enddo
3689       enddo
3690       estr=0.5d0*AKP*estr
3691 c
3692 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3693 c
3694       do i=nnt,nct
3695         iti=itype(i)
3696         if (iti.ne.10) then
3697           nbi=nbondterm(iti)
3698           if (nbi.eq.1) then
3699             diff=vbld(i+nres)-vbldsc0(1,iti)
3700 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3701 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3702             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3703             do j=1,3
3704               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3705             enddo
3706           else
3707             do j=1,nbi
3708               diff=vbld(i+nres)-vbldsc0(j,iti)
3709               ud(j)=aksc(j,iti)*diff
3710               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3711             enddo
3712             uprod=u(1)
3713             do j=2,nbi
3714               uprod=uprod*u(j)
3715             enddo
3716             usum=0.0d0
3717             usumsqder=0.0d0
3718             do j=1,nbi
3719               uprod1=1.0d0
3720               uprod2=1.0d0
3721               do k=1,nbi
3722                 if (k.ne.j) then
3723                   uprod1=uprod1*u(k)
3724                   uprod2=uprod2*u(k)*u(k)
3725                 endif
3726               enddo
3727               usum=usum+uprod1
3728               usumsqder=usumsqder+ud(j)*uprod2
3729             enddo
3730 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3731 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3732             estr=estr+uprod/usum
3733             do j=1,3
3734              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3735             enddo
3736           endif
3737         endif
3738       enddo
3739       return
3740       end
3741 #ifdef CRYST_THETA
3742 C--------------------------------------------------------------------------
3743       subroutine ebend(etheta)
3744 C
3745 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3746 C angles gamma and its derivatives in consecutive thetas and gammas.
3747 C
3748       implicit real*8 (a-h,o-z)
3749       include 'DIMENSIONS'
3750       include 'sizesclu.dat'
3751       include 'COMMON.LOCAL'
3752       include 'COMMON.GEO'
3753       include 'COMMON.INTERACT'
3754       include 'COMMON.DERIV'
3755       include 'COMMON.VAR'
3756       include 'COMMON.CHAIN'
3757       include 'COMMON.IOUNITS'
3758       include 'COMMON.NAMES'
3759       include 'COMMON.FFIELD'
3760       common /calcthet/ term1,term2,termm,diffak,ratak,
3761      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3762      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3763       double precision y(2),z(2)
3764       delta=0.02d0*pi
3765       time11=dexp(-2*time)
3766       time12=1.0d0
3767       etheta=0.0D0
3768 c      write (iout,*) "nres",nres
3769 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3770 c      write (iout,*) ithet_start,ithet_end
3771       do i=ithet_start,ithet_end
3772 C Zero the energy function and its derivative at 0 or pi.
3773         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3774         it=itype(i-1)
3775 c        if (i.gt.ithet_start .and.
3776 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3777 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3778 c          phii=phi(i)
3779 c          y(1)=dcos(phii)
3780 c          y(2)=dsin(phii)
3781 c        else
3782 c          y(1)=0.0D0
3783 c          y(2)=0.0D0
3784 c        endif
3785 c        if (i.lt.nres .and. itel(i).ne.0) then
3786 c          phii1=phi(i+1)
3787 c          z(1)=dcos(phii1)
3788 c          z(2)=dsin(phii1)
3789 c        else
3790 c          z(1)=0.0D0
3791 c          z(2)=0.0D0
3792 c        endif
3793         if (i.gt.3) then
3794 #ifdef OSF
3795           phii=phi(i)
3796           icrc=0
3797           call proc_proc(phii,icrc)
3798           if (icrc.eq.1) phii=150.0
3799 #else
3800           phii=phi(i)
3801 #endif
3802           y(1)=dcos(phii)
3803           y(2)=dsin(phii)
3804         else
3805           y(1)=0.0D0
3806           y(2)=0.0D0
3807         endif
3808         if (i.lt.nres) then
3809 #ifdef OSF
3810           phii1=phi(i+1)
3811           icrc=0
3812           call proc_proc(phii1,icrc)
3813           if (icrc.eq.1) phii1=150.0
3814           phii1=pinorm(phii1)
3815           z(1)=cos(phii1)
3816 #else
3817           phii1=phi(i+1)
3818           z(1)=dcos(phii1)
3819 #endif
3820           z(2)=dsin(phii1)
3821         else
3822           z(1)=0.0D0
3823           z(2)=0.0D0
3824         endif
3825 C Calculate the "mean" value of theta from the part of the distribution
3826 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3827 C In following comments this theta will be referred to as t_c.
3828         thet_pred_mean=0.0d0
3829         do k=1,2
3830           athetk=athet(k,it)
3831           bthetk=bthet(k,it)
3832           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3833         enddo
3834 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3835         dthett=thet_pred_mean*ssd
3836         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3837 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3838 C Derivatives of the "mean" values in gamma1 and gamma2.
3839         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3840         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3841         if (theta(i).gt.pi-delta) then
3842           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3843      &         E_tc0)
3844           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3845           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3846           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3847      &        E_theta)
3848           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3849      &        E_tc)
3850         else if (theta(i).lt.delta) then
3851           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3852           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3853           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3854      &        E_theta)
3855           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3856           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3857      &        E_tc)
3858         else
3859           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3860      &        E_theta,E_tc)
3861         endif
3862         etheta=etheta+ethetai
3863 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3864 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3865         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3866         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3867         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3868  1215   continue
3869       enddo
3870 C Ufff.... We've done all this!!!
3871       return
3872       end
3873 C---------------------------------------------------------------------------
3874       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3875      &     E_tc)
3876       implicit real*8 (a-h,o-z)
3877       include 'DIMENSIONS'
3878       include 'COMMON.LOCAL'
3879       include 'COMMON.IOUNITS'
3880       common /calcthet/ term1,term2,termm,diffak,ratak,
3881      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3882      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3883 C Calculate the contributions to both Gaussian lobes.
3884 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3885 C The "polynomial part" of the "standard deviation" of this part of
3886 C the distribution.
3887         sig=polthet(3,it)
3888         do j=2,0,-1
3889           sig=sig*thet_pred_mean+polthet(j,it)
3890         enddo
3891 C Derivative of the "interior part" of the "standard deviation of the"
3892 C gamma-dependent Gaussian lobe in t_c.
3893         sigtc=3*polthet(3,it)
3894         do j=2,1,-1
3895           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3896         enddo
3897         sigtc=sig*sigtc
3898 C Set the parameters of both Gaussian lobes of the distribution.
3899 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3900         fac=sig*sig+sigc0(it)
3901         sigcsq=fac+fac
3902         sigc=1.0D0/sigcsq
3903 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3904         sigsqtc=-4.0D0*sigcsq*sigtc
3905 c       print *,i,sig,sigtc,sigsqtc
3906 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3907         sigtc=-sigtc/(fac*fac)
3908 C Following variable is sigma(t_c)**(-2)
3909         sigcsq=sigcsq*sigcsq
3910         sig0i=sig0(it)
3911         sig0inv=1.0D0/sig0i**2
3912         delthec=thetai-thet_pred_mean
3913         delthe0=thetai-theta0i
3914         term1=-0.5D0*sigcsq*delthec*delthec
3915         term2=-0.5D0*sig0inv*delthe0*delthe0
3916 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3917 C NaNs in taking the logarithm. We extract the largest exponent which is added
3918 C to the energy (this being the log of the distribution) at the end of energy
3919 C term evaluation for this virtual-bond angle.
3920         if (term1.gt.term2) then
3921           termm=term1
3922           term2=dexp(term2-termm)
3923           term1=1.0d0
3924         else
3925           termm=term2
3926           term1=dexp(term1-termm)
3927           term2=1.0d0
3928         endif
3929 C The ratio between the gamma-independent and gamma-dependent lobes of
3930 C the distribution is a Gaussian function of thet_pred_mean too.
3931         diffak=gthet(2,it)-thet_pred_mean
3932         ratak=diffak/gthet(3,it)**2
3933         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3934 C Let's differentiate it in thet_pred_mean NOW.
3935         aktc=ak*ratak
3936 C Now put together the distribution terms to make complete distribution.
3937         termexp=term1+ak*term2
3938         termpre=sigc+ak*sig0i
3939 C Contribution of the bending energy from this theta is just the -log of
3940 C the sum of the contributions from the two lobes and the pre-exponential
3941 C factor. Simple enough, isn't it?
3942         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3943 C NOW the derivatives!!!
3944 C 6/6/97 Take into account the deformation.
3945         E_theta=(delthec*sigcsq*term1
3946      &       +ak*delthe0*sig0inv*term2)/termexp
3947         E_tc=((sigtc+aktc*sig0i)/termpre
3948      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3949      &       aktc*term2)/termexp)
3950       return
3951       end
3952 c-----------------------------------------------------------------------------
3953       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3954       implicit real*8 (a-h,o-z)
3955       include 'DIMENSIONS'
3956       include 'COMMON.LOCAL'
3957       include 'COMMON.IOUNITS'
3958       common /calcthet/ term1,term2,termm,diffak,ratak,
3959      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3960      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3961       delthec=thetai-thet_pred_mean
3962       delthe0=thetai-theta0i
3963 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3964       t3 = thetai-thet_pred_mean
3965       t6 = t3**2
3966       t9 = term1
3967       t12 = t3*sigcsq
3968       t14 = t12+t6*sigsqtc
3969       t16 = 1.0d0
3970       t21 = thetai-theta0i
3971       t23 = t21**2
3972       t26 = term2
3973       t27 = t21*t26
3974       t32 = termexp
3975       t40 = t32**2
3976       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3977      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3978      & *(-t12*t9-ak*sig0inv*t27)
3979       return
3980       end
3981 #else
3982 C--------------------------------------------------------------------------
3983       subroutine ebend(etheta)
3984 C
3985 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3986 C angles gamma and its derivatives in consecutive thetas and gammas.
3987 C ab initio-derived potentials from
3988 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3989 C
3990       implicit real*8 (a-h,o-z)
3991       include 'DIMENSIONS'
3992       include 'COMMON.LOCAL'
3993       include 'COMMON.GEO'
3994       include 'COMMON.INTERACT'
3995       include 'COMMON.DERIV'
3996       include 'COMMON.VAR'
3997       include 'COMMON.CHAIN'
3998       include 'COMMON.IOUNITS'
3999       include 'COMMON.NAMES'
4000       include 'COMMON.FFIELD'
4001       include 'COMMON.CONTROL'
4002       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4003      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4004      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4005      & sinph1ph2(maxdouble,maxdouble)
4006       logical lprn /.false./, lprn1 /.false./
4007       etheta=0.0D0
4008       do i=ithet_start,ithet_end
4009         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4010      &    (itype(i).eq.ntyp1)) cycle
4011         dethetai=0.0d0
4012         dephii=0.0d0
4013         dephii1=0.0d0
4014         theti2=0.5d0*theta(i)
4015         ityp2=ithetyp(itype(i-1))
4016         do k=1,nntheterm
4017           coskt(k)=dcos(k*theti2)
4018           sinkt(k)=dsin(k*theti2)
4019         enddo
4020         if (i.gt.3  .and. itype(i-3).ne.ntyp1) then
4021 #ifdef OSF
4022           phii=phi(i)
4023           if (phii.ne.phii) phii=150.0
4024 #else
4025           phii=phi(i)
4026 #endif
4027           ityp1=ithetyp(itype(i-2))
4028           do k=1,nsingle
4029             cosph1(k)=dcos(k*phii)
4030             sinph1(k)=dsin(k*phii)
4031           enddo
4032         else
4033           phii=0.0d0
4034           ityp1=ithetyp(itype(i-2))
4035           do k=1,nsingle
4036             cosph1(k)=0.0d0
4037             sinph1(k)=0.0d0
4038           enddo
4039         endif
4040         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4041 #ifdef OSF
4042           phii1=phi(i+1)
4043           if (phii1.ne.phii1) phii1=150.0
4044           phii1=pinorm(phii1)
4045 #else
4046           phii1=phi(i+1)
4047 #endif
4048           ityp3=ithetyp(itype(i))
4049           do k=1,nsingle
4050             cosph2(k)=dcos(k*phii1)
4051             sinph2(k)=dsin(k*phii1)
4052           enddo
4053         else
4054           phii1=0.0d0
4055           ityp3=nthetyp+1
4056           do k=1,nsingle
4057             cosph2(k)=0.0d0
4058             sinph2(k)=0.0d0
4059           enddo
4060         endif
4061 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4062 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4063 c        call flush(iout)
4064         ethetai=aa0thet(ityp1,ityp2,ityp3)
4065         do k=1,ndouble
4066           do l=1,k-1
4067             ccl=cosph1(l)*cosph2(k-l)
4068             ssl=sinph1(l)*sinph2(k-l)
4069             scl=sinph1(l)*cosph2(k-l)
4070             csl=cosph1(l)*sinph2(k-l)
4071             cosph1ph2(l,k)=ccl-ssl
4072             cosph1ph2(k,l)=ccl+ssl
4073             sinph1ph2(l,k)=scl+csl
4074             sinph1ph2(k,l)=scl-csl
4075           enddo
4076         enddo
4077         if (lprn) then
4078         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4079      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4080         write (iout,*) "coskt and sinkt"
4081         do k=1,nntheterm
4082           write (iout,*) k,coskt(k),sinkt(k)
4083         enddo
4084         endif
4085         do k=1,ntheterm
4086           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4087           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4088      &      *coskt(k)
4089           if (lprn)
4090      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4091      &     " ethetai",ethetai
4092         enddo
4093         if (lprn) then
4094         write (iout,*) "cosph and sinph"
4095         do k=1,nsingle
4096           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4097         enddo
4098         write (iout,*) "cosph1ph2 and sinph2ph2"
4099         do k=2,ndouble
4100           do l=1,k-1
4101             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4102      &         sinph1ph2(l,k),sinph1ph2(k,l)
4103           enddo
4104         enddo
4105         write(iout,*) "ethetai",ethetai
4106         endif
4107         do m=1,ntheterm2
4108           do k=1,nsingle
4109             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4110      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4111      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4112      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4113             ethetai=ethetai+sinkt(m)*aux
4114             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4115             dephii=dephii+k*sinkt(m)*(
4116      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4117      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4118             dephii1=dephii1+k*sinkt(m)*(
4119      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4120      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4121             if (lprn)
4122      &      write (iout,*) "m",m," k",k," bbthet",
4123      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4124      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4125      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4126      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4127           enddo
4128         enddo
4129         if (lprn)
4130      &  write(iout,*) "ethetai",ethetai
4131         do m=1,ntheterm3
4132           do k=2,ndouble
4133             do l=1,k-1
4134               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4135      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4136      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4137      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4138               ethetai=ethetai+sinkt(m)*aux
4139               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4140               dephii=dephii+l*sinkt(m)*(
4141      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4142      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4143      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4144      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4145               dephii1=dephii1+(k-l)*sinkt(m)*(
4146      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4147      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4148      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4149      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4150               if (lprn) then
4151               write (iout,*) "m",m," k",k," l",l," ffthet",
4152      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4153      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4154      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4155      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4156               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4157      &            cosph1ph2(k,l)*sinkt(m),
4158      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4159               endif
4160             enddo
4161           enddo
4162         enddo
4163 10      continue
4164 c        lprn1=.true.
4165         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4166      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4167      &   phii1*rad2deg,ethetai
4168 c        lprn1=.false.
4169         etheta=etheta+ethetai
4170
4171         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4172         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4173         gloc(nphi+i-2,icg)=wang*dethetai
4174       enddo
4175       return
4176       end
4177 #endif
4178 #ifdef CRYST_SC
4179 c-----------------------------------------------------------------------------
4180       subroutine esc(escloc)
4181 C Calculate the local energy of a side chain and its derivatives in the
4182 C corresponding virtual-bond valence angles THETA and the spherical angles
4183 C ALPHA and OMEGA.
4184       implicit real*8 (a-h,o-z)
4185       include 'DIMENSIONS'
4186       include 'sizesclu.dat'
4187       include 'COMMON.GEO'
4188       include 'COMMON.LOCAL'
4189       include 'COMMON.VAR'
4190       include 'COMMON.INTERACT'
4191       include 'COMMON.DERIV'
4192       include 'COMMON.CHAIN'
4193       include 'COMMON.IOUNITS'
4194       include 'COMMON.NAMES'
4195       include 'COMMON.FFIELD'
4196       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4197      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4198       common /sccalc/ time11,time12,time112,theti,it,nlobit
4199       delta=0.02d0*pi
4200       escloc=0.0D0
4201 c     write (iout,'(a)') 'ESC'
4202       do i=loc_start,loc_end
4203         it=itype(i)
4204         if (it.eq.10) goto 1
4205         nlobit=nlob(it)
4206 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4207 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4208         theti=theta(i+1)-pipol
4209         x(1)=dtan(theti)
4210         x(2)=alph(i)
4211         x(3)=omeg(i)
4212 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4213
4214         if (x(2).gt.pi-delta) then
4215           xtemp(1)=x(1)
4216           xtemp(2)=pi-delta
4217           xtemp(3)=x(3)
4218           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4219           xtemp(2)=pi
4220           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4221           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4222      &        escloci,dersc(2))
4223           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4224      &        ddersc0(1),dersc(1))
4225           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4226      &        ddersc0(3),dersc(3))
4227           xtemp(2)=pi-delta
4228           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4229           xtemp(2)=pi
4230           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4231           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4232      &            dersc0(2),esclocbi,dersc02)
4233           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4234      &            dersc12,dersc01)
4235           call splinthet(x(2),0.5d0*delta,ss,ssd)
4236           dersc0(1)=dersc01
4237           dersc0(2)=dersc02
4238           dersc0(3)=0.0d0
4239           do k=1,3
4240             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4241           enddo
4242           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4243 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4244 c    &             esclocbi,ss,ssd
4245           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4246 c         escloci=esclocbi
4247 c         write (iout,*) escloci
4248         else if (x(2).lt.delta) then
4249           xtemp(1)=x(1)
4250           xtemp(2)=delta
4251           xtemp(3)=x(3)
4252           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4253           xtemp(2)=0.0d0
4254           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4255           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4256      &        escloci,dersc(2))
4257           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4258      &        ddersc0(1),dersc(1))
4259           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4260      &        ddersc0(3),dersc(3))
4261           xtemp(2)=delta
4262           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4263           xtemp(2)=0.0d0
4264           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4265           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4266      &            dersc0(2),esclocbi,dersc02)
4267           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4268      &            dersc12,dersc01)
4269           dersc0(1)=dersc01
4270           dersc0(2)=dersc02
4271           dersc0(3)=0.0d0
4272           call splinthet(x(2),0.5d0*delta,ss,ssd)
4273           do k=1,3
4274             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4275           enddo
4276           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4277 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4278 c    &             esclocbi,ss,ssd
4279           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4280 c         write (iout,*) escloci
4281         else
4282           call enesc(x,escloci,dersc,ddummy,.false.)
4283         endif
4284
4285         escloc=escloc+escloci
4286 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4287
4288         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4289      &   wscloc*dersc(1)
4290         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4291         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4292     1   continue
4293       enddo
4294       return
4295       end
4296 C---------------------------------------------------------------------------
4297       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4298       implicit real*8 (a-h,o-z)
4299       include 'DIMENSIONS'
4300       include 'COMMON.GEO'
4301       include 'COMMON.LOCAL'
4302       include 'COMMON.IOUNITS'
4303       common /sccalc/ time11,time12,time112,theti,it,nlobit
4304       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4305       double precision contr(maxlob,-1:1)
4306       logical mixed
4307 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4308         escloc_i=0.0D0
4309         do j=1,3
4310           dersc(j)=0.0D0
4311           if (mixed) ddersc(j)=0.0d0
4312         enddo
4313         x3=x(3)
4314
4315 C Because of periodicity of the dependence of the SC energy in omega we have
4316 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4317 C To avoid underflows, first compute & store the exponents.
4318
4319         do iii=-1,1
4320
4321           x(3)=x3+iii*dwapi
4322
4323           do j=1,nlobit
4324             do k=1,3
4325               z(k)=x(k)-censc(k,j,it)
4326             enddo
4327             do k=1,3
4328               Axk=0.0D0
4329               do l=1,3
4330                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4331               enddo
4332               Ax(k,j,iii)=Axk
4333             enddo
4334             expfac=0.0D0
4335             do k=1,3
4336               expfac=expfac+Ax(k,j,iii)*z(k)
4337             enddo
4338             contr(j,iii)=expfac
4339           enddo ! j
4340
4341         enddo ! iii
4342
4343         x(3)=x3
4344 C As in the case of ebend, we want to avoid underflows in exponentiation and
4345 C subsequent NaNs and INFs in energy calculation.
4346 C Find the largest exponent
4347         emin=contr(1,-1)
4348         do iii=-1,1
4349           do j=1,nlobit
4350             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4351           enddo
4352         enddo
4353         emin=0.5D0*emin
4354 cd      print *,'it=',it,' emin=',emin
4355
4356 C Compute the contribution to SC energy and derivatives
4357         do iii=-1,1
4358
4359           do j=1,nlobit
4360             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4361 cd          print *,'j=',j,' expfac=',expfac
4362             escloc_i=escloc_i+expfac
4363             do k=1,3
4364               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4365             enddo
4366             if (mixed) then
4367               do k=1,3,2
4368                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4369      &            +gaussc(k,2,j,it))*expfac
4370               enddo
4371             endif
4372           enddo
4373
4374         enddo ! iii
4375
4376         dersc(1)=dersc(1)/cos(theti)**2
4377         ddersc(1)=ddersc(1)/cos(theti)**2
4378         ddersc(3)=ddersc(3)
4379
4380         escloci=-(dlog(escloc_i)-emin)
4381         do j=1,3
4382           dersc(j)=dersc(j)/escloc_i
4383         enddo
4384         if (mixed) then
4385           do j=1,3,2
4386             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4387           enddo
4388         endif
4389       return
4390       end
4391 C------------------------------------------------------------------------------
4392       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4393       implicit real*8 (a-h,o-z)
4394       include 'DIMENSIONS'
4395       include 'COMMON.GEO'
4396       include 'COMMON.LOCAL'
4397       include 'COMMON.IOUNITS'
4398       common /sccalc/ time11,time12,time112,theti,it,nlobit
4399       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4400       double precision contr(maxlob)
4401       logical mixed
4402
4403       escloc_i=0.0D0
4404
4405       do j=1,3
4406         dersc(j)=0.0D0
4407       enddo
4408
4409       do j=1,nlobit
4410         do k=1,2
4411           z(k)=x(k)-censc(k,j,it)
4412         enddo
4413         z(3)=dwapi
4414         do k=1,3
4415           Axk=0.0D0
4416           do l=1,3
4417             Axk=Axk+gaussc(l,k,j,it)*z(l)
4418           enddo
4419           Ax(k,j)=Axk
4420         enddo
4421         expfac=0.0D0
4422         do k=1,3
4423           expfac=expfac+Ax(k,j)*z(k)
4424         enddo
4425         contr(j)=expfac
4426       enddo ! j
4427
4428 C As in the case of ebend, we want to avoid underflows in exponentiation and
4429 C subsequent NaNs and INFs in energy calculation.
4430 C Find the largest exponent
4431       emin=contr(1)
4432       do j=1,nlobit
4433         if (emin.gt.contr(j)) emin=contr(j)
4434       enddo
4435       emin=0.5D0*emin
4436
4437 C Compute the contribution to SC energy and derivatives
4438
4439       dersc12=0.0d0
4440       do j=1,nlobit
4441         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4442         escloc_i=escloc_i+expfac
4443         do k=1,2
4444           dersc(k)=dersc(k)+Ax(k,j)*expfac
4445         enddo
4446         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4447      &            +gaussc(1,2,j,it))*expfac
4448         dersc(3)=0.0d0
4449       enddo
4450
4451       dersc(1)=dersc(1)/cos(theti)**2
4452       dersc12=dersc12/cos(theti)**2
4453       escloci=-(dlog(escloc_i)-emin)
4454       do j=1,2
4455         dersc(j)=dersc(j)/escloc_i
4456       enddo
4457       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4458       return
4459       end
4460 #else
4461 c----------------------------------------------------------------------------------
4462       subroutine esc(escloc)
4463 C Calculate the local energy of a side chain and its derivatives in the
4464 C corresponding virtual-bond valence angles THETA and the spherical angles
4465 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4466 C added by Urszula Kozlowska. 07/11/2007
4467 C
4468       implicit real*8 (a-h,o-z)
4469       include 'DIMENSIONS'
4470       include 'COMMON.GEO'
4471       include 'COMMON.LOCAL'
4472       include 'COMMON.VAR'
4473       include 'COMMON.SCROT'
4474       include 'COMMON.INTERACT'
4475       include 'COMMON.DERIV'
4476       include 'COMMON.CHAIN'
4477       include 'COMMON.IOUNITS'
4478       include 'COMMON.NAMES'
4479       include 'COMMON.FFIELD'
4480       include 'COMMON.CONTROL'
4481       include 'COMMON.VECTORS'
4482       double precision x_prime(3),y_prime(3),z_prime(3)
4483      &    , sumene,dsc_i,dp2_i,x(65),
4484      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4485      &    de_dxx,de_dyy,de_dzz,de_dt
4486       double precision s1_t,s1_6_t,s2_t,s2_6_t
4487       double precision
4488      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4489      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4490      & dt_dCi(3),dt_dCi1(3)
4491       common /sccalc/ time11,time12,time112,theti,it,nlobit
4492       delta=0.02d0*pi
4493       escloc=0.0D0
4494       do i=loc_start,loc_end
4495         costtab(i+1) =dcos(theta(i+1))
4496         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4497         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4498         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4499         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4500         cosfac=dsqrt(cosfac2)
4501         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4502         sinfac=dsqrt(sinfac2)
4503         it=itype(i)
4504         if (it.eq.10) goto 1
4505 c
4506 C  Compute the axes of tghe local cartesian coordinates system; store in
4507 c   x_prime, y_prime and z_prime
4508 c
4509         do j=1,3
4510           x_prime(j) = 0.00
4511           y_prime(j) = 0.00
4512           z_prime(j) = 0.00
4513         enddo
4514 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4515 C     &   dc_norm(3,i+nres)
4516         do j = 1,3
4517           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4518           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4519         enddo
4520         do j = 1,3
4521           z_prime(j) = -uz(j,i-1)
4522         enddo
4523 c       write (2,*) "i",i
4524 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4525 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4526 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4527 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4528 c      & " xy",scalar(x_prime(1),y_prime(1)),
4529 c      & " xz",scalar(x_prime(1),z_prime(1)),
4530 c      & " yy",scalar(y_prime(1),y_prime(1)),
4531 c      & " yz",scalar(y_prime(1),z_prime(1)),
4532 c      & " zz",scalar(z_prime(1),z_prime(1))
4533 c
4534 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4535 C to local coordinate system. Store in xx, yy, zz.
4536 c
4537         xx=0.0d0
4538         yy=0.0d0
4539         zz=0.0d0
4540         do j = 1,3
4541           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4542           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4543           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4544         enddo
4545
4546         xxtab(i)=xx
4547         yytab(i)=yy
4548         zztab(i)=zz
4549 C
4550 C Compute the energy of the ith side cbain
4551 C
4552 c        write (2,*) "xx",xx," yy",yy," zz",zz
4553         it=itype(i)
4554         do j = 1,65
4555           x(j) = sc_parmin(j,it)
4556         enddo
4557 #ifdef CHECK_COORD
4558 Cc diagnostics - remove later
4559         xx1 = dcos(alph(2))
4560         yy1 = dsin(alph(2))*dcos(omeg(2))
4561         zz1 = -dsin(alph(2))*dsin(omeg(2))
4562         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4563      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4564      &    xx1,yy1,zz1
4565 C,"  --- ", xx_w,yy_w,zz_w
4566 c end diagnostics
4567 #endif
4568         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4569      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4570      &   + x(10)*yy*zz
4571         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4572      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4573      & + x(20)*yy*zz
4574         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4575      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4576      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4577      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4578      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4579      &  +x(40)*xx*yy*zz
4580         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4581      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4582      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4583      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4584      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4585      &  +x(60)*xx*yy*zz
4586         dsc_i   = 0.743d0+x(61)
4587         dp2_i   = 1.9d0+x(62)
4588         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4589      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4590         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4591      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4592         s1=(1+x(63))/(0.1d0 + dscp1)
4593         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4594         s2=(1+x(65))/(0.1d0 + dscp2)
4595         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4596         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4597      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4598 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4599 c     &   sumene4,
4600 c     &   dscp1,dscp2,sumene
4601 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4602         escloc = escloc + sumene
4603 c        write (2,*) "escloc",escloc
4604         if (.not. calc_grad) goto 1
4605 #ifdef DEBUG
4606 C
4607 C This section to check the numerical derivatives of the energy of ith side
4608 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4609 C #define DEBUG in the code to turn it on.
4610 C
4611         write (2,*) "sumene               =",sumene
4612         aincr=1.0d-7
4613         xxsave=xx
4614         xx=xx+aincr
4615         write (2,*) xx,yy,zz
4616         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4617         de_dxx_num=(sumenep-sumene)/aincr
4618         xx=xxsave
4619         write (2,*) "xx+ sumene from enesc=",sumenep
4620         yysave=yy
4621         yy=yy+aincr
4622         write (2,*) xx,yy,zz
4623         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4624         de_dyy_num=(sumenep-sumene)/aincr
4625         yy=yysave
4626         write (2,*) "yy+ sumene from enesc=",sumenep
4627         zzsave=zz
4628         zz=zz+aincr
4629         write (2,*) xx,yy,zz
4630         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4631         de_dzz_num=(sumenep-sumene)/aincr
4632         zz=zzsave
4633         write (2,*) "zz+ sumene from enesc=",sumenep
4634         costsave=cost2tab(i+1)
4635         sintsave=sint2tab(i+1)
4636         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4637         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4638         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4639         de_dt_num=(sumenep-sumene)/aincr
4640         write (2,*) " t+ sumene from enesc=",sumenep
4641         cost2tab(i+1)=costsave
4642         sint2tab(i+1)=sintsave
4643 C End of diagnostics section.
4644 #endif
4645 C
4646 C Compute the gradient of esc
4647 C
4648         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4649         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4650         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4651         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4652         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4653         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4654         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4655         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4656         pom1=(sumene3*sint2tab(i+1)+sumene1)
4657      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4658         pom2=(sumene4*cost2tab(i+1)+sumene2)
4659      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4660         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4661         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4662      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4663      &  +x(40)*yy*zz
4664         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4665         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4666      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4667      &  +x(60)*yy*zz
4668         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4669      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4670      &        +(pom1+pom2)*pom_dx
4671 #ifdef DEBUG
4672         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4673 #endif
4674 C
4675         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4676         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4677      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4678      &  +x(40)*xx*zz
4679         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4680         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4681      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4682      &  +x(59)*zz**2 +x(60)*xx*zz
4683         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4684      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4685      &        +(pom1-pom2)*pom_dy
4686 #ifdef DEBUG
4687         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4688 #endif
4689 C
4690         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4691      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4692      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4693      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4694      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4695      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4696      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4697      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4698 #ifdef DEBUG
4699         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4700 #endif
4701 C
4702         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4703      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4704      &  +pom1*pom_dt1+pom2*pom_dt2
4705 #ifdef DEBUG
4706         write(2,*), "de_dt = ", de_dt,de_dt_num
4707 #endif
4708 c
4709 C
4710        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4711        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4712        cosfac2xx=cosfac2*xx
4713        sinfac2yy=sinfac2*yy
4714        do k = 1,3
4715          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4716      &      vbld_inv(i+1)
4717          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4718      &      vbld_inv(i)
4719          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4720          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4721 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4722 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4723 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4724 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4725          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4726          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4727          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4728          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4729          dZZ_Ci1(k)=0.0d0
4730          dZZ_Ci(k)=0.0d0
4731          do j=1,3
4732            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4733            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4734          enddo
4735
4736          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4737          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4738          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4739 c
4740          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4741          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4742        enddo
4743
4744        do k=1,3
4745          dXX_Ctab(k,i)=dXX_Ci(k)
4746          dXX_C1tab(k,i)=dXX_Ci1(k)
4747          dYY_Ctab(k,i)=dYY_Ci(k)
4748          dYY_C1tab(k,i)=dYY_Ci1(k)
4749          dZZ_Ctab(k,i)=dZZ_Ci(k)
4750          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4751          dXX_XYZtab(k,i)=dXX_XYZ(k)
4752          dYY_XYZtab(k,i)=dYY_XYZ(k)
4753          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4754        enddo
4755
4756        do k = 1,3
4757 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4758 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4759 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4760 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4761 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4762 c     &    dt_dci(k)
4763 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4764 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4765          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4766      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4767          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4768      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4769          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4770      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4771        enddo
4772 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4773 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4774
4775 C to check gradient call subroutine check_grad
4776
4777     1 continue
4778       enddo
4779       return
4780       end
4781 #endif
4782 c------------------------------------------------------------------------------
4783       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4784 C
4785 C This procedure calculates two-body contact function g(rij) and its derivative:
4786 C
4787 C           eps0ij                                     !       x < -1
4788 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4789 C            0                                         !       x > 1
4790 C
4791 C where x=(rij-r0ij)/delta
4792 C
4793 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4794 C
4795       implicit none
4796       double precision rij,r0ij,eps0ij,fcont,fprimcont
4797       double precision x,x2,x4,delta
4798 c     delta=0.02D0*r0ij
4799 c      delta=0.2D0*r0ij
4800       x=(rij-r0ij)/delta
4801       if (x.lt.-1.0D0) then
4802         fcont=eps0ij
4803         fprimcont=0.0D0
4804       else if (x.le.1.0D0) then
4805         x2=x*x
4806         x4=x2*x2
4807         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4808         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4809       else
4810         fcont=0.0D0
4811         fprimcont=0.0D0
4812       endif
4813       return
4814       end
4815 c------------------------------------------------------------------------------
4816       subroutine splinthet(theti,delta,ss,ssder)
4817       implicit real*8 (a-h,o-z)
4818       include 'DIMENSIONS'
4819       include 'sizesclu.dat'
4820       include 'COMMON.VAR'
4821       include 'COMMON.GEO'
4822       thetup=pi-delta
4823       thetlow=delta
4824       if (theti.gt.pipol) then
4825         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4826       else
4827         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4828         ssder=-ssder
4829       endif
4830       return
4831       end
4832 c------------------------------------------------------------------------------
4833       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4834       implicit none
4835       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4836       double precision ksi,ksi2,ksi3,a1,a2,a3
4837       a1=fprim0*delta/(f1-f0)
4838       a2=3.0d0-2.0d0*a1
4839       a3=a1-2.0d0
4840       ksi=(x-x0)/delta
4841       ksi2=ksi*ksi
4842       ksi3=ksi2*ksi
4843       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4844       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4845       return
4846       end
4847 c------------------------------------------------------------------------------
4848       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4849       implicit none
4850       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4851       double precision ksi,ksi2,ksi3,a1,a2,a3
4852       ksi=(x-x0)/delta
4853       ksi2=ksi*ksi
4854       ksi3=ksi2*ksi
4855       a1=fprim0x*delta
4856       a2=3*(f1x-f0x)-2*fprim0x*delta
4857       a3=fprim0x*delta-2*(f1x-f0x)
4858       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4859       return
4860       end
4861 C-----------------------------------------------------------------------------
4862 #ifdef CRYST_TOR
4863 C-----------------------------------------------------------------------------
4864       subroutine etor(etors,edihcnstr,fact)
4865       implicit real*8 (a-h,o-z)
4866       include 'DIMENSIONS'
4867       include 'sizesclu.dat'
4868       include 'COMMON.VAR'
4869       include 'COMMON.GEO'
4870       include 'COMMON.LOCAL'
4871       include 'COMMON.TORSION'
4872       include 'COMMON.INTERACT'
4873       include 'COMMON.DERIV'
4874       include 'COMMON.CHAIN'
4875       include 'COMMON.NAMES'
4876       include 'COMMON.IOUNITS'
4877       include 'COMMON.FFIELD'
4878       include 'COMMON.TORCNSTR'
4879       logical lprn
4880 C Set lprn=.true. for debugging
4881       lprn=.false.
4882 c      lprn=.true.
4883       etors=0.0D0
4884       do i=iphi_start,iphi_end
4885         itori=itortyp(itype(i-2))
4886         itori1=itortyp(itype(i-1))
4887         phii=phi(i)
4888         gloci=0.0D0
4889 C Proline-Proline pair is a special case...
4890         if (itori.eq.3 .and. itori1.eq.3) then
4891           if (phii.gt.-dwapi3) then
4892             cosphi=dcos(3*phii)
4893             fac=1.0D0/(1.0D0-cosphi)
4894             etorsi=v1(1,3,3)*fac
4895             etorsi=etorsi+etorsi
4896             etors=etors+etorsi-v1(1,3,3)
4897             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4898           endif
4899           do j=1,3
4900             v1ij=v1(j+1,itori,itori1)
4901             v2ij=v2(j+1,itori,itori1)
4902             cosphi=dcos(j*phii)
4903             sinphi=dsin(j*phii)
4904             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4905             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4906           enddo
4907         else
4908           do j=1,nterm_old
4909             v1ij=v1(j,itori,itori1)
4910             v2ij=v2(j,itori,itori1)
4911             cosphi=dcos(j*phii)
4912             sinphi=dsin(j*phii)
4913             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4914             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4915           enddo
4916         endif
4917         if (lprn)
4918      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4919      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4920      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4921         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4922 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4923       enddo
4924 ! 6/20/98 - dihedral angle constraints
4925       edihcnstr=0.0d0
4926       do i=1,ndih_constr
4927         itori=idih_constr(i)
4928         phii=phi(itori)
4929         difi=pinorm(phii-phi0(i))
4930         if (difi.gt.drange(i)) then
4931           difi=difi-drange(i)
4932           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4933           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4934         else if (difi.lt.-drange(i)) then
4935           difi=difi+drange(i)
4936           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4937           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4938         endif
4939 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4940 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4941       enddo
4942       write (iout,*) 'edihcnstr',edihcnstr
4943       return
4944       end
4945 c------------------------------------------------------------------------------
4946 #else
4947       subroutine etor(etors,edihcnstr,fact)
4948       implicit real*8 (a-h,o-z)
4949       include 'DIMENSIONS'
4950       include 'sizesclu.dat'
4951       include 'COMMON.VAR'
4952       include 'COMMON.GEO'
4953       include 'COMMON.LOCAL'
4954       include 'COMMON.TORSION'
4955       include 'COMMON.INTERACT'
4956       include 'COMMON.DERIV'
4957       include 'COMMON.CHAIN'
4958       include 'COMMON.NAMES'
4959       include 'COMMON.IOUNITS'
4960       include 'COMMON.FFIELD'
4961       include 'COMMON.TORCNSTR'
4962       logical lprn
4963 C Set lprn=.true. for debugging
4964       lprn=.false.
4965 c      lprn=.true.
4966       etors=0.0D0
4967       do i=iphi_start,iphi_end
4968         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4969         itori=itortyp(itype(i-2))
4970         itori1=itortyp(itype(i-1))
4971         phii=phi(i)
4972         gloci=0.0D0
4973 C Regular cosine and sine terms
4974         do j=1,nterm(itori,itori1)
4975           v1ij=v1(j,itori,itori1)
4976           v2ij=v2(j,itori,itori1)
4977           cosphi=dcos(j*phii)
4978           sinphi=dsin(j*phii)
4979           etors=etors+v1ij*cosphi+v2ij*sinphi
4980           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4981         enddo
4982 C Lorentz terms
4983 C                         v1
4984 C  E = SUM ----------------------------------- - v1
4985 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4986 C
4987         cosphi=dcos(0.5d0*phii)
4988         sinphi=dsin(0.5d0*phii)
4989         do j=1,nlor(itori,itori1)
4990           vl1ij=vlor1(j,itori,itori1)
4991           vl2ij=vlor2(j,itori,itori1)
4992           vl3ij=vlor3(j,itori,itori1)
4993           pom=vl2ij*cosphi+vl3ij*sinphi
4994           pom1=1.0d0/(pom*pom+1.0d0)
4995           etors=etors+vl1ij*pom1
4996           pom=-pom*pom1*pom1
4997           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4998         enddo
4999 C Subtract the constant term
5000         etors=etors-v0(itori,itori1)
5001         if (lprn)
5002      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5003      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5004      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5005         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5006 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5007  1215   continue
5008       enddo
5009 ! 6/20/98 - dihedral angle constraints
5010       edihcnstr=0.0d0
5011 c      write (iout,*) "Dihedral angle restraint energy"
5012       do i=1,ndih_constr
5013         itori=idih_constr(i)
5014         phii=phi(itori)
5015         difi=pinorm(phii-phi0(i))
5016 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5017 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5018         if (difi.gt.drange(i)) then
5019           difi=difi-drange(i)
5020           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5021           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5022 c          write (iout,*) 0.25d0*ftors*difi**4
5023         else if (difi.lt.-drange(i)) then
5024           difi=difi+drange(i)
5025           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5026           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5027 c          write (iout,*) 0.25d0*ftors*difi**4
5028         endif
5029       enddo
5030 c      write (iout,*) 'edihcnstr',edihcnstr
5031       return
5032       end
5033 c----------------------------------------------------------------------------
5034       subroutine etor_d(etors_d,fact2)
5035 C 6/23/01 Compute double torsional energy
5036       implicit real*8 (a-h,o-z)
5037       include 'DIMENSIONS'
5038       include 'sizesclu.dat'
5039       include 'COMMON.VAR'
5040       include 'COMMON.GEO'
5041       include 'COMMON.LOCAL'
5042       include 'COMMON.TORSION'
5043       include 'COMMON.INTERACT'
5044       include 'COMMON.DERIV'
5045       include 'COMMON.CHAIN'
5046       include 'COMMON.NAMES'
5047       include 'COMMON.IOUNITS'
5048       include 'COMMON.FFIELD'
5049       include 'COMMON.TORCNSTR'
5050       logical lprn
5051 C Set lprn=.true. for debugging
5052       lprn=.false.
5053 c     lprn=.true.
5054       etors_d=0.0D0
5055       do i=iphi_start,iphi_end-1
5056         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5057      &     goto 1215
5058         itori=itortyp(itype(i-2))
5059         itori1=itortyp(itype(i-1))
5060         itori2=itortyp(itype(i))
5061         phii=phi(i)
5062         phii1=phi(i+1)
5063         gloci1=0.0D0
5064         gloci2=0.0D0
5065 C Regular cosine and sine terms
5066         do j=1,ntermd_1(itori,itori1,itori2)
5067           v1cij=v1c(1,j,itori,itori1,itori2)
5068           v1sij=v1s(1,j,itori,itori1,itori2)
5069           v2cij=v1c(2,j,itori,itori1,itori2)
5070           v2sij=v1s(2,j,itori,itori1,itori2)
5071           cosphi1=dcos(j*phii)
5072           sinphi1=dsin(j*phii)
5073           cosphi2=dcos(j*phii1)
5074           sinphi2=dsin(j*phii1)
5075           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5076      &     v2cij*cosphi2+v2sij*sinphi2
5077           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5078           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5079         enddo
5080         do k=2,ntermd_2(itori,itori1,itori2)
5081           do l=1,k-1
5082             v1cdij = v2c(k,l,itori,itori1,itori2)
5083             v2cdij = v2c(l,k,itori,itori1,itori2)
5084             v1sdij = v2s(k,l,itori,itori1,itori2)
5085             v2sdij = v2s(l,k,itori,itori1,itori2)
5086             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5087             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5088             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5089             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5090             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5091      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5092             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5093      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5094             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5095      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5096           enddo
5097         enddo
5098         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5099         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5100  1215   continue
5101       enddo
5102       return
5103       end
5104 #endif
5105 c------------------------------------------------------------------------------
5106       subroutine eback_sc_corr(esccor,fact)
5107 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5108 c        conformational states; temporarily implemented as differences
5109 c        between UNRES torsional potentials (dependent on three types of
5110 c        residues) and the torsional potentials dependent on all 20 types
5111 c        of residues computed from AM1 energy surfaces of terminally-blocked
5112 c        amino-acid residues.
5113       implicit real*8 (a-h,o-z)
5114       include 'DIMENSIONS'
5115       include 'COMMON.VAR'
5116       include 'COMMON.GEO'
5117       include 'COMMON.LOCAL'
5118       include 'COMMON.TORSION'
5119       include 'COMMON.SCCOR'
5120       include 'COMMON.INTERACT'
5121       include 'COMMON.DERIV'
5122       include 'COMMON.CHAIN'
5123       include 'COMMON.NAMES'
5124       include 'COMMON.IOUNITS'
5125       include 'COMMON.FFIELD'
5126       include 'COMMON.CONTROL'
5127       logical lprn
5128 C Set lprn=.true. for debugging
5129       lprn=.false.
5130 c      lprn=.true.
5131 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5132       esccor=0.0D0
5133       do i=itau_start,itau_end
5134         esccor_ii=0.0D0
5135         isccori=isccortyp(itype(i-2))
5136         isccori1=isccortyp(itype(i-1))
5137         phii=phi(i)
5138 cccc  Added 9 May 2012
5139 cc Tauangle is torsional engle depending on the value of first digit
5140 c(see comment below)
5141 cc Omicron is flat angle depending on the value of first digit
5142 c(see comment below)
5143
5144
5145         do intertyp=1,3 !intertyp
5146 cc Added 09 May 2012 (Adasko)
5147 cc  Intertyp means interaction type of backbone mainchain correlation:
5148 c   1 = SC...Ca...Ca...Ca
5149 c   2 = Ca...Ca...Ca...SC
5150 c   3 = SC...Ca...Ca...SCi
5151         gloci=0.0D0
5152         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5153      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5154      &      (itype(i-1).eq.21)))
5155      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5156      &     .or.(itype(i-2).eq.21)))
5157      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5158      &      (itype(i-1).eq.21)))) cycle
5159         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5160         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5161      & cycle
5162         do j=1,nterm_sccor(isccori,isccori1)
5163           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5164           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5165           cosphi=dcos(j*tauangle(intertyp,i))
5166           sinphi=dsin(j*tauangle(intertyp,i))
5167           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5168           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5169         enddo
5170         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5171 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5172 c     &gloc_sc(intertyp,i-3,icg)
5173         if (lprn)
5174      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5175      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5176      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5177      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5178         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5179        enddo !intertyp
5180       enddo
5181
5182       return
5183       end
5184 c------------------------------------------------------------------------------
5185       subroutine multibody(ecorr)
5186 C This subroutine calculates multi-body contributions to energy following
5187 C the idea of Skolnick et al. If side chains I and J make a contact and
5188 C at the same time side chains I+1 and J+1 make a contact, an extra
5189 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5190       implicit real*8 (a-h,o-z)
5191       include 'DIMENSIONS'
5192       include 'COMMON.IOUNITS'
5193       include 'COMMON.DERIV'
5194       include 'COMMON.INTERACT'
5195       include 'COMMON.CONTACTS'
5196       double precision gx(3),gx1(3)
5197       logical lprn
5198
5199 C Set lprn=.true. for debugging
5200       lprn=.false.
5201
5202       if (lprn) then
5203         write (iout,'(a)') 'Contact function values:'
5204         do i=nnt,nct-2
5205           write (iout,'(i2,20(1x,i2,f10.5))')
5206      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5207         enddo
5208       endif
5209       ecorr=0.0D0
5210       do i=nnt,nct
5211         do j=1,3
5212           gradcorr(j,i)=0.0D0
5213           gradxorr(j,i)=0.0D0
5214         enddo
5215       enddo
5216       do i=nnt,nct-2
5217
5218         DO ISHIFT = 3,4
5219
5220         i1=i+ishift
5221         num_conti=num_cont(i)
5222         num_conti1=num_cont(i1)
5223         do jj=1,num_conti
5224           j=jcont(jj,i)
5225           do kk=1,num_conti1
5226             j1=jcont(kk,i1)
5227             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5228 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5229 cd   &                   ' ishift=',ishift
5230 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5231 C The system gains extra energy.
5232               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5233             endif   ! j1==j+-ishift
5234           enddo     ! kk
5235         enddo       ! jj
5236
5237         ENDDO ! ISHIFT
5238
5239       enddo         ! i
5240       return
5241       end
5242 c------------------------------------------------------------------------------
5243       double precision function esccorr(i,j,k,l,jj,kk)
5244       implicit real*8 (a-h,o-z)
5245       include 'DIMENSIONS'
5246       include 'COMMON.IOUNITS'
5247       include 'COMMON.DERIV'
5248       include 'COMMON.INTERACT'
5249       include 'COMMON.CONTACTS'
5250       double precision gx(3),gx1(3)
5251       logical lprn
5252       lprn=.false.
5253       eij=facont(jj,i)
5254       ekl=facont(kk,k)
5255 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5256 C Calculate the multi-body contribution to energy.
5257 C Calculate multi-body contributions to the gradient.
5258 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5259 cd   & k,l,(gacont(m,kk,k),m=1,3)
5260       do m=1,3
5261         gx(m) =ekl*gacont(m,jj,i)
5262         gx1(m)=eij*gacont(m,kk,k)
5263         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5264         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5265         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5266         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5267       enddo
5268       do m=i,j-1
5269         do ll=1,3
5270           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5271         enddo
5272       enddo
5273       do m=k,l-1
5274         do ll=1,3
5275           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5276         enddo
5277       enddo
5278       esccorr=-eij*ekl
5279       return
5280       end
5281 c------------------------------------------------------------------------------
5282 #ifdef MPL
5283       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5284       implicit real*8 (a-h,o-z)
5285       include 'DIMENSIONS'
5286       integer dimen1,dimen2,atom,indx
5287       double precision buffer(dimen1,dimen2)
5288       double precision zapas
5289       common /contacts_hb/ zapas(3,20,maxres,7),
5290      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5291      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5292       num_kont=num_cont_hb(atom)
5293       do i=1,num_kont
5294         do k=1,7
5295           do j=1,3
5296             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5297           enddo ! j
5298         enddo ! k
5299         buffer(i,indx+22)=facont_hb(i,atom)
5300         buffer(i,indx+23)=ees0p(i,atom)
5301         buffer(i,indx+24)=ees0m(i,atom)
5302         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5303       enddo ! i
5304       buffer(1,indx+26)=dfloat(num_kont)
5305       return
5306       end
5307 c------------------------------------------------------------------------------
5308       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5309       implicit real*8 (a-h,o-z)
5310       include 'DIMENSIONS'
5311       integer dimen1,dimen2,atom,indx
5312       double precision buffer(dimen1,dimen2)
5313       double precision zapas
5314       common /contacts_hb/ zapas(3,20,maxres,7),
5315      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5316      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5317       num_kont=buffer(1,indx+26)
5318       num_kont_old=num_cont_hb(atom)
5319       num_cont_hb(atom)=num_kont+num_kont_old
5320       do i=1,num_kont
5321         ii=i+num_kont_old
5322         do k=1,7
5323           do j=1,3
5324             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5325           enddo ! j
5326         enddo ! k
5327         facont_hb(ii,atom)=buffer(i,indx+22)
5328         ees0p(ii,atom)=buffer(i,indx+23)
5329         ees0m(ii,atom)=buffer(i,indx+24)
5330         jcont_hb(ii,atom)=buffer(i,indx+25)
5331       enddo ! i
5332       return
5333       end
5334 c------------------------------------------------------------------------------
5335 #endif
5336       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5337 C This subroutine calculates multi-body contributions to hydrogen-bonding
5338       implicit real*8 (a-h,o-z)
5339       include 'DIMENSIONS'
5340       include 'sizesclu.dat'
5341       include 'COMMON.IOUNITS'
5342 #ifdef MPL
5343       include 'COMMON.INFO'
5344 #endif
5345       include 'COMMON.FFIELD'
5346       include 'COMMON.DERIV'
5347       include 'COMMON.INTERACT'
5348       include 'COMMON.CONTACTS'
5349 #ifdef MPL
5350       parameter (max_cont=maxconts)
5351       parameter (max_dim=2*(8*3+2))
5352       parameter (msglen1=max_cont*max_dim*4)
5353       parameter (msglen2=2*msglen1)
5354       integer source,CorrelType,CorrelID,Error
5355       double precision buffer(max_cont,max_dim)
5356 #endif
5357       double precision gx(3),gx1(3)
5358       logical lprn,ldone
5359
5360 C Set lprn=.true. for debugging
5361       lprn=.false.
5362 #ifdef MPL
5363       n_corr=0
5364       n_corr1=0
5365       if (fgProcs.le.1) goto 30
5366       if (lprn) then
5367         write (iout,'(a)') 'Contact function values:'
5368         do i=nnt,nct-2
5369           write (iout,'(2i3,50(1x,i2,f5.2))')
5370      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5371      &    j=1,num_cont_hb(i))
5372         enddo
5373       endif
5374 C Caution! Following code assumes that electrostatic interactions concerning
5375 C a given atom are split among at most two processors!
5376       CorrelType=477
5377       CorrelID=MyID+1
5378       ldone=.false.
5379       do i=1,max_cont
5380         do j=1,max_dim
5381           buffer(i,j)=0.0D0
5382         enddo
5383       enddo
5384       mm=mod(MyRank,2)
5385 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5386       if (mm) 20,20,10
5387    10 continue
5388 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5389       if (MyRank.gt.0) then
5390 C Send correlation contributions to the preceding processor
5391         msglen=msglen1
5392         nn=num_cont_hb(iatel_s)
5393         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5394 cd      write (iout,*) 'The BUFFER array:'
5395 cd      do i=1,nn
5396 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5397 cd      enddo
5398         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5399           msglen=msglen2
5400             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5401 C Clear the contacts of the atom passed to the neighboring processor
5402         nn=num_cont_hb(iatel_s+1)
5403 cd      do i=1,nn
5404 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5405 cd      enddo
5406             num_cont_hb(iatel_s)=0
5407         endif
5408 cd      write (iout,*) 'Processor ',MyID,MyRank,
5409 cd   & ' is sending correlation contribution to processor',MyID-1,
5410 cd   & ' msglen=',msglen
5411 cd      write (*,*) 'Processor ',MyID,MyRank,
5412 cd   & ' is sending correlation contribution to processor',MyID-1,
5413 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5414         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5415 cd      write (iout,*) 'Processor ',MyID,
5416 cd   & ' has sent correlation contribution to processor',MyID-1,
5417 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5418 cd      write (*,*) 'Processor ',MyID,
5419 cd   & ' has sent correlation contribution to processor',MyID-1,
5420 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5421         msglen=msglen1
5422       endif ! (MyRank.gt.0)
5423       if (ldone) goto 30
5424       ldone=.true.
5425    20 continue
5426 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5427       if (MyRank.lt.fgProcs-1) then
5428 C Receive correlation contributions from the next processor
5429         msglen=msglen1
5430         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5431 cd      write (iout,*) 'Processor',MyID,
5432 cd   & ' is receiving correlation contribution from processor',MyID+1,
5433 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5434 cd      write (*,*) 'Processor',MyID,
5435 cd   & ' is receiving correlation contribution from processor',MyID+1,
5436 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5437         nbytes=-1
5438         do while (nbytes.le.0)
5439           call mp_probe(MyID+1,CorrelType,nbytes)
5440         enddo
5441 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5442         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5443 cd      write (iout,*) 'Processor',MyID,
5444 cd   & ' has received correlation contribution from processor',MyID+1,
5445 cd   & ' msglen=',msglen,' nbytes=',nbytes
5446 cd      write (iout,*) 'The received BUFFER array:'
5447 cd      do i=1,max_cont
5448 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5449 cd      enddo
5450         if (msglen.eq.msglen1) then
5451           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5452         else if (msglen.eq.msglen2)  then
5453           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5454           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5455         else
5456           write (iout,*)
5457      & 'ERROR!!!! message length changed while processing correlations.'
5458           write (*,*)
5459      & 'ERROR!!!! message length changed while processing correlations.'
5460           call mp_stopall(Error)
5461         endif ! msglen.eq.msglen1
5462       endif ! MyRank.lt.fgProcs-1
5463       if (ldone) goto 30
5464       ldone=.true.
5465       goto 10
5466    30 continue
5467 #endif
5468       if (lprn) then
5469         write (iout,'(a)') 'Contact function values:'
5470         do i=nnt,nct-2
5471           write (iout,'(2i3,50(1x,i2,f5.2))')
5472      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5473      &    j=1,num_cont_hb(i))
5474         enddo
5475       endif
5476       ecorr=0.0D0
5477 C Remove the loop below after debugging !!!
5478       do i=nnt,nct
5479         do j=1,3
5480           gradcorr(j,i)=0.0D0
5481           gradxorr(j,i)=0.0D0
5482         enddo
5483       enddo
5484 C Calculate the local-electrostatic correlation terms
5485       do i=iatel_s,iatel_e+1
5486         i1=i+1
5487         num_conti=num_cont_hb(i)
5488         num_conti1=num_cont_hb(i+1)
5489         do jj=1,num_conti
5490           j=jcont_hb(jj,i)
5491           do kk=1,num_conti1
5492             j1=jcont_hb(kk,i1)
5493 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5494 c     &         ' jj=',jj,' kk=',kk
5495             if (j1.eq.j+1 .or. j1.eq.j-1) then
5496 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5497 C The system gains extra energy.
5498               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5499               n_corr=n_corr+1
5500             else if (j1.eq.j) then
5501 C Contacts I-J and I-(J+1) occur simultaneously.
5502 C The system loses extra energy.
5503 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5504             endif
5505           enddo ! kk
5506           do kk=1,num_conti
5507             j1=jcont_hb(kk,i)
5508 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5509 c    &         ' jj=',jj,' kk=',kk
5510             if (j1.eq.j+1) then
5511 C Contacts I-J and (I+1)-J occur simultaneously.
5512 C The system loses extra energy.
5513 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5514             endif ! j1==j+1
5515           enddo ! kk
5516         enddo ! jj
5517       enddo ! i
5518       return
5519       end
5520 c------------------------------------------------------------------------------
5521       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5522      &  n_corr1)
5523 C This subroutine calculates multi-body contributions to hydrogen-bonding
5524       implicit real*8 (a-h,o-z)
5525       include 'DIMENSIONS'
5526       include 'sizesclu.dat'
5527       include 'COMMON.IOUNITS'
5528 #ifdef MPL
5529       include 'COMMON.INFO'
5530 #endif
5531       include 'COMMON.FFIELD'
5532       include 'COMMON.DERIV'
5533       include 'COMMON.INTERACT'
5534       include 'COMMON.CONTACTS'
5535 #ifdef MPL
5536       parameter (max_cont=maxconts)
5537       parameter (max_dim=2*(8*3+2))
5538       parameter (msglen1=max_cont*max_dim*4)
5539       parameter (msglen2=2*msglen1)
5540       integer source,CorrelType,CorrelID,Error
5541       double precision buffer(max_cont,max_dim)
5542 #endif
5543       double precision gx(3),gx1(3)
5544       logical lprn,ldone
5545
5546 C Set lprn=.true. for debugging
5547       lprn=.false.
5548       eturn6=0.0d0
5549       ecorr6=0.0d0
5550 #ifdef MPL
5551       n_corr=0
5552       n_corr1=0
5553       if (fgProcs.le.1) goto 30
5554       if (lprn) then
5555         write (iout,'(a)') 'Contact function values:'
5556         do i=nnt,nct-2
5557           write (iout,'(2i3,50(1x,i2,f5.2))')
5558      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5559      &    j=1,num_cont_hb(i))
5560         enddo
5561       endif
5562 C Caution! Following code assumes that electrostatic interactions concerning
5563 C a given atom are split among at most two processors!
5564       CorrelType=477
5565       CorrelID=MyID+1
5566       ldone=.false.
5567       do i=1,max_cont
5568         do j=1,max_dim
5569           buffer(i,j)=0.0D0
5570         enddo
5571       enddo
5572       mm=mod(MyRank,2)
5573 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5574       if (mm) 20,20,10
5575    10 continue
5576 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5577       if (MyRank.gt.0) then
5578 C Send correlation contributions to the preceding processor
5579         msglen=msglen1
5580         nn=num_cont_hb(iatel_s)
5581         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5582 cd      write (iout,*) 'The BUFFER array:'
5583 cd      do i=1,nn
5584 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5585 cd      enddo
5586         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5587           msglen=msglen2
5588             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5589 C Clear the contacts of the atom passed to the neighboring processor
5590         nn=num_cont_hb(iatel_s+1)
5591 cd      do i=1,nn
5592 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5593 cd      enddo
5594             num_cont_hb(iatel_s)=0
5595         endif
5596 cd      write (iout,*) 'Processor ',MyID,MyRank,
5597 cd   & ' is sending correlation contribution to processor',MyID-1,
5598 cd   & ' msglen=',msglen
5599 cd      write (*,*) 'Processor ',MyID,MyRank,
5600 cd   & ' is sending correlation contribution to processor',MyID-1,
5601 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5602         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5603 cd      write (iout,*) 'Processor ',MyID,
5604 cd   & ' has sent correlation contribution to processor',MyID-1,
5605 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5606 cd      write (*,*) 'Processor ',MyID,
5607 cd   & ' has sent correlation contribution to processor',MyID-1,
5608 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5609         msglen=msglen1
5610       endif ! (MyRank.gt.0)
5611       if (ldone) goto 30
5612       ldone=.true.
5613    20 continue
5614 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5615       if (MyRank.lt.fgProcs-1) then
5616 C Receive correlation contributions from the next processor
5617         msglen=msglen1
5618         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5619 cd      write (iout,*) 'Processor',MyID,
5620 cd   & ' is receiving correlation contribution from processor',MyID+1,
5621 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5622 cd      write (*,*) 'Processor',MyID,
5623 cd   & ' is receiving correlation contribution from processor',MyID+1,
5624 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5625         nbytes=-1
5626         do while (nbytes.le.0)
5627           call mp_probe(MyID+1,CorrelType,nbytes)
5628         enddo
5629 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5630         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5631 cd      write (iout,*) 'Processor',MyID,
5632 cd   & ' has received correlation contribution from processor',MyID+1,
5633 cd   & ' msglen=',msglen,' nbytes=',nbytes
5634 cd      write (iout,*) 'The received BUFFER array:'
5635 cd      do i=1,max_cont
5636 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5637 cd      enddo
5638         if (msglen.eq.msglen1) then
5639           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5640         else if (msglen.eq.msglen2)  then
5641           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5642           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5643         else
5644           write (iout,*)
5645      & 'ERROR!!!! message length changed while processing correlations.'
5646           write (*,*)
5647      & 'ERROR!!!! message length changed while processing correlations.'
5648           call mp_stopall(Error)
5649         endif ! msglen.eq.msglen1
5650       endif ! MyRank.lt.fgProcs-1
5651       if (ldone) goto 30
5652       ldone=.true.
5653       goto 10
5654    30 continue
5655 #endif
5656       if (lprn) then
5657         write (iout,'(a)') 'Contact function values:'
5658         do i=nnt,nct-2
5659           write (iout,'(2i3,50(1x,i2,f5.2))')
5660      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5661      &    j=1,num_cont_hb(i))
5662         enddo
5663       endif
5664       ecorr=0.0D0
5665       ecorr5=0.0d0
5666       ecorr6=0.0d0
5667 C Remove the loop below after debugging !!!
5668       do i=nnt,nct
5669         do j=1,3
5670           gradcorr(j,i)=0.0D0
5671           gradxorr(j,i)=0.0D0
5672         enddo
5673       enddo
5674 C Calculate the dipole-dipole interaction energies
5675       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5676       do i=iatel_s,iatel_e+1
5677         num_conti=num_cont_hb(i)
5678         do jj=1,num_conti
5679           j=jcont_hb(jj,i)
5680           call dipole(i,j,jj)
5681         enddo
5682       enddo
5683       endif
5684 C Calculate the local-electrostatic correlation terms
5685       do i=iatel_s,iatel_e+1
5686         i1=i+1
5687         num_conti=num_cont_hb(i)
5688         num_conti1=num_cont_hb(i+1)
5689         do jj=1,num_conti
5690           j=jcont_hb(jj,i)
5691           do kk=1,num_conti1
5692             j1=jcont_hb(kk,i1)
5693 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5694 c     &         ' jj=',jj,' kk=',kk
5695             if (j1.eq.j+1 .or. j1.eq.j-1) then
5696 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5697 C The system gains extra energy.
5698               n_corr=n_corr+1
5699               sqd1=dsqrt(d_cont(jj,i))
5700               sqd2=dsqrt(d_cont(kk,i1))
5701               sred_geom = sqd1*sqd2
5702               IF (sred_geom.lt.cutoff_corr) THEN
5703                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5704      &            ekont,fprimcont)
5705 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5706 c     &         ' jj=',jj,' kk=',kk
5707                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5708                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5709                 do l=1,3
5710                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5711                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5712                 enddo
5713                 n_corr1=n_corr1+1
5714 cd               write (iout,*) 'sred_geom=',sred_geom,
5715 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5716                 call calc_eello(i,j,i+1,j1,jj,kk)
5717                 if (wcorr4.gt.0.0d0)
5718      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5719                 if (wcorr5.gt.0.0d0)
5720      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5721 c                print *,"wcorr5",ecorr5
5722 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5723 cd                write(2,*)'ijkl',i,j,i+1,j1
5724                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5725      &               .or. wturn6.eq.0.0d0))then
5726 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5727 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5728 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5729 c     &            'ecorr6=',ecorr6, wcorr6
5730 cd                write (iout,'(4e15.5)') sred_geom,
5731 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5732 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5733 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5734                 else if (wturn6.gt.0.0d0
5735      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5736 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5737                   eturn6=eturn6+eello_turn6(i,jj,kk)
5738 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5739                 endif
5740               ENDIF
5741 1111          continue
5742             else if (j1.eq.j) then
5743 C Contacts I-J and I-(J+1) occur simultaneously.
5744 C The system loses extra energy.
5745 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5746             endif
5747           enddo ! kk
5748           do kk=1,num_conti
5749             j1=jcont_hb(kk,i)
5750 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5751 c    &         ' jj=',jj,' kk=',kk
5752             if (j1.eq.j+1) then
5753 C Contacts I-J and (I+1)-J occur simultaneously.
5754 C The system loses extra energy.
5755 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5756             endif ! j1==j+1
5757           enddo ! kk
5758         enddo ! jj
5759       enddo ! i
5760       return
5761       end
5762 c------------------------------------------------------------------------------
5763       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5764       implicit real*8 (a-h,o-z)
5765       include 'DIMENSIONS'
5766       include 'COMMON.IOUNITS'
5767       include 'COMMON.DERIV'
5768       include 'COMMON.INTERACT'
5769       include 'COMMON.CONTACTS'
5770       double precision gx(3),gx1(3)
5771       logical lprn
5772       lprn=.false.
5773       eij=facont_hb(jj,i)
5774       ekl=facont_hb(kk,k)
5775       ees0pij=ees0p(jj,i)
5776       ees0pkl=ees0p(kk,k)
5777       ees0mij=ees0m(jj,i)
5778       ees0mkl=ees0m(kk,k)
5779       ekont=eij*ekl
5780       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5781 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5782 C Following 4 lines for diagnostics.
5783 cd    ees0pkl=0.0D0
5784 cd    ees0pij=1.0D0
5785 cd    ees0mkl=0.0D0
5786 cd    ees0mij=1.0D0
5787 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5788 c    &   ' and',k,l
5789 c     write (iout,*)'Contacts have occurred for peptide groups',
5790 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5791 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5792 C Calculate the multi-body contribution to energy.
5793       ecorr=ecorr+ekont*ees
5794       if (calc_grad) then
5795 C Calculate multi-body contributions to the gradient.
5796       do ll=1,3
5797         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5798         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5799      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5800      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5801         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5802      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5803      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5804         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5805         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5806      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5807      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5808         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5809      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5810      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5811       enddo
5812       do m=i+1,j-1
5813         do ll=1,3
5814           gradcorr(ll,m)=gradcorr(ll,m)+
5815      &     ees*ekl*gacont_hbr(ll,jj,i)-
5816      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5817      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5818         enddo
5819       enddo
5820       do m=k+1,l-1
5821         do ll=1,3
5822           gradcorr(ll,m)=gradcorr(ll,m)+
5823      &     ees*eij*gacont_hbr(ll,kk,k)-
5824      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5825      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5826         enddo
5827       enddo
5828       endif
5829       ehbcorr=ekont*ees
5830       return
5831       end
5832 C---------------------------------------------------------------------------
5833       subroutine dipole(i,j,jj)
5834       implicit real*8 (a-h,o-z)
5835       include 'DIMENSIONS'
5836       include 'sizesclu.dat'
5837       include 'COMMON.IOUNITS'
5838       include 'COMMON.CHAIN'
5839       include 'COMMON.FFIELD'
5840       include 'COMMON.DERIV'
5841       include 'COMMON.INTERACT'
5842       include 'COMMON.CONTACTS'
5843       include 'COMMON.TORSION'
5844       include 'COMMON.VAR'
5845       include 'COMMON.GEO'
5846       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5847      &  auxmat(2,2)
5848       iti1 = itortyp(itype(i+1))
5849       if (j.lt.nres-1) then
5850         itj1 = itortyp(itype(j+1))
5851       else
5852         itj1=ntortyp+1
5853       endif
5854       do iii=1,2
5855         dipi(iii,1)=Ub2(iii,i)
5856         dipderi(iii)=Ub2der(iii,i)
5857         dipi(iii,2)=b1(iii,iti1)
5858         dipj(iii,1)=Ub2(iii,j)
5859         dipderj(iii)=Ub2der(iii,j)
5860         dipj(iii,2)=b1(iii,itj1)
5861       enddo
5862       kkk=0
5863       do iii=1,2
5864         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5865         do jjj=1,2
5866           kkk=kkk+1
5867           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5868         enddo
5869       enddo
5870       if (.not.calc_grad) return
5871       do kkk=1,5
5872         do lll=1,3
5873           mmm=0
5874           do iii=1,2
5875             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5876      &        auxvec(1))
5877             do jjj=1,2
5878               mmm=mmm+1
5879               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5880             enddo
5881           enddo
5882         enddo
5883       enddo
5884       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5885       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5886       do iii=1,2
5887         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5888       enddo
5889       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5890       do iii=1,2
5891         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5892       enddo
5893       return
5894       end
5895 C---------------------------------------------------------------------------
5896       subroutine calc_eello(i,j,k,l,jj,kk)
5897 C
5898 C This subroutine computes matrices and vectors needed to calculate
5899 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5900 C
5901       implicit real*8 (a-h,o-z)
5902       include 'DIMENSIONS'
5903       include 'sizesclu.dat'
5904       include 'COMMON.IOUNITS'
5905       include 'COMMON.CHAIN'
5906       include 'COMMON.DERIV'
5907       include 'COMMON.INTERACT'
5908       include 'COMMON.CONTACTS'
5909       include 'COMMON.TORSION'
5910       include 'COMMON.VAR'
5911       include 'COMMON.GEO'
5912       include 'COMMON.FFIELD'
5913       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5914      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5915       logical lprn
5916       common /kutas/ lprn
5917 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5918 cd     & ' jj=',jj,' kk=',kk
5919 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5920       do iii=1,2
5921         do jjj=1,2
5922           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5923           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5924         enddo
5925       enddo
5926       call transpose2(aa1(1,1),aa1t(1,1))
5927       call transpose2(aa2(1,1),aa2t(1,1))
5928       do kkk=1,5
5929         do lll=1,3
5930           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5931      &      aa1tder(1,1,lll,kkk))
5932           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5933      &      aa2tder(1,1,lll,kkk))
5934         enddo
5935       enddo
5936       if (l.eq.j+1) then
5937 C parallel orientation of the two CA-CA-CA frames.
5938         if (i.gt.1) then
5939           iti=itortyp(itype(i))
5940         else
5941           iti=ntortyp+1
5942         endif
5943         itk1=itortyp(itype(k+1))
5944         itj=itortyp(itype(j))
5945         if (l.lt.nres-1) then
5946           itl1=itortyp(itype(l+1))
5947         else
5948           itl1=ntortyp+1
5949         endif
5950 C A1 kernel(j+1) A2T
5951 cd        do iii=1,2
5952 cd          write (iout,'(3f10.5,5x,3f10.5)')
5953 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5954 cd        enddo
5955         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5956      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5957      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5958 C Following matrices are needed only for 6-th order cumulants
5959         IF (wcorr6.gt.0.0d0) THEN
5960         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5961      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5962      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5963         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5964      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5965      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5966      &   ADtEAderx(1,1,1,1,1,1))
5967         lprn=.false.
5968         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5969      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5970      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5971      &   ADtEA1derx(1,1,1,1,1,1))
5972         ENDIF
5973 C End 6-th order cumulants
5974 cd        lprn=.false.
5975 cd        if (lprn) then
5976 cd        write (2,*) 'In calc_eello6'
5977 cd        do iii=1,2
5978 cd          write (2,*) 'iii=',iii
5979 cd          do kkk=1,5
5980 cd            write (2,*) 'kkk=',kkk
5981 cd            do jjj=1,2
5982 cd              write (2,'(3(2f10.5),5x)')
5983 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5984 cd            enddo
5985 cd          enddo
5986 cd        enddo
5987 cd        endif
5988         call transpose2(EUgder(1,1,k),auxmat(1,1))
5989         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5990         call transpose2(EUg(1,1,k),auxmat(1,1))
5991         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5992         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5993         do iii=1,2
5994           do kkk=1,5
5995             do lll=1,3
5996               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5997      &          EAEAderx(1,1,lll,kkk,iii,1))
5998             enddo
5999           enddo
6000         enddo
6001 C A1T kernel(i+1) A2
6002         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6003      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6004      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6005 C Following matrices are needed only for 6-th order cumulants
6006         IF (wcorr6.gt.0.0d0) THEN
6007         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6008      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6009      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6010         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6011      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6012      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6013      &   ADtEAderx(1,1,1,1,1,2))
6014         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6015      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6016      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6017      &   ADtEA1derx(1,1,1,1,1,2))
6018         ENDIF
6019 C End 6-th order cumulants
6020         call transpose2(EUgder(1,1,l),auxmat(1,1))
6021         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6022         call transpose2(EUg(1,1,l),auxmat(1,1))
6023         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6024         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6025         do iii=1,2
6026           do kkk=1,5
6027             do lll=1,3
6028               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6029      &          EAEAderx(1,1,lll,kkk,iii,2))
6030             enddo
6031           enddo
6032         enddo
6033 C AEAb1 and AEAb2
6034 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6035 C They are needed only when the fifth- or the sixth-order cumulants are
6036 C indluded.
6037         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6038         call transpose2(AEA(1,1,1),auxmat(1,1))
6039         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6040         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6041         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6042         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6043         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6044         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6045         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6046         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6047         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6048         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6049         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6050         call transpose2(AEA(1,1,2),auxmat(1,1))
6051         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6052         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6053         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6054         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6055         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6056         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6057         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6058         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6059         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6060         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6061         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6062 C Calculate the Cartesian derivatives of the vectors.
6063         do iii=1,2
6064           do kkk=1,5
6065             do lll=1,3
6066               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6067               call matvec2(auxmat(1,1),b1(1,iti),
6068      &          AEAb1derx(1,lll,kkk,iii,1,1))
6069               call matvec2(auxmat(1,1),Ub2(1,i),
6070      &          AEAb2derx(1,lll,kkk,iii,1,1))
6071               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6072      &          AEAb1derx(1,lll,kkk,iii,2,1))
6073               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6074      &          AEAb2derx(1,lll,kkk,iii,2,1))
6075               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6076               call matvec2(auxmat(1,1),b1(1,itj),
6077      &          AEAb1derx(1,lll,kkk,iii,1,2))
6078               call matvec2(auxmat(1,1),Ub2(1,j),
6079      &          AEAb2derx(1,lll,kkk,iii,1,2))
6080               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6081      &          AEAb1derx(1,lll,kkk,iii,2,2))
6082               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6083      &          AEAb2derx(1,lll,kkk,iii,2,2))
6084             enddo
6085           enddo
6086         enddo
6087         ENDIF
6088 C End vectors
6089       else
6090 C Antiparallel orientation of the two CA-CA-CA frames.
6091         if (i.gt.1) then
6092           iti=itortyp(itype(i))
6093         else
6094           iti=ntortyp+1
6095         endif
6096         itk1=itortyp(itype(k+1))
6097         itl=itortyp(itype(l))
6098         itj=itortyp(itype(j))
6099         if (j.lt.nres-1) then
6100           itj1=itortyp(itype(j+1))
6101         else
6102           itj1=ntortyp+1
6103         endif
6104 C A2 kernel(j-1)T A1T
6105         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6106      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6107      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6108 C Following matrices are needed only for 6-th order cumulants
6109         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6110      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6111         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6112      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6113      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6114         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6115      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6116      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6117      &   ADtEAderx(1,1,1,1,1,1))
6118         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6119      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6120      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6121      &   ADtEA1derx(1,1,1,1,1,1))
6122         ENDIF
6123 C End 6-th order cumulants
6124         call transpose2(EUgder(1,1,k),auxmat(1,1))
6125         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6126         call transpose2(EUg(1,1,k),auxmat(1,1))
6127         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6128         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6129         do iii=1,2
6130           do kkk=1,5
6131             do lll=1,3
6132               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6133      &          EAEAderx(1,1,lll,kkk,iii,1))
6134             enddo
6135           enddo
6136         enddo
6137 C A2T kernel(i+1)T A1
6138         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6139      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6140      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6141 C Following matrices are needed only for 6-th order cumulants
6142         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6143      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6144         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6145      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6146      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6147         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6148      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6149      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6150      &   ADtEAderx(1,1,1,1,1,2))
6151         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6152      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6153      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6154      &   ADtEA1derx(1,1,1,1,1,2))
6155         ENDIF
6156 C End 6-th order cumulants
6157         call transpose2(EUgder(1,1,j),auxmat(1,1))
6158         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6159         call transpose2(EUg(1,1,j),auxmat(1,1))
6160         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6161         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6162         do iii=1,2
6163           do kkk=1,5
6164             do lll=1,3
6165               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6166      &          EAEAderx(1,1,lll,kkk,iii,2))
6167             enddo
6168           enddo
6169         enddo
6170 C AEAb1 and AEAb2
6171 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6172 C They are needed only when the fifth- or the sixth-order cumulants are
6173 C indluded.
6174         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6175      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6176         call transpose2(AEA(1,1,1),auxmat(1,1))
6177         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6178         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6179         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6180         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6181         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6182         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6183         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6184         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6185         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6186         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6187         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6188         call transpose2(AEA(1,1,2),auxmat(1,1))
6189         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6190         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6191         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6192         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6193         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6194         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6195         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6196         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6197         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6198         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6199         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6200 C Calculate the Cartesian derivatives of the vectors.
6201         do iii=1,2
6202           do kkk=1,5
6203             do lll=1,3
6204               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6205               call matvec2(auxmat(1,1),b1(1,iti),
6206      &          AEAb1derx(1,lll,kkk,iii,1,1))
6207               call matvec2(auxmat(1,1),Ub2(1,i),
6208      &          AEAb2derx(1,lll,kkk,iii,1,1))
6209               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6210      &          AEAb1derx(1,lll,kkk,iii,2,1))
6211               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6212      &          AEAb2derx(1,lll,kkk,iii,2,1))
6213               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6214               call matvec2(auxmat(1,1),b1(1,itl),
6215      &          AEAb1derx(1,lll,kkk,iii,1,2))
6216               call matvec2(auxmat(1,1),Ub2(1,l),
6217      &          AEAb2derx(1,lll,kkk,iii,1,2))
6218               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6219      &          AEAb1derx(1,lll,kkk,iii,2,2))
6220               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6221      &          AEAb2derx(1,lll,kkk,iii,2,2))
6222             enddo
6223           enddo
6224         enddo
6225         ENDIF
6226 C End vectors
6227       endif
6228       return
6229       end
6230 C---------------------------------------------------------------------------
6231       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6232      &  KK,KKderg,AKA,AKAderg,AKAderx)
6233       implicit none
6234       integer nderg
6235       logical transp
6236       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6237      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6238      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6239       integer iii,kkk,lll
6240       integer jjj,mmm
6241       logical lprn
6242       common /kutas/ lprn
6243       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6244       do iii=1,nderg
6245         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6246      &    AKAderg(1,1,iii))
6247       enddo
6248 cd      if (lprn) write (2,*) 'In kernel'
6249       do kkk=1,5
6250 cd        if (lprn) write (2,*) 'kkk=',kkk
6251         do lll=1,3
6252           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6253      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6254 cd          if (lprn) then
6255 cd            write (2,*) 'lll=',lll
6256 cd            write (2,*) 'iii=1'
6257 cd            do jjj=1,2
6258 cd              write (2,'(3(2f10.5),5x)')
6259 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6260 cd            enddo
6261 cd          endif
6262           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6263      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6264 cd          if (lprn) then
6265 cd            write (2,*) 'lll=',lll
6266 cd            write (2,*) 'iii=2'
6267 cd            do jjj=1,2
6268 cd              write (2,'(3(2f10.5),5x)')
6269 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6270 cd            enddo
6271 cd          endif
6272         enddo
6273       enddo
6274       return
6275       end
6276 C---------------------------------------------------------------------------
6277       double precision function eello4(i,j,k,l,jj,kk)
6278       implicit real*8 (a-h,o-z)
6279       include 'DIMENSIONS'
6280       include 'sizesclu.dat'
6281       include 'COMMON.IOUNITS'
6282       include 'COMMON.CHAIN'
6283       include 'COMMON.DERIV'
6284       include 'COMMON.INTERACT'
6285       include 'COMMON.CONTACTS'
6286       include 'COMMON.TORSION'
6287       include 'COMMON.VAR'
6288       include 'COMMON.GEO'
6289       double precision pizda(2,2),ggg1(3),ggg2(3)
6290 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6291 cd        eello4=0.0d0
6292 cd        return
6293 cd      endif
6294 cd      print *,'eello4:',i,j,k,l,jj,kk
6295 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6296 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6297 cold      eij=facont_hb(jj,i)
6298 cold      ekl=facont_hb(kk,k)
6299 cold      ekont=eij*ekl
6300       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6301       if (calc_grad) then
6302 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6303       gcorr_loc(k-1)=gcorr_loc(k-1)
6304      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6305       if (l.eq.j+1) then
6306         gcorr_loc(l-1)=gcorr_loc(l-1)
6307      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6308       else
6309         gcorr_loc(j-1)=gcorr_loc(j-1)
6310      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6311       endif
6312       do iii=1,2
6313         do kkk=1,5
6314           do lll=1,3
6315             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6316      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6317 cd            derx(lll,kkk,iii)=0.0d0
6318           enddo
6319         enddo
6320       enddo
6321 cd      gcorr_loc(l-1)=0.0d0
6322 cd      gcorr_loc(j-1)=0.0d0
6323 cd      gcorr_loc(k-1)=0.0d0
6324 cd      eel4=1.0d0
6325 cd      write (iout,*)'Contacts have occurred for peptide groups',
6326 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6327 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6328       if (j.lt.nres-1) then
6329         j1=j+1
6330         j2=j-1
6331       else
6332         j1=j-1
6333         j2=j-2
6334       endif
6335       if (l.lt.nres-1) then
6336         l1=l+1
6337         l2=l-1
6338       else
6339         l1=l-1
6340         l2=l-2
6341       endif
6342       do ll=1,3
6343 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6344         ggg1(ll)=eel4*g_contij(ll,1)
6345         ggg2(ll)=eel4*g_contij(ll,2)
6346         ghalf=0.5d0*ggg1(ll)
6347 cd        ghalf=0.0d0
6348         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6349         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6350         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6351         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6352 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6353         ghalf=0.5d0*ggg2(ll)
6354 cd        ghalf=0.0d0
6355         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6356         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6357         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6358         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6359       enddo
6360 cd      goto 1112
6361       do m=i+1,j-1
6362         do ll=1,3
6363 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6364           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6365         enddo
6366       enddo
6367       do m=k+1,l-1
6368         do ll=1,3
6369 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6370           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6371         enddo
6372       enddo
6373 1112  continue
6374       do m=i+2,j2
6375         do ll=1,3
6376           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6377         enddo
6378       enddo
6379       do m=k+2,l2
6380         do ll=1,3
6381           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6382         enddo
6383       enddo
6384 cd      do iii=1,nres-3
6385 cd        write (2,*) iii,gcorr_loc(iii)
6386 cd      enddo
6387       endif
6388       eello4=ekont*eel4
6389 cd      write (2,*) 'ekont',ekont
6390 cd      write (iout,*) 'eello4',ekont*eel4
6391       return
6392       end
6393 C---------------------------------------------------------------------------
6394       double precision function eello5(i,j,k,l,jj,kk)
6395       implicit real*8 (a-h,o-z)
6396       include 'DIMENSIONS'
6397       include 'sizesclu.dat'
6398       include 'COMMON.IOUNITS'
6399       include 'COMMON.CHAIN'
6400       include 'COMMON.DERIV'
6401       include 'COMMON.INTERACT'
6402       include 'COMMON.CONTACTS'
6403       include 'COMMON.TORSION'
6404       include 'COMMON.VAR'
6405       include 'COMMON.GEO'
6406       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6407       double precision ggg1(3),ggg2(3)
6408 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6409 C                                                                              C
6410 C                            Parallel chains                                   C
6411 C                                                                              C
6412 C          o             o                   o             o                   C
6413 C         /l\           / \             \   / \           / \   /              C
6414 C        /   \         /   \             \ /   \         /   \ /               C
6415 C       j| o |l1       | o |              o| o |         | o |o                C
6416 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6417 C      \i/   \         /   \ /             /   \         /   \                 C
6418 C       o    k1             o                                                  C
6419 C         (I)          (II)                (III)          (IV)                 C
6420 C                                                                              C
6421 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6422 C                                                                              C
6423 C                            Antiparallel chains                               C
6424 C                                                                              C
6425 C          o             o                   o             o                   C
6426 C         /j\           / \             \   / \           / \   /              C
6427 C        /   \         /   \             \ /   \         /   \ /               C
6428 C      j1| o |l        | o |              o| o |         | o |o                C
6429 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6430 C      \i/   \         /   \ /             /   \         /   \                 C
6431 C       o     k1            o                                                  C
6432 C         (I)          (II)                (III)          (IV)                 C
6433 C                                                                              C
6434 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6435 C                                                                              C
6436 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6437 C                                                                              C
6438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6439 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6440 cd        eello5=0.0d0
6441 cd        return
6442 cd      endif
6443 cd      write (iout,*)
6444 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6445 cd     &   ' and',k,l
6446       itk=itortyp(itype(k))
6447       itl=itortyp(itype(l))
6448       itj=itortyp(itype(j))
6449       eello5_1=0.0d0
6450       eello5_2=0.0d0
6451       eello5_3=0.0d0
6452       eello5_4=0.0d0
6453 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6454 cd     &   eel5_3_num,eel5_4_num)
6455       do iii=1,2
6456         do kkk=1,5
6457           do lll=1,3
6458             derx(lll,kkk,iii)=0.0d0
6459           enddo
6460         enddo
6461       enddo
6462 cd      eij=facont_hb(jj,i)
6463 cd      ekl=facont_hb(kk,k)
6464 cd      ekont=eij*ekl
6465 cd      write (iout,*)'Contacts have occurred for peptide groups',
6466 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6467 cd      goto 1111
6468 C Contribution from the graph I.
6469 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6470 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6471       call transpose2(EUg(1,1,k),auxmat(1,1))
6472       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6473       vv(1)=pizda(1,1)-pizda(2,2)
6474       vv(2)=pizda(1,2)+pizda(2,1)
6475       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6476      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6477       if (calc_grad) then
6478 C Explicit gradient in virtual-dihedral angles.
6479       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6480      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6481      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6482       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6483       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6484       vv(1)=pizda(1,1)-pizda(2,2)
6485       vv(2)=pizda(1,2)+pizda(2,1)
6486       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6487      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6488      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6489       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6490       vv(1)=pizda(1,1)-pizda(2,2)
6491       vv(2)=pizda(1,2)+pizda(2,1)
6492       if (l.eq.j+1) then
6493         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6494      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6495      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6496       else
6497         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6498      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6499      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6500       endif
6501 C Cartesian gradient
6502       do iii=1,2
6503         do kkk=1,5
6504           do lll=1,3
6505             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6506      &        pizda(1,1))
6507             vv(1)=pizda(1,1)-pizda(2,2)
6508             vv(2)=pizda(1,2)+pizda(2,1)
6509             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6510      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6511      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6512           enddo
6513         enddo
6514       enddo
6515 c      goto 1112
6516       endif
6517 c1111  continue
6518 C Contribution from graph II
6519       call transpose2(EE(1,1,itk),auxmat(1,1))
6520       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6521       vv(1)=pizda(1,1)+pizda(2,2)
6522       vv(2)=pizda(2,1)-pizda(1,2)
6523       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6524      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6525       if (calc_grad) then
6526 C Explicit gradient in virtual-dihedral angles.
6527       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6528      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6529       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6530       vv(1)=pizda(1,1)+pizda(2,2)
6531       vv(2)=pizda(2,1)-pizda(1,2)
6532       if (l.eq.j+1) then
6533         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6534      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6535      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6536       else
6537         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6538      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6539      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6540       endif
6541 C Cartesian gradient
6542       do iii=1,2
6543         do kkk=1,5
6544           do lll=1,3
6545             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6546      &        pizda(1,1))
6547             vv(1)=pizda(1,1)+pizda(2,2)
6548             vv(2)=pizda(2,1)-pizda(1,2)
6549             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6550      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6551      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6552           enddo
6553         enddo
6554       enddo
6555 cd      goto 1112
6556       endif
6557 cd1111  continue
6558       if (l.eq.j+1) then
6559 cd        goto 1110
6560 C Parallel orientation
6561 C Contribution from graph III
6562         call transpose2(EUg(1,1,l),auxmat(1,1))
6563         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6564         vv(1)=pizda(1,1)-pizda(2,2)
6565         vv(2)=pizda(1,2)+pizda(2,1)
6566         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6567      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6568         if (calc_grad) then
6569 C Explicit gradient in virtual-dihedral angles.
6570         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6571      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6572      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6573         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6574         vv(1)=pizda(1,1)-pizda(2,2)
6575         vv(2)=pizda(1,2)+pizda(2,1)
6576         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6577      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6578      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6579         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6580         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6581         vv(1)=pizda(1,1)-pizda(2,2)
6582         vv(2)=pizda(1,2)+pizda(2,1)
6583         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6584      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6585      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6586 C Cartesian gradient
6587         do iii=1,2
6588           do kkk=1,5
6589             do lll=1,3
6590               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6591      &          pizda(1,1))
6592               vv(1)=pizda(1,1)-pizda(2,2)
6593               vv(2)=pizda(1,2)+pizda(2,1)
6594               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6595      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6596      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6597             enddo
6598           enddo
6599         enddo
6600 cd        goto 1112
6601         endif
6602 C Contribution from graph IV
6603 cd1110    continue
6604         call transpose2(EE(1,1,itl),auxmat(1,1))
6605         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6606         vv(1)=pizda(1,1)+pizda(2,2)
6607         vv(2)=pizda(2,1)-pizda(1,2)
6608         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6609      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6610         if (calc_grad) then
6611 C Explicit gradient in virtual-dihedral angles.
6612         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6613      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6614         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6615         vv(1)=pizda(1,1)+pizda(2,2)
6616         vv(2)=pizda(2,1)-pizda(1,2)
6617         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6618      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6619      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6620 C Cartesian gradient
6621         do iii=1,2
6622           do kkk=1,5
6623             do lll=1,3
6624               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6625      &          pizda(1,1))
6626               vv(1)=pizda(1,1)+pizda(2,2)
6627               vv(2)=pizda(2,1)-pizda(1,2)
6628               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6629      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6630      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6631             enddo
6632           enddo
6633         enddo
6634         endif
6635       else
6636 C Antiparallel orientation
6637 C Contribution from graph III
6638 c        goto 1110
6639         call transpose2(EUg(1,1,j),auxmat(1,1))
6640         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6641         vv(1)=pizda(1,1)-pizda(2,2)
6642         vv(2)=pizda(1,2)+pizda(2,1)
6643         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6644      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6645         if (calc_grad) then
6646 C Explicit gradient in virtual-dihedral angles.
6647         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6648      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6649      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6650         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6651         vv(1)=pizda(1,1)-pizda(2,2)
6652         vv(2)=pizda(1,2)+pizda(2,1)
6653         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6654      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6655      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6656         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6657         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6658         vv(1)=pizda(1,1)-pizda(2,2)
6659         vv(2)=pizda(1,2)+pizda(2,1)
6660         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6661      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6662      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6663 C Cartesian gradient
6664         do iii=1,2
6665           do kkk=1,5
6666             do lll=1,3
6667               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6668      &          pizda(1,1))
6669               vv(1)=pizda(1,1)-pizda(2,2)
6670               vv(2)=pizda(1,2)+pizda(2,1)
6671               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6672      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6673      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6674             enddo
6675           enddo
6676         enddo
6677 cd        goto 1112
6678         endif
6679 C Contribution from graph IV
6680 1110    continue
6681         call transpose2(EE(1,1,itj),auxmat(1,1))
6682         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6683         vv(1)=pizda(1,1)+pizda(2,2)
6684         vv(2)=pizda(2,1)-pizda(1,2)
6685         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6686      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6687         if (calc_grad) then
6688 C Explicit gradient in virtual-dihedral angles.
6689         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6690      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6691         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6692         vv(1)=pizda(1,1)+pizda(2,2)
6693         vv(2)=pizda(2,1)-pizda(1,2)
6694         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6695      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6696      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6697 C Cartesian gradient
6698         do iii=1,2
6699           do kkk=1,5
6700             do lll=1,3
6701               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6702      &          pizda(1,1))
6703               vv(1)=pizda(1,1)+pizda(2,2)
6704               vv(2)=pizda(2,1)-pizda(1,2)
6705               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6706      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6707      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6708             enddo
6709           enddo
6710         enddo
6711       endif
6712       endif
6713 1112  continue
6714       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6715 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6716 cd        write (2,*) 'ijkl',i,j,k,l
6717 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6718 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6719 cd      endif
6720 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6721 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6722 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6723 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6724       if (calc_grad) then
6725       if (j.lt.nres-1) then
6726         j1=j+1
6727         j2=j-1
6728       else
6729         j1=j-1
6730         j2=j-2
6731       endif
6732       if (l.lt.nres-1) then
6733         l1=l+1
6734         l2=l-1
6735       else
6736         l1=l-1
6737         l2=l-2
6738       endif
6739 cd      eij=1.0d0
6740 cd      ekl=1.0d0
6741 cd      ekont=1.0d0
6742 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6743       do ll=1,3
6744         ggg1(ll)=eel5*g_contij(ll,1)
6745         ggg2(ll)=eel5*g_contij(ll,2)
6746 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6747         ghalf=0.5d0*ggg1(ll)
6748 cd        ghalf=0.0d0
6749         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6750         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6751         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6752         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6753 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6754         ghalf=0.5d0*ggg2(ll)
6755 cd        ghalf=0.0d0
6756         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6757         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6758         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6759         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6760       enddo
6761 cd      goto 1112
6762       do m=i+1,j-1
6763         do ll=1,3
6764 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6765           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6766         enddo
6767       enddo
6768       do m=k+1,l-1
6769         do ll=1,3
6770 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6771           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6772         enddo
6773       enddo
6774 c1112  continue
6775       do m=i+2,j2
6776         do ll=1,3
6777           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6778         enddo
6779       enddo
6780       do m=k+2,l2
6781         do ll=1,3
6782           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6783         enddo
6784       enddo
6785 cd      do iii=1,nres-3
6786 cd        write (2,*) iii,g_corr5_loc(iii)
6787 cd      enddo
6788       endif
6789       eello5=ekont*eel5
6790 cd      write (2,*) 'ekont',ekont
6791 cd      write (iout,*) 'eello5',ekont*eel5
6792       return
6793       end
6794 c--------------------------------------------------------------------------
6795       double precision function eello6(i,j,k,l,jj,kk)
6796       implicit real*8 (a-h,o-z)
6797       include 'DIMENSIONS'
6798       include 'sizesclu.dat'
6799       include 'COMMON.IOUNITS'
6800       include 'COMMON.CHAIN'
6801       include 'COMMON.DERIV'
6802       include 'COMMON.INTERACT'
6803       include 'COMMON.CONTACTS'
6804       include 'COMMON.TORSION'
6805       include 'COMMON.VAR'
6806       include 'COMMON.GEO'
6807       include 'COMMON.FFIELD'
6808       double precision ggg1(3),ggg2(3)
6809 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6810 cd        eello6=0.0d0
6811 cd        return
6812 cd      endif
6813 cd      write (iout,*)
6814 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6815 cd     &   ' and',k,l
6816       eello6_1=0.0d0
6817       eello6_2=0.0d0
6818       eello6_3=0.0d0
6819       eello6_4=0.0d0
6820       eello6_5=0.0d0
6821       eello6_6=0.0d0
6822 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6823 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6824       do iii=1,2
6825         do kkk=1,5
6826           do lll=1,3
6827             derx(lll,kkk,iii)=0.0d0
6828           enddo
6829         enddo
6830       enddo
6831 cd      eij=facont_hb(jj,i)
6832 cd      ekl=facont_hb(kk,k)
6833 cd      ekont=eij*ekl
6834 cd      eij=1.0d0
6835 cd      ekl=1.0d0
6836 cd      ekont=1.0d0
6837       if (l.eq.j+1) then
6838         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6839         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6840         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6841         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6842         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6843         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6844       else
6845         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6846         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6847         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6848         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6849         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6850           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6851         else
6852           eello6_5=0.0d0
6853         endif
6854         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6855       endif
6856 C If turn contributions are considered, they will be handled separately.
6857       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6858 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6859 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6860 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6861 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6862 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6863 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6864 cd      goto 1112
6865       if (calc_grad) then
6866       if (j.lt.nres-1) then
6867         j1=j+1
6868         j2=j-1
6869       else
6870         j1=j-1
6871         j2=j-2
6872       endif
6873       if (l.lt.nres-1) then
6874         l1=l+1
6875         l2=l-1
6876       else
6877         l1=l-1
6878         l2=l-2
6879       endif
6880       do ll=1,3
6881         ggg1(ll)=eel6*g_contij(ll,1)
6882         ggg2(ll)=eel6*g_contij(ll,2)
6883 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6884         ghalf=0.5d0*ggg1(ll)
6885 cd        ghalf=0.0d0
6886         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6887         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6888         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6889         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6890         ghalf=0.5d0*ggg2(ll)
6891 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6892 cd        ghalf=0.0d0
6893         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6894         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6895         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6896         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6897       enddo
6898 cd      goto 1112
6899       do m=i+1,j-1
6900         do ll=1,3
6901 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6902           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6903         enddo
6904       enddo
6905       do m=k+1,l-1
6906         do ll=1,3
6907 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6908           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6909         enddo
6910       enddo
6911 1112  continue
6912       do m=i+2,j2
6913         do ll=1,3
6914           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6915         enddo
6916       enddo
6917       do m=k+2,l2
6918         do ll=1,3
6919           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6920         enddo
6921       enddo
6922 cd      do iii=1,nres-3
6923 cd        write (2,*) iii,g_corr6_loc(iii)
6924 cd      enddo
6925       endif
6926       eello6=ekont*eel6
6927 cd      write (2,*) 'ekont',ekont
6928 cd      write (iout,*) 'eello6',ekont*eel6
6929       return
6930       end
6931 c--------------------------------------------------------------------------
6932       double precision function eello6_graph1(i,j,k,l,imat,swap)
6933       implicit real*8 (a-h,o-z)
6934       include 'DIMENSIONS'
6935       include 'sizesclu.dat'
6936       include 'COMMON.IOUNITS'
6937       include 'COMMON.CHAIN'
6938       include 'COMMON.DERIV'
6939       include 'COMMON.INTERACT'
6940       include 'COMMON.CONTACTS'
6941       include 'COMMON.TORSION'
6942       include 'COMMON.VAR'
6943       include 'COMMON.GEO'
6944       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6945       logical swap
6946       logical lprn
6947       common /kutas/ lprn
6948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6949 C                                                                              C
6950 C      Parallel       Antiparallel                                             C
6951 C                                                                              C
6952 C          o             o                                                     C
6953 C         /l\           /j\                                                    C
6954 C        /   \         /   \                                                   C
6955 C       /| o |         | o |\                                                  C
6956 C     \ j|/k\|  /   \  |/k\|l /                                                C
6957 C      \ /   \ /     \ /   \ /                                                 C
6958 C       o     o       o     o                                                  C
6959 C       i             i                                                        C
6960 C                                                                              C
6961 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6962       itk=itortyp(itype(k))
6963       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6964       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6965       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6966       call transpose2(EUgC(1,1,k),auxmat(1,1))
6967       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6968       vv1(1)=pizda1(1,1)-pizda1(2,2)
6969       vv1(2)=pizda1(1,2)+pizda1(2,1)
6970       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6971       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6972       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6973       s5=scalar2(vv(1),Dtobr2(1,i))
6974 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6975       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6976       if (.not. calc_grad) return
6977       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6978      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6979      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6980      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6981      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6982      & +scalar2(vv(1),Dtobr2der(1,i)))
6983       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6984       vv1(1)=pizda1(1,1)-pizda1(2,2)
6985       vv1(2)=pizda1(1,2)+pizda1(2,1)
6986       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6987       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6988       if (l.eq.j+1) then
6989         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6990      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6991      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6992      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6993      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6994       else
6995         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6996      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6997      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6998      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6999      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7000       endif
7001       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7002       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7003       vv1(1)=pizda1(1,1)-pizda1(2,2)
7004       vv1(2)=pizda1(1,2)+pizda1(2,1)
7005       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7006      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7007      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7008      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7009       do iii=1,2
7010         if (swap) then
7011           ind=3-iii
7012         else
7013           ind=iii
7014         endif
7015         do kkk=1,5
7016           do lll=1,3
7017             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7018             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7019             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7020             call transpose2(EUgC(1,1,k),auxmat(1,1))
7021             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7022      &        pizda1(1,1))
7023             vv1(1)=pizda1(1,1)-pizda1(2,2)
7024             vv1(2)=pizda1(1,2)+pizda1(2,1)
7025             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7026             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7027      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7028             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7029      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7030             s5=scalar2(vv(1),Dtobr2(1,i))
7031             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7032           enddo
7033         enddo
7034       enddo
7035       return
7036       end
7037 c----------------------------------------------------------------------------
7038       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7039       implicit real*8 (a-h,o-z)
7040       include 'DIMENSIONS'
7041       include 'sizesclu.dat'
7042       include 'COMMON.IOUNITS'
7043       include 'COMMON.CHAIN'
7044       include 'COMMON.DERIV'
7045       include 'COMMON.INTERACT'
7046       include 'COMMON.CONTACTS'
7047       include 'COMMON.TORSION'
7048       include 'COMMON.VAR'
7049       include 'COMMON.GEO'
7050       logical swap
7051       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7052      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7053       logical lprn
7054       common /kutas/ lprn
7055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7056 C                                                                              C
7057 C      Parallel       Antiparallel                                             C
7058 C                                                                              C
7059 C          o             o                                                     C
7060 C     \   /l\           /j\   /                                                C
7061 C      \ /   \         /   \ /                                                 C
7062 C       o| o |         | o |o                                                  C
7063 C     \ j|/k\|      \  |/k\|l                                                  C
7064 C      \ /   \       \ /   \                                                   C
7065 C       o             o                                                        C
7066 C       i             i                                                        C
7067 C                                                                              C
7068 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7069 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7070 C AL 7/4/01 s1 would occur in the sixth-order moment,
7071 C           but not in a cluster cumulant
7072 #ifdef MOMENT
7073       s1=dip(1,jj,i)*dip(1,kk,k)
7074 #endif
7075       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7076       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7077       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7078       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7079       call transpose2(EUg(1,1,k),auxmat(1,1))
7080       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7081       vv(1)=pizda(1,1)-pizda(2,2)
7082       vv(2)=pizda(1,2)+pizda(2,1)
7083       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7084 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7085 #ifdef MOMENT
7086       eello6_graph2=-(s1+s2+s3+s4)
7087 #else
7088       eello6_graph2=-(s2+s3+s4)
7089 #endif
7090 c      eello6_graph2=-s3
7091       if (.not. calc_grad) return
7092 C Derivatives in gamma(i-1)
7093       if (i.gt.1) then
7094 #ifdef MOMENT
7095         s1=dipderg(1,jj,i)*dip(1,kk,k)
7096 #endif
7097         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7098         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7099         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7100         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7101 #ifdef MOMENT
7102         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7103 #else
7104         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7105 #endif
7106 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7107       endif
7108 C Derivatives in gamma(k-1)
7109 #ifdef MOMENT
7110       s1=dip(1,jj,i)*dipderg(1,kk,k)
7111 #endif
7112       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7113       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7114       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7115       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7116       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7117       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7118       vv(1)=pizda(1,1)-pizda(2,2)
7119       vv(2)=pizda(1,2)+pizda(2,1)
7120       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7121 #ifdef MOMENT
7122       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7123 #else
7124       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7125 #endif
7126 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7127 C Derivatives in gamma(j-1) or gamma(l-1)
7128       if (j.gt.1) then
7129 #ifdef MOMENT
7130         s1=dipderg(3,jj,i)*dip(1,kk,k)
7131 #endif
7132         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7133         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7134         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7135         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7136         vv(1)=pizda(1,1)-pizda(2,2)
7137         vv(2)=pizda(1,2)+pizda(2,1)
7138         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7139 #ifdef MOMENT
7140         if (swap) then
7141           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7142         else
7143           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7144         endif
7145 #endif
7146         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7147 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7148       endif
7149 C Derivatives in gamma(l-1) or gamma(j-1)
7150       if (l.gt.1) then
7151 #ifdef MOMENT
7152         s1=dip(1,jj,i)*dipderg(3,kk,k)
7153 #endif
7154         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7155         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7156         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7157         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7158         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7159         vv(1)=pizda(1,1)-pizda(2,2)
7160         vv(2)=pizda(1,2)+pizda(2,1)
7161         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7162 #ifdef MOMENT
7163         if (swap) then
7164           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7165         else
7166           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7167         endif
7168 #endif
7169         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7170 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7171       endif
7172 C Cartesian derivatives.
7173       if (lprn) then
7174         write (2,*) 'In eello6_graph2'
7175         do iii=1,2
7176           write (2,*) 'iii=',iii
7177           do kkk=1,5
7178             write (2,*) 'kkk=',kkk
7179             do jjj=1,2
7180               write (2,'(3(2f10.5),5x)')
7181      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7182             enddo
7183           enddo
7184         enddo
7185       endif
7186       do iii=1,2
7187         do kkk=1,5
7188           do lll=1,3
7189 #ifdef MOMENT
7190             if (iii.eq.1) then
7191               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7192             else
7193               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7194             endif
7195 #endif
7196             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7197      &        auxvec(1))
7198             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7199             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7200      &        auxvec(1))
7201             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7202             call transpose2(EUg(1,1,k),auxmat(1,1))
7203             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7204      &        pizda(1,1))
7205             vv(1)=pizda(1,1)-pizda(2,2)
7206             vv(2)=pizda(1,2)+pizda(2,1)
7207             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7208 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7209 #ifdef MOMENT
7210             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7211 #else
7212             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7213 #endif
7214             if (swap) then
7215               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7216             else
7217               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7218             endif
7219           enddo
7220         enddo
7221       enddo
7222       return
7223       end
7224 c----------------------------------------------------------------------------
7225       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7226       implicit real*8 (a-h,o-z)
7227       include 'DIMENSIONS'
7228       include 'sizesclu.dat'
7229       include 'COMMON.IOUNITS'
7230       include 'COMMON.CHAIN'
7231       include 'COMMON.DERIV'
7232       include 'COMMON.INTERACT'
7233       include 'COMMON.CONTACTS'
7234       include 'COMMON.TORSION'
7235       include 'COMMON.VAR'
7236       include 'COMMON.GEO'
7237       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7238       logical swap
7239 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7240 C                                                                              C
7241 C      Parallel       Antiparallel                                             C
7242 C                                                                              C
7243 C          o             o                                                     C
7244 C         /l\   /   \   /j\                                                    C
7245 C        /   \ /     \ /   \                                                   C
7246 C       /| o |o       o| o |\                                                  C
7247 C       j|/k\|  /      |/k\|l /                                                C
7248 C        /   \ /       /   \ /                                                 C
7249 C       /     o       /     o                                                  C
7250 C       i             i                                                        C
7251 C                                                                              C
7252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7253 C
7254 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7255 C           energy moment and not to the cluster cumulant.
7256       iti=itortyp(itype(i))
7257       if (j.lt.nres-1) then
7258         itj1=itortyp(itype(j+1))
7259       else
7260         itj1=ntortyp+1
7261       endif
7262       itk=itortyp(itype(k))
7263       itk1=itortyp(itype(k+1))
7264       if (l.lt.nres-1) then
7265         itl1=itortyp(itype(l+1))
7266       else
7267         itl1=ntortyp+1
7268       endif
7269 #ifdef MOMENT
7270       s1=dip(4,jj,i)*dip(4,kk,k)
7271 #endif
7272       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7273       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7274       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7275       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7276       call transpose2(EE(1,1,itk),auxmat(1,1))
7277       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7278       vv(1)=pizda(1,1)+pizda(2,2)
7279       vv(2)=pizda(2,1)-pizda(1,2)
7280       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7281 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7282 #ifdef MOMENT
7283       eello6_graph3=-(s1+s2+s3+s4)
7284 #else
7285       eello6_graph3=-(s2+s3+s4)
7286 #endif
7287 c      eello6_graph3=-s4
7288       if (.not. calc_grad) return
7289 C Derivatives in gamma(k-1)
7290       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7291       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7292       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7293       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7294 C Derivatives in gamma(l-1)
7295       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7296       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7297       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7298       vv(1)=pizda(1,1)+pizda(2,2)
7299       vv(2)=pizda(2,1)-pizda(1,2)
7300       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7301       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7302 C Cartesian derivatives.
7303       do iii=1,2
7304         do kkk=1,5
7305           do lll=1,3
7306 #ifdef MOMENT
7307             if (iii.eq.1) then
7308               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7309             else
7310               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7311             endif
7312 #endif
7313             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7314      &        auxvec(1))
7315             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7316             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7317      &        auxvec(1))
7318             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7319             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7320      &        pizda(1,1))
7321             vv(1)=pizda(1,1)+pizda(2,2)
7322             vv(2)=pizda(2,1)-pizda(1,2)
7323             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7324 #ifdef MOMENT
7325             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7326 #else
7327             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7328 #endif
7329             if (swap) then
7330               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7331             else
7332               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7333             endif
7334 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7335           enddo
7336         enddo
7337       enddo
7338       return
7339       end
7340 c----------------------------------------------------------------------------
7341       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7342       implicit real*8 (a-h,o-z)
7343       include 'DIMENSIONS'
7344       include 'sizesclu.dat'
7345       include 'COMMON.IOUNITS'
7346       include 'COMMON.CHAIN'
7347       include 'COMMON.DERIV'
7348       include 'COMMON.INTERACT'
7349       include 'COMMON.CONTACTS'
7350       include 'COMMON.TORSION'
7351       include 'COMMON.VAR'
7352       include 'COMMON.GEO'
7353       include 'COMMON.FFIELD'
7354       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7355      & auxvec1(2),auxmat1(2,2)
7356       logical swap
7357 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7358 C                                                                              C
7359 C      Parallel       Antiparallel                                             C
7360 C                                                                              C
7361 C          o             o                                                     C
7362 C         /l\   /   \   /j\                                                    C
7363 C        /   \ /     \ /   \                                                   C
7364 C       /| o |o       o| o |\                                                  C
7365 C     \ j|/k\|      \  |/k\|l                                                  C
7366 C      \ /   \       \ /   \                                                   C
7367 C       o     \       o     \                                                  C
7368 C       i             i                                                        C
7369 C                                                                              C
7370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7371 C
7372 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7373 C           energy moment and not to the cluster cumulant.
7374 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7375       iti=itortyp(itype(i))
7376       itj=itortyp(itype(j))
7377       if (j.lt.nres-1) then
7378         itj1=itortyp(itype(j+1))
7379       else
7380         itj1=ntortyp+1
7381       endif
7382       itk=itortyp(itype(k))
7383       if (k.lt.nres-1) then
7384         itk1=itortyp(itype(k+1))
7385       else
7386         itk1=ntortyp+1
7387       endif
7388       itl=itortyp(itype(l))
7389       if (l.lt.nres-1) then
7390         itl1=itortyp(itype(l+1))
7391       else
7392         itl1=ntortyp+1
7393       endif
7394 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7395 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7396 cd     & ' itl',itl,' itl1',itl1
7397 #ifdef MOMENT
7398       if (imat.eq.1) then
7399         s1=dip(3,jj,i)*dip(3,kk,k)
7400       else
7401         s1=dip(2,jj,j)*dip(2,kk,l)
7402       endif
7403 #endif
7404       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7405       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7406       if (j.eq.l+1) then
7407         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7408         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7409       else
7410         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7411         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7412       endif
7413       call transpose2(EUg(1,1,k),auxmat(1,1))
7414       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7415       vv(1)=pizda(1,1)-pizda(2,2)
7416       vv(2)=pizda(2,1)+pizda(1,2)
7417       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7418 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7419 #ifdef MOMENT
7420       eello6_graph4=-(s1+s2+s3+s4)
7421 #else
7422       eello6_graph4=-(s2+s3+s4)
7423 #endif
7424       if (.not. calc_grad) return
7425 C Derivatives in gamma(i-1)
7426       if (i.gt.1) then
7427 #ifdef MOMENT
7428         if (imat.eq.1) then
7429           s1=dipderg(2,jj,i)*dip(3,kk,k)
7430         else
7431           s1=dipderg(4,jj,j)*dip(2,kk,l)
7432         endif
7433 #endif
7434         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7435         if (j.eq.l+1) then
7436           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7437           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7438         else
7439           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7440           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7441         endif
7442         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7443         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7444 cd          write (2,*) 'turn6 derivatives'
7445 #ifdef MOMENT
7446           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7447 #else
7448           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7449 #endif
7450         else
7451 #ifdef MOMENT
7452           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7453 #else
7454           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7455 #endif
7456         endif
7457       endif
7458 C Derivatives in gamma(k-1)
7459 #ifdef MOMENT
7460       if (imat.eq.1) then
7461         s1=dip(3,jj,i)*dipderg(2,kk,k)
7462       else
7463         s1=dip(2,jj,j)*dipderg(4,kk,l)
7464       endif
7465 #endif
7466       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7467       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7468       if (j.eq.l+1) then
7469         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7470         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7471       else
7472         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7473         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7474       endif
7475       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7476       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7477       vv(1)=pizda(1,1)-pizda(2,2)
7478       vv(2)=pizda(2,1)+pizda(1,2)
7479       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7480       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7481 #ifdef MOMENT
7482         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7483 #else
7484         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7485 #endif
7486       else
7487 #ifdef MOMENT
7488         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7489 #else
7490         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7491 #endif
7492       endif
7493 C Derivatives in gamma(j-1) or gamma(l-1)
7494       if (l.eq.j+1 .and. l.gt.1) then
7495         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7496         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7497         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7498         vv(1)=pizda(1,1)-pizda(2,2)
7499         vv(2)=pizda(2,1)+pizda(1,2)
7500         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7501         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7502       else if (j.gt.1) then
7503         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7504         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7505         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7506         vv(1)=pizda(1,1)-pizda(2,2)
7507         vv(2)=pizda(2,1)+pizda(1,2)
7508         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7509         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7510           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7511         else
7512           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7513         endif
7514       endif
7515 C Cartesian derivatives.
7516       do iii=1,2
7517         do kkk=1,5
7518           do lll=1,3
7519 #ifdef MOMENT
7520             if (iii.eq.1) then
7521               if (imat.eq.1) then
7522                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7523               else
7524                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7525               endif
7526             else
7527               if (imat.eq.1) then
7528                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7529               else
7530                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7531               endif
7532             endif
7533 #endif
7534             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7535      &        auxvec(1))
7536             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7537             if (j.eq.l+1) then
7538               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7539      &          b1(1,itj1),auxvec(1))
7540               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7541             else
7542               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7543      &          b1(1,itl1),auxvec(1))
7544               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7545             endif
7546             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7547      &        pizda(1,1))
7548             vv(1)=pizda(1,1)-pizda(2,2)
7549             vv(2)=pizda(2,1)+pizda(1,2)
7550             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7551             if (swap) then
7552               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7553 #ifdef MOMENT
7554                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7555      &             -(s1+s2+s4)
7556 #else
7557                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7558      &             -(s2+s4)
7559 #endif
7560                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7561               else
7562 #ifdef MOMENT
7563                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7564 #else
7565                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7566 #endif
7567                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7568               endif
7569             else
7570 #ifdef MOMENT
7571               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7572 #else
7573               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7574 #endif
7575               if (l.eq.j+1) then
7576                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7577               else
7578                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7579               endif
7580             endif
7581           enddo
7582         enddo
7583       enddo
7584       return
7585       end
7586 c----------------------------------------------------------------------------
7587       double precision function eello_turn6(i,jj,kk)
7588       implicit real*8 (a-h,o-z)
7589       include 'DIMENSIONS'
7590       include 'sizesclu.dat'
7591       include 'COMMON.IOUNITS'
7592       include 'COMMON.CHAIN'
7593       include 'COMMON.DERIV'
7594       include 'COMMON.INTERACT'
7595       include 'COMMON.CONTACTS'
7596       include 'COMMON.TORSION'
7597       include 'COMMON.VAR'
7598       include 'COMMON.GEO'
7599       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7600      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7601      &  ggg1(3),ggg2(3)
7602       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7603      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7604 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7605 C           the respective energy moment and not to the cluster cumulant.
7606       eello_turn6=0.0d0
7607       j=i+4
7608       k=i+1
7609       l=i+3
7610       iti=itortyp(itype(i))
7611       itk=itortyp(itype(k))
7612       itk1=itortyp(itype(k+1))
7613       itl=itortyp(itype(l))
7614       itj=itortyp(itype(j))
7615 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7616 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7617 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7618 cd        eello6=0.0d0
7619 cd        return
7620 cd      endif
7621 cd      write (iout,*)
7622 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7623 cd     &   ' and',k,l
7624 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7625       do iii=1,2
7626         do kkk=1,5
7627           do lll=1,3
7628             derx_turn(lll,kkk,iii)=0.0d0
7629           enddo
7630         enddo
7631       enddo
7632 cd      eij=1.0d0
7633 cd      ekl=1.0d0
7634 cd      ekont=1.0d0
7635       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7636 cd      eello6_5=0.0d0
7637 cd      write (2,*) 'eello6_5',eello6_5
7638 #ifdef MOMENT
7639       call transpose2(AEA(1,1,1),auxmat(1,1))
7640       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7641       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7642       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7643 #else
7644       s1 = 0.0d0
7645 #endif
7646       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7647       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7648       s2 = scalar2(b1(1,itk),vtemp1(1))
7649 #ifdef MOMENT
7650       call transpose2(AEA(1,1,2),atemp(1,1))
7651       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7652       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7653       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7654 #else
7655       s8=0.0d0
7656 #endif
7657       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7658       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7659       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7660 #ifdef MOMENT
7661       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7662       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7663       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7664       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7665       ss13 = scalar2(b1(1,itk),vtemp4(1))
7666       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7667 #else
7668       s13=0.0d0
7669 #endif
7670 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7671 c      s1=0.0d0
7672 c      s2=0.0d0
7673 c      s8=0.0d0
7674 c      s12=0.0d0
7675 c      s13=0.0d0
7676       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7677       if (calc_grad) then
7678 C Derivatives in gamma(i+2)
7679 #ifdef MOMENT
7680       call transpose2(AEA(1,1,1),auxmatd(1,1))
7681       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7682       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7683       call transpose2(AEAderg(1,1,2),atempd(1,1))
7684       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7685       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7686 #else
7687       s8d=0.0d0
7688 #endif
7689       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7690       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7691       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7692 c      s1d=0.0d0
7693 c      s2d=0.0d0
7694 c      s8d=0.0d0
7695 c      s12d=0.0d0
7696 c      s13d=0.0d0
7697       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7698 C Derivatives in gamma(i+3)
7699 #ifdef MOMENT
7700       call transpose2(AEA(1,1,1),auxmatd(1,1))
7701       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7702       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7703       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7704 #else
7705       s1d=0.0d0
7706 #endif
7707       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7708       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7709       s2d = scalar2(b1(1,itk),vtemp1d(1))
7710 #ifdef MOMENT
7711       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7712       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7713 #endif
7714       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7715 #ifdef MOMENT
7716       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7717       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7718       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7719 #else
7720       s13d=0.0d0
7721 #endif
7722 c      s1d=0.0d0
7723 c      s2d=0.0d0
7724 c      s8d=0.0d0
7725 c      s12d=0.0d0
7726 c      s13d=0.0d0
7727 #ifdef MOMENT
7728       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7729      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7730 #else
7731       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7732      &               -0.5d0*ekont*(s2d+s12d)
7733 #endif
7734 C Derivatives in gamma(i+4)
7735       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7736       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7737       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7738 #ifdef MOMENT
7739       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7740       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7741       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7742 #else
7743       s13d = 0.0d0
7744 #endif
7745 c      s1d=0.0d0
7746 c      s2d=0.0d0
7747 c      s8d=0.0d0
7748 C      s12d=0.0d0
7749 c      s13d=0.0d0
7750 #ifdef MOMENT
7751       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7752 #else
7753       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7754 #endif
7755 C Derivatives in gamma(i+5)
7756 #ifdef MOMENT
7757       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7758       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7759       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7760 #else
7761       s1d = 0.0d0
7762 #endif
7763       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7764       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7765       s2d = scalar2(b1(1,itk),vtemp1d(1))
7766 #ifdef MOMENT
7767       call transpose2(AEA(1,1,2),atempd(1,1))
7768       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7769       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7770 #else
7771       s8d = 0.0d0
7772 #endif
7773       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7774       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7775 #ifdef MOMENT
7776       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7777       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7778       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7779 #else
7780       s13d = 0.0d0
7781 #endif
7782 c      s1d=0.0d0
7783 c      s2d=0.0d0
7784 c      s8d=0.0d0
7785 c      s12d=0.0d0
7786 c      s13d=0.0d0
7787 #ifdef MOMENT
7788       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7789      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7790 #else
7791       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7792      &               -0.5d0*ekont*(s2d+s12d)
7793 #endif
7794 C Cartesian derivatives
7795       do iii=1,2
7796         do kkk=1,5
7797           do lll=1,3
7798 #ifdef MOMENT
7799             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7800             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7801             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7802 #else
7803             s1d = 0.0d0
7804 #endif
7805             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7806             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7807      &          vtemp1d(1))
7808             s2d = scalar2(b1(1,itk),vtemp1d(1))
7809 #ifdef MOMENT
7810             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7811             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7812             s8d = -(atempd(1,1)+atempd(2,2))*
7813      &           scalar2(cc(1,1,itl),vtemp2(1))
7814 #else
7815             s8d = 0.0d0
7816 #endif
7817             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7818      &           auxmatd(1,1))
7819             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7820             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7821 c      s1d=0.0d0
7822 c      s2d=0.0d0
7823 c      s8d=0.0d0
7824 c      s12d=0.0d0
7825 c      s13d=0.0d0
7826 #ifdef MOMENT
7827             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7828      &        - 0.5d0*(s1d+s2d)
7829 #else
7830             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7831      &        - 0.5d0*s2d
7832 #endif
7833 #ifdef MOMENT
7834             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7835      &        - 0.5d0*(s8d+s12d)
7836 #else
7837             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7838      &        - 0.5d0*s12d
7839 #endif
7840           enddo
7841         enddo
7842       enddo
7843 #ifdef MOMENT
7844       do kkk=1,5
7845         do lll=1,3
7846           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7847      &      achuj_tempd(1,1))
7848           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7849           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7850           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7851           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7852           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7853      &      vtemp4d(1))
7854           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7855           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7856           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7857         enddo
7858       enddo
7859 #endif
7860 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7861 cd     &  16*eel_turn6_num
7862 cd      goto 1112
7863       if (j.lt.nres-1) then
7864         j1=j+1
7865         j2=j-1
7866       else
7867         j1=j-1
7868         j2=j-2
7869       endif
7870       if (l.lt.nres-1) then
7871         l1=l+1
7872         l2=l-1
7873       else
7874         l1=l-1
7875         l2=l-2
7876       endif
7877       do ll=1,3
7878         ggg1(ll)=eel_turn6*g_contij(ll,1)
7879         ggg2(ll)=eel_turn6*g_contij(ll,2)
7880         ghalf=0.5d0*ggg1(ll)
7881 cd        ghalf=0.0d0
7882         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7883      &    +ekont*derx_turn(ll,2,1)
7884         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7885         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7886      &    +ekont*derx_turn(ll,4,1)
7887         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7888         ghalf=0.5d0*ggg2(ll)
7889 cd        ghalf=0.0d0
7890         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7891      &    +ekont*derx_turn(ll,2,2)
7892         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7893         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7894      &    +ekont*derx_turn(ll,4,2)
7895         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7896       enddo
7897 cd      goto 1112
7898       do m=i+1,j-1
7899         do ll=1,3
7900           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7901         enddo
7902       enddo
7903       do m=k+1,l-1
7904         do ll=1,3
7905           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7906         enddo
7907       enddo
7908 1112  continue
7909       do m=i+2,j2
7910         do ll=1,3
7911           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7912         enddo
7913       enddo
7914       do m=k+2,l2
7915         do ll=1,3
7916           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7917         enddo
7918       enddo
7919 cd      do iii=1,nres-3
7920 cd        write (2,*) iii,g_corr6_loc(iii)
7921 cd      enddo
7922       endif
7923       eello_turn6=ekont*eel_turn6
7924 cd      write (2,*) 'ekont',ekont
7925 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7926       return
7927       end
7928 crc-------------------------------------------------
7929       SUBROUTINE MATVEC2(A1,V1,V2)
7930       implicit real*8 (a-h,o-z)
7931       include 'DIMENSIONS'
7932       DIMENSION A1(2,2),V1(2),V2(2)
7933 c      DO 1 I=1,2
7934 c        VI=0.0
7935 c        DO 3 K=1,2
7936 c    3     VI=VI+A1(I,K)*V1(K)
7937 c        Vaux(I)=VI
7938 c    1 CONTINUE
7939
7940       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7941       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7942
7943       v2(1)=vaux1
7944       v2(2)=vaux2
7945       END
7946 C---------------------------------------
7947       SUBROUTINE MATMAT2(A1,A2,A3)
7948       implicit real*8 (a-h,o-z)
7949       include 'DIMENSIONS'
7950       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7951 c      DIMENSION AI3(2,2)
7952 c        DO  J=1,2
7953 c          A3IJ=0.0
7954 c          DO K=1,2
7955 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7956 c          enddo
7957 c          A3(I,J)=A3IJ
7958 c       enddo
7959 c      enddo
7960
7961       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7962       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7963       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7964       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7965
7966       A3(1,1)=AI3_11
7967       A3(2,1)=AI3_21
7968       A3(1,2)=AI3_12
7969       A3(2,2)=AI3_22
7970       END
7971
7972 c-------------------------------------------------------------------------
7973       double precision function scalar2(u,v)
7974       implicit none
7975       double precision u(2),v(2)
7976       double precision sc
7977       integer i
7978       scalar2=u(1)*v(1)+u(2)*v(2)
7979       return
7980       end
7981
7982 C-----------------------------------------------------------------------------
7983
7984       subroutine transpose2(a,at)
7985       implicit none
7986       double precision a(2,2),at(2,2)
7987       at(1,1)=a(1,1)
7988       at(1,2)=a(2,1)
7989       at(2,1)=a(1,2)
7990       at(2,2)=a(2,2)
7991       return
7992       end
7993 c--------------------------------------------------------------------------
7994       subroutine transpose(n,a,at)
7995       implicit none
7996       integer n,i,j
7997       double precision a(n,n),at(n,n)
7998       do i=1,n
7999         do j=1,n
8000           at(j,i)=a(i,j)
8001         enddo
8002       enddo
8003       return
8004       end
8005 C---------------------------------------------------------------------------
8006       subroutine prodmat3(a1,a2,kk,transp,prod)
8007       implicit none
8008       integer i,j
8009       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8010       logical transp
8011 crc      double precision auxmat(2,2),prod_(2,2)
8012
8013       if (transp) then
8014 crc        call transpose2(kk(1,1),auxmat(1,1))
8015 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8016 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8017
8018            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8019      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8020            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8021      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8022            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8023      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8024            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8025      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8026
8027       else
8028 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8029 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8030
8031            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8032      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8033            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8034      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8035            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8036      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8037            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8038      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8039
8040       endif
8041 c      call transpose2(a2(1,1),a2t(1,1))
8042
8043 crc      print *,transp
8044 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8045 crc      print *,((prod(i,j),i=1,2),j=1,2)
8046
8047       return
8048       end
8049 C-----------------------------------------------------------------------------
8050       double precision function scalar(u,v)
8051       implicit none
8052       double precision u(3),v(3)
8053       double precision sc
8054       integer i
8055       sc=0.0d0
8056       do i=1,3
8057         sc=sc+u(i)*v(i)
8058       enddo
8059       scalar=sc
8060       return
8061       end
8062