source/cluster/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 c     external proc_proc
   7 #ifdef WINPGI
   8 cMS$ATTRIBUTES C ::  proc_proc
   9 #endif
  10
  11       include 'COMMON.IOUNITS'
  12       double precision energia(0:max_ene),energia1(0:max_ene+1)
  13 #ifdef MPL
  14       include 'COMMON.INFO'
  15       external d_vadd
  16       integer ready
  17 #endif
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.CONTROL'
  24
  25       double precision fact(5)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor,fact(1))
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105
 106 c      write(iout,*) "TEST_ENE",constr_homology
 107       if (constr_homology.ge.1) then
 108         call e_modeller(ehomology_constr)
 109       else
 110         ehomology_constr=0.0d0
 111       endif
 112 c      write(iout,*) "TEST_ENE",ehomology_constr
 113
 114 C     BARTEK for dfa test!
 115       if (wdfa_dist.gt.0) call edfad(edfadis)
 116 c      print*, 'edfad is finished!', edfadis
 117       if (wdfa_tor.gt.0) call edfat(edfator)
 118 c      print*, 'edfat is finished!', edfator
 119       if (wdfa_nei.gt.0) call edfan(edfanei)
 120 c      print*, 'edfan is finished!', edfanei
 121       if (wdfa_beta.gt.0) call edfab(edfabet)
 122 c      print*, 'edfab is finished!', edfabet
 123
 124
 125 C     call multibody(ecorr)
 126 C
 127 C Sum the energies
 128 C
 129 #ifdef SPLITELE
 130       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*ees+wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*(ees+evdw1)
 141      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 142      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 143      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 144      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 145      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 146      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 147      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 148      & +wdfa_beta*edfabet
 149 #endif
 150       energia(0)=etot
 151       energia(1)=evdw
 152 #ifdef SCP14
 153       energia(2)=evdw2-evdw2_14
 154       energia(17)=evdw2_14
 155 #else
 156       energia(2)=evdw2
 157       energia(17)=0.0d0
 158 #endif
 159 #ifdef SPLITELE
 160       energia(3)=ees
 161       energia(16)=evdw1
 162 #else
 163       energia(3)=ees+evdw1
 164       energia(16)=0.0d0
 165 #endif
 166       energia(4)=ecorr
 167       energia(5)=ecorr5
 168       energia(6)=ecorr6
 169       energia(7)=eel_loc
 170       energia(8)=eello_turn3
 171       energia(9)=eello_turn4
 172       energia(10)=eturn6
 173       energia(11)=ebe
 174       energia(12)=escloc
 175       energia(13)=etors
 176       energia(14)=etors_d
 177       energia(15)=ehpb
 178       energia(18)=estr
 179       energia(19)=esccor
 180       energia(20)=edihcnstr
 181       energia(21)=ehomology_constr
 182       energia(22)=edfadis
 183       energia(23)=edfator
 184       energia(24)=edfanei
 185       energia(25)=edfabet
 186 cc      if (dyn_ss) call dyn_set_nss
 187 c detecting NaNQ
 188       i=0
 189 #ifdef WINPGI
 190       idumm=proc_proc(etot,i)
 191 #else
 192 c     call proc_proc(etot,i)
 193 #endif
 194       if(i.eq.1)energia(0)=1.0d+99
 195 #ifdef MPL
 196 c     endif
 197 #endif
 198       if (calc_grad) then
 199 C
 200 C Sum up the components of the Cartesian gradient.
 201 C
 202 #ifdef SPLITELE
 203       do i=1,nct
 204         do j=1,3
 205           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 206      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 207      &                wbond*gradb(j,i)+
 208      &                wstrain*ghpbc(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)+
 217      &                wdfa_dist*gdfad(j,i)+
 218      &                wdfa_tor*gdfat(j,i)+
 219      &                wdfa_nei*gdfan(j,i)+
 220      &                wdfa_beta*gdfab(j,i)
 221           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 222      &                  wbond*gradbx(j,i)+
 223      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 224         enddo
 225 #else
 226       do i=1,nct
 227         do j=1,3
 228           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 229      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 230      &                wbond*gradb(j,i)+
 231      &                wcorr*fact(3)*gradcorr(j,i)+
 232      &                wel_loc*fact(2)*gel_loc(j,i)+
 233      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 234      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 235      &                wcorr5*fact(4)*gradcorr5(j,i)+
 236      &                wcorr6*fact(5)*gradcorr6(j,i)+
 237      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 238      &                wsccor*fact(2)*gsccorc(j,i)+
 239      &                wdfa_dist*gdfad(j,i)+
 240      &                wdfa_tor*gdfat(j,i)+
 241      &                wdfa_nei*gdfan(j,i)+
 242      &                wdfa_beta*gdfab(j,i)
 243           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 244      &                  wbond*gradbx(j,i)+
 245      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 246         enddo
 247 #endif
 248 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 249 cd   &        (gradc(k,i),k=1,3)
 250       enddo
 251
 252
 253       do i=1,nres-3
 254 cd        write (iout,*) i,g_corr5_loc(i)
 255         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 256      &   +wcorr5*fact(4)*g_corr5_loc(i)
 257      &   +wcorr6*fact(5)*g_corr6_loc(i)
 258      &   +wturn4*fact(3)*gel_loc_turn4(i)
 259      &   +wturn3*fact(2)*gel_loc_turn3(i)
 260      &   +wturn6*fact(5)*gel_loc_turn6(i)
 261      &   +wel_loc*fact(2)*gel_loc_loc(i)
 262      &   +wsccor*fact(1)*gsccor_loc(i)
 263       enddo
 264       endif
 265 c      call enerprint(energia(0),fact)
 266 cd    call intout
 267 cd    stop
 268       return
 269       end
 270 C------------------------------------------------------------------------
 271       subroutine enerprint(energia,fact)
 272       implicit real*8 (a-h,o-z)
 273       include 'DIMENSIONS'
 274       include 'sizesclu.dat'
 275       include 'COMMON.IOUNITS'
 276       include 'COMMON.FFIELD'
 277       include 'COMMON.SBRIDGE'
 278       double precision energia(0:max_ene),fact(5)
 279       etot=energia(0)
 280       evdw=energia(1)
 281 #ifdef SCP14
 282       evdw2=energia(2)+energia(17)
 283 #else
 284       evdw2=energia(2)
 285 #endif
 286       ees=energia(3)
 287 #ifdef SPLITELE
 288       evdw1=energia(16)
 289 #endif
 290       ecorr=energia(4)
 291       ecorr5=energia(5)
 292       ecorr6=energia(6)
 293       eel_loc=energia(7)
 294       eello_turn3=energia(8)
 295       eello_turn4=energia(9)
 296       eello_turn6=energia(10)
 297       ebe=energia(11)
 298       escloc=energia(12)
 299       etors=energia(13)
 300       etors_d=energia(14)
 301       ehpb=energia(15)
 302       esccor=energia(19)
 303       edihcnstr=energia(20)
 304       estr=energia(18)
 305       ehomology_constr=energia(21)
 306       edfadis=energia(22)
 307       edfator=energia(23)
 308       edfanei=energia(24)
 309       edfabet=energia(25)
 310 #ifdef SPLITELE
 311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 312      &  wvdwpp,
 313      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 314      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 315      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 316      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 317      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 318      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 320      &  wdfa_beta,etot
 321    10 format (/'Virtual-chain energies:'//
 322      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 323      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 324      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 325      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 332      & ' (SS bridges & dist. cnstr.)'/
 333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 341      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 342      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 344      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 345      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 346      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 347      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #else
 350       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 351      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 352      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 353      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 354      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 355      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 356      &  edihcnstr,ehomology_constr,ebr*nss,
 357      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 358      &  wdfa_beta,etot
 359    10 format (/'Virtual-chain energies:'//
 360      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 361      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 362      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 363      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 364      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 365      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 366      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 367      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 368      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 369      & ' (SS bridges & dist. cnstr.)'/
 370      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 372      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 373      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 374      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 375      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 376      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 377      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 378      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 379      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 380      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 381      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 382      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 383      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 384      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 385      & 'ETOT=  ',1pE16.6,' (total)')
 386 #endif
 387       return
 388       end
 389 C-----------------------------------------------------------------------
 390       subroutine elj(evdw)
 391 C
 392 C This subroutine calculates the interaction energy of nonbonded side chains
 393 C assuming the LJ potential of interaction.
 394 C
 395       implicit real*8 (a-h,o-z)
 396       include 'DIMENSIONS'
 397       include 'sizesclu.dat'
 398 c      include "DIMENSIONS.COMPAR"
 399       parameter (accur=1.0d-10)
 400       include 'COMMON.GEO'
 401       include 'COMMON.VAR'
 402       include 'COMMON.LOCAL'
 403       include 'COMMON.CHAIN'
 404       include 'COMMON.DERIV'
 405       include 'COMMON.INTERACT'
 406       include 'COMMON.TORSION'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.NAMES'
 409       include 'COMMON.IOUNITS'
 410       include 'COMMON.CONTACTS'
 411       dimension gg(3)
 412       integer icant
 413       external icant
 414 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 415       evdw=0.0D0
 416       do i=iatsc_s,iatsc_e
 417         itypi=itype(i)
 418         itypi1=itype(i+1)
 419         xi=c(1,nres+i)
 420         yi=c(2,nres+i)
 421         zi=c(3,nres+i)
 422 C Change 12/1/95
 423         num_conti=0
 424 C
 425 C Calculate SC interaction energy.
 426 C
 427         do iint=1,nint_gr(i)
 428 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 429 cd   &                  'iend=',iend(i,iint)
 430           do j=istart(i,iint),iend(i,iint)
 431             itypj=itype(j)
 432             xj=c(1,nres+j)-xi
 433             yj=c(2,nres+j)-yi
 434             zj=c(3,nres+j)-zi
 435 C Change 12/1/95 to calculate four-body interactions
 436             rij=xj*xj+yj*yj+zj*zj
 437             rrij=1.0D0/rij
 438 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 439             eps0ij=eps(itypi,itypj)
 440             fac=rrij**expon2
 441             e1=fac*fac*aa(itypi,itypj)
 442             e2=fac*bb(itypi,itypj)
 443             evdwij=e1+e2
 444             ij=icant(itypi,itypj)
 445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 447 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 449 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 450 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 451             evdw=evdw+evdwij
 452             if (calc_grad) then
 453 C
 454 C Calculate the components of the gradient in DC and X
 455 C
 456             fac=-rrij*(e1+evdwij)
 457             gg(1)=xj*fac
 458             gg(2)=yj*fac
 459             gg(3)=zj*fac
 460             do k=1,3
 461               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 462               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 463             enddo
 464             do k=i,j-1
 465               do l=1,3
 466                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 467               enddo
 468             enddo
 469             endif
 470 C
 471 C 12/1/95, revised on 5/20/97
 472 C
 473 C Calculate the contact function. The ith column of the array JCONT will
 474 C contain the numbers of atoms that make contacts with the atom I (of numbers
 475 C greater than I). The arrays FACONT and GACONT will contain the values of
 476 C the contact function and its derivative.
 477 C
 478 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 479 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 480 C Uncomment next line, if the correlation interactions are contact function only
 481             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 482               rij=dsqrt(rij)
 483               sigij=sigma(itypi,itypj)
 484               r0ij=rs0(itypi,itypj)
 485 C
 486 C Check whether the SC's are not too far to make a contact.
 487 C
 488               rcut=1.5d0*r0ij
 489               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 490 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 491 C
 492               if (fcont.gt.0.0D0) then
 493 C If the SC-SC distance if close to sigma, apply spline.
 494 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 495 cAdam &             fcont1,fprimcont1)
 496 cAdam           fcont1=1.0d0-fcont1
 497 cAdam           if (fcont1.gt.0.0d0) then
 498 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 499 cAdam             fcont=fcont*fcont1
 500 cAdam           endif
 501 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 502 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 503 cga             do k=1,3
 504 cga               gg(k)=gg(k)*eps0ij
 505 cga             enddo
 506 cga             eps0ij=-evdwij*eps0ij
 507 C Uncomment for AL's type of SC correlation interactions.
 508 cadam           eps0ij=-evdwij
 509                 num_conti=num_conti+1
 510                 jcont(num_conti,i)=j
 511                 facont(num_conti,i)=fcont*eps0ij
 512                 fprimcont=eps0ij*fprimcont/rij
 513                 fcont=expon*fcont
 514 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 515 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 516 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 517 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 518                 gacont(1,num_conti,i)=-fprimcont*xj
 519                 gacont(2,num_conti,i)=-fprimcont*yj
 520                 gacont(3,num_conti,i)=-fprimcont*zj
 521 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 522 cd              write (iout,'(2i3,3f10.5)')
 523 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 524               endif
 525             endif
 526           enddo      ! j
 527         enddo        ! iint
 528 C Change 12/1/95
 529         num_cont(i)=num_conti
 530       enddo          ! i
 531       if (calc_grad) then
 532       do i=1,nct
 533         do j=1,3
 534           gvdwc(j,i)=expon*gvdwc(j,i)
 535           gvdwx(j,i)=expon*gvdwx(j,i)
 536         enddo
 537       enddo
 538       endif
 539 C******************************************************************************
 540 C
 541 C                              N O T E !!!
 542 C
 543 C To save time, the factor of EXPON has been extracted from ALL components
 544 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 545 C use!
 546 C
 547 C******************************************************************************
 548       return
 549       end
 550 C-----------------------------------------------------------------------------
 551       subroutine eljk(evdw)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJK potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'sizesclu.dat'
 559 c      include "DIMENSIONS.COMPAR"
 560       include 'COMMON.GEO'
 561       include 'COMMON.VAR'
 562       include 'COMMON.LOCAL'
 563       include 'COMMON.CHAIN'
 564       include 'COMMON.DERIV'
 565       include 'COMMON.INTERACT'
 566       include 'COMMON.IOUNITS'
 567       include 'COMMON.NAMES'
 568       dimension gg(3)
 569       logical scheck
 570       integer icant
 571       external icant
 572 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 573       evdw=0.0D0
 574       do i=iatsc_s,iatsc_e
 575         itypi=itype(i)
 576         itypi1=itype(i+1)
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=itype(j)
 586             xj=c(1,nres+j)-xi
 587             yj=c(2,nres+j)-yi
 588             zj=c(3,nres+j)-zi
 589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 590             fac_augm=rrij**expon
 591             e_augm=augm(itypi,itypj)*fac_augm
 592             r_inv_ij=dsqrt(rrij)
 593             rij=1.0D0/r_inv_ij
 594             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 595             fac=r_shift_inv**expon
 596             e1=fac*fac*aa(itypi,itypj)
 597             e2=fac*bb(itypi,itypj)
 598             evdwij=e_augm+e1+e2
 599             ij=icant(itypi,itypj)
 600 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 601 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 602 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 603 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 604 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 605 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 606 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 607             evdw=evdw+evdwij
 608             if (calc_grad) then
 609 C
 610 C Calculate the components of the gradient in DC and X
 611 C
 612             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 613             gg(1)=xj*fac
 614             gg(2)=yj*fac
 615             gg(3)=zj*fac
 616             do k=1,3
 617               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 618               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 619             enddo
 620             do k=i,j-1
 621               do l=1,3
 622                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 623               enddo
 624             enddo
 625             endif
 626           enddo      ! j
 627         enddo        ! iint
 628       enddo          ! i
 629       if (calc_grad) then
 630       do i=1,nct
 631         do j=1,3
 632           gvdwc(j,i)=expon*gvdwc(j,i)
 633           gvdwx(j,i)=expon*gvdwx(j,i)
 634         enddo
 635       enddo
 636       endif
 637       return
 638       end
 639 C-----------------------------------------------------------------------------
 640       subroutine ebp(evdw)
 641 C
 642 C This subroutine calculates the interaction energy of nonbonded side chains
 643 C assuming the Berne-Pechukas potential of interaction.
 644 C
 645       implicit real*8 (a-h,o-z)
 646       include 'DIMENSIONS'
 647       include 'sizesclu.dat'
 648 c      include "DIMENSIONS.COMPAR"
 649       include 'COMMON.GEO'
 650       include 'COMMON.VAR'
 651       include 'COMMON.LOCAL'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.DERIV'
 654       include 'COMMON.NAMES'
 655       include 'COMMON.INTERACT'
 656       include 'COMMON.IOUNITS'
 657       include 'COMMON.CALC'
 658       common /srutu/ icall
 659 c     double precision rrsave(maxdim)
 660       logical lprn
 661       integer icant
 662       external icant
 663       evdw=0.0D0
 664 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 665       evdw=0.0D0
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=itype(i)
 674         itypi1=itype(i+1)
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678         dxi=dc_norm(1,nres+i)
 679         dyi=dc_norm(2,nres+i)
 680         dzi=dc_norm(3,nres+i)
 681         dsci_inv=vbld_inv(i+nres)
 682 C
 683 C Calculate SC interaction energy.
 684 C
 685         do iint=1,nint_gr(i)
 686           do j=istart(i,iint),iend(i,iint)
 687             ind=ind+1
 688             itypj=itype(j)
 689             dscj_inv=vbld_inv(j+nres)
 690             chi1=chi(itypi,itypj)
 691             chi2=chi(itypj,itypi)
 692             chi12=chi1*chi2
 693             chip1=chip(itypi)
 694             chip2=chip(itypj)
 695             chip12=chip1*chip2
 696             alf1=alp(itypi)
 697             alf2=alp(itypj)
 698             alf12=0.5D0*(alf1+alf2)
 699 C For diagnostics only!!!
 700 c           chi1=0.0D0
 701 c           chi2=0.0D0
 702 c           chi12=0.0D0
 703 c           chip1=0.0D0
 704 c           chip2=0.0D0
 705 c           chip12=0.0D0
 706 c           alf1=0.0D0
 707 c           alf2=0.0D0
 708 c           alf12=0.0D0
 709             xj=c(1,nres+j)-xi
 710             yj=c(2,nres+j)-yi
 711             zj=c(3,nres+j)-zi
 712             dxj=dc_norm(1,nres+j)
 713             dyj=dc_norm(2,nres+j)
 714             dzj=dc_norm(3,nres+j)
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716 cd          if (icall.eq.0) then
 717 cd            rrsave(ind)=rrij
 718 cd          else
 719 cd            rrij=rrsave(ind)
 720 cd          endif
 721             rij=dsqrt(rrij)
 722 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 723             call sc_angular
 724 C Calculate whole angle-dependent part of epsilon and contributions
 725 C to its derivatives
 726             fac=(rrij*sigsq)**expon2
 727             e1=fac*fac*aa(itypi,itypj)
 728             e2=fac*bb(itypi,itypj)
 729             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 730             eps2der=evdwij*eps3rt
 731             eps3der=evdwij*eps2rt
 732             evdwij=evdwij*eps2rt*eps3rt
 733             ij=icant(itypi,itypj)
 734             aux=eps1*eps2rt**2*eps3rt**2
 735             evdw=evdw+evdwij
 736             if (calc_grad) then
 737             if (lprn) then
 738             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 741 cd     &        restyp(itypi),i,restyp(itypj),j,
 742 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 743 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 744 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 745 cd     &        evdwij
 746             endif
 747 C Calculate gradient components.
 748             e1=e1*eps1*eps2rt**2*eps3rt**2
 749             fac=-expon*(e1+evdwij)
 750             sigder=fac/sigsq
 751             fac=rrij*fac
 752 C Calculate radial part of the gradient
 753             gg(1)=xj*fac
 754             gg(2)=yj*fac
 755             gg(3)=zj*fac
 756 C Calculate the angular part of the gradient and sum add the contributions
 757 C to the appropriate components of the Cartesian gradient.
 758             call sc_grad
 759             endif
 760           enddo      ! j
 761         enddo        ! iint
 762       enddo          ! i
 763 c     stop
 764       return
 765       end
 766 C-----------------------------------------------------------------------------
 767       subroutine egb(evdw)
 768 C
 769 C This subroutine calculates the interaction energy of nonbonded side chains
 770 C assuming the Gay-Berne potential of interaction.
 771 C
 772       implicit real*8 (a-h,o-z)
 773       include 'DIMENSIONS'
 774       include 'sizesclu.dat'
 775 c      include "DIMENSIONS.COMPAR"
 776       include 'COMMON.GEO'
 777       include 'COMMON.VAR'
 778       include 'COMMON.LOCAL'
 779       include 'COMMON.CHAIN'
 780       include 'COMMON.DERIV'
 781       include 'COMMON.NAMES'
 782       include 'COMMON.INTERACT'
 783       include 'COMMON.IOUNITS'
 784       include 'COMMON.CALC'
 785       include 'COMMON.SBRIDGE'
 786       logical lprn
 787       common /srutu/icall
 788       integer icant
 789       external icant
 790       evdw=0.0D0
 791 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 792       evdw=0.0D0
 793       lprn=.false.
 794 c      if (icall.gt.0) lprn=.true.
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=itype(i)
 798         itypi1=itype(i+1)
 799         xi=c(1,nres+i)
 800         yi=c(2,nres+i)
 801         zi=c(3,nres+i)
 802         dxi=dc_norm(1,nres+i)
 803         dyi=dc_norm(2,nres+i)
 804         dzi=dc_norm(3,nres+i)
 805         dsci_inv=vbld_inv(i+nres)
 806 C
 807 C Calculate SC interaction energy.
 808 C
 809         do iint=1,nint_gr(i)
 810           do j=istart(i,iint),iend(i,iint)
 811             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 812               call dyn_ssbond_ene(i,j,evdwij)
 813               evdw=evdw+evdwij
 814 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 815 c     &                        'evdw',i,j,evdwij,' ss'
 816             ELSE
 817             ind=ind+1
 818             itypj=itype(j)
 819             dscj_inv=vbld_inv(j+nres)
 820             sig0ij=sigma(itypi,itypj)
 821             chi1=chi(itypi,itypj)
 822             chi2=chi(itypj,itypi)
 823             chi12=chi1*chi2
 824             chip1=chip(itypi)
 825             chip2=chip(itypj)
 826             chip12=chip1*chip2
 827             alf1=alp(itypi)
 828             alf2=alp(itypj)
 829             alf12=0.5D0*(alf1+alf2)
 830 C For diagnostics only!!!
 831 c           chi1=0.0D0
 832 c           chi2=0.0D0
 833 c           chi12=0.0D0
 834 c           chip1=0.0D0
 835 c           chip2=0.0D0
 836 c           chip12=0.0D0
 837 c           alf1=0.0D0
 838 c           alf2=0.0D0
 839 c           alf12=0.0D0
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843             dxj=dc_norm(1,nres+j)
 844             dyj=dc_norm(2,nres+j)
 845             dzj=dc_norm(3,nres+j)
 846 c            write (iout,*) i,j,xj,yj,zj
 847             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 848             rij=dsqrt(rrij)
 849 C Calculate angle-dependent terms of energy and contributions to their
 850 C derivatives.
 851             call sc_angular
 852             sigsq=1.0D0/sigsq
 853             sig=sig0ij*dsqrt(sigsq)
 854             rij_shift=1.0D0/rij-sig+sig0ij
 855 C I hate to put IF's in the loops, but here don't have another choice!!!!
 856             if (rij_shift.le.0.0D0) then
 857               evdw=1.0D20
 858               return
 859             endif
 860             sigder=-sig*sigsq
 861 c---------------------------------------------------------------
 862             rij_shift=1.0D0/rij_shift
 863             fac=rij_shift**expon
 864             e1=fac*fac*aa(itypi,itypj)
 865             e2=fac*bb(itypi,itypj)
 866             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 867             eps2der=evdwij*eps3rt
 868             eps3der=evdwij*eps2rt
 869             evdwij=evdwij*eps2rt*eps3rt
 870             evdw=evdw+evdwij
 871             ij=icant(itypi,itypj)
 872             aux=eps1*eps2rt**2*eps3rt**2
 873 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 874 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 875 c     &         aux*e2/eps(itypi,itypj)
 876             if (lprn) then
 877             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 878             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 879             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 880      &        restyp(itypi),i,restyp(itypj),j,
 881      &        epsi,sigm,chi1,chi2,chip1,chip2,
 882      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 883      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 884      &        evdwij
 885             endif
 886             if (calc_grad) then
 887 C Calculate gradient components.
 888             e1=e1*eps1*eps2rt**2*eps3rt**2
 889             fac=-expon*(e1+evdwij)*rij_shift
 890             sigder=fac*sigder
 891             fac=rij*fac
 892 C Calculate the radial part of the gradient
 893             gg(1)=xj*fac
 894             gg(2)=yj*fac
 895             gg(3)=zj*fac
 896 C Calculate angular part of the gradient.
 897             call sc_grad
 898             endif
 899             ENDIF    ! SSBOND
 900           enddo      ! j
 901         enddo        ! iint
 902       enddo          ! i
 903       return
 904       end
 905 C-----------------------------------------------------------------------------
 906       subroutine egbv(evdw)
 907 C
 908 C This subroutine calculates the interaction energy of nonbonded side chains
 909 C assuming the Gay-Berne-Vorobjev potential of interaction.
 910 C
 911       implicit real*8 (a-h,o-z)
 912       include 'DIMENSIONS'
 913       include 'sizesclu.dat'
 914 c      include "DIMENSIONS.COMPAR"
 915       include 'COMMON.GEO'
 916       include 'COMMON.VAR'
 917       include 'COMMON.LOCAL'
 918       include 'COMMON.CHAIN'
 919       include 'COMMON.DERIV'
 920       include 'COMMON.NAMES'
 921       include 'COMMON.INTERACT'
 922       include 'COMMON.IOUNITS'
 923       include 'COMMON.CALC'
 924       include 'COMMON.SBRIDGE'
 925       common /srutu/ icall
 926       logical lprn
 927       integer icant
 928       external icant
 929       evdw=0.0D0
 930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 931       evdw=0.0D0
 932       lprn=.false.
 933 c      if (icall.gt.0) lprn=.true.
 934       ind=0
 935       do i=iatsc_s,iatsc_e
 936         itypi=itype(i)
 937         itypi1=itype(i+1)
 938         xi=c(1,nres+i)
 939         yi=c(2,nres+i)
 940         zi=c(3,nres+i)
 941         dxi=dc_norm(1,nres+i)
 942         dyi=dc_norm(2,nres+i)
 943         dzi=dc_norm(3,nres+i)
 944         dsci_inv=vbld_inv(i+nres)
 945 C
 946 C Calculate SC interaction energy.
 947 C
 948         do iint=1,nint_gr(i)
 949           do j=istart(i,iint),iend(i,iint)
 950 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 951             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 952               call dyn_ssbond_ene(i,j,evdwij)
 953               evdw=evdw+evdwij
 954 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 955 c     &                        'evdw',i,j,evdwij,' ss'
 956             ELSE
 957             ind=ind+1
 958             itypj=itype(j)
 959             dscj_inv=vbld_inv(j+nres)
 960             sig0ij=sigma(itypi,itypj)
 961             r0ij=r0(itypi,itypj)
 962             chi1=chi(itypi,itypj)
 963             chi2=chi(itypj,itypi)
 964             chi12=chi1*chi2
 965             chip1=chip(itypi)
 966             chip2=chip(itypj)
 967             chip12=chip1*chip2
 968             alf1=alp(itypi)
 969             alf2=alp(itypj)
 970             alf12=0.5D0*(alf1+alf2)
 971 C For diagnostics only!!!
 972 c           chi1=0.0D0
 973 c           chi2=0.0D0
 974 c           chi12=0.0D0
 975 c           chip1=0.0D0
 976 c           chip2=0.0D0
 977 c           chip12=0.0D0
 978 c           alf1=0.0D0
 979 c           alf2=0.0D0
 980 c           alf12=0.0D0
 981             xj=c(1,nres+j)-xi
 982             yj=c(2,nres+j)-yi
 983             zj=c(3,nres+j)-zi
 984             dxj=dc_norm(1,nres+j)
 985             dyj=dc_norm(2,nres+j)
 986             dzj=dc_norm(3,nres+j)
 987             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 988             rij=dsqrt(rrij)
 989 C Calculate angle-dependent terms of energy and contributions to their
 990 C derivatives.
 991             call sc_angular
 992             sigsq=1.0D0/sigsq
 993             sig=sig0ij*dsqrt(sigsq)
 994             rij_shift=1.0D0/rij-sig+r0ij
 995 C I hate to put IF's in the loops, but here don't have another choice!!!!
 996             if (rij_shift.le.0.0D0) then
 997               evdw=1.0D20
 998               return
 999             endif
1000             sigder=-sig*sigsq
1001 c---------------------------------------------------------------
1002             rij_shift=1.0D0/rij_shift
1003             fac=rij_shift**expon
1004             e1=fac*fac*aa(itypi,itypj)
1005             e2=fac*bb(itypi,itypj)
1006             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1007             eps2der=evdwij*eps3rt
1008             eps3der=evdwij*eps2rt
1009             fac_augm=rrij**expon
1010             e_augm=augm(itypi,itypj)*fac_augm
1011             evdwij=evdwij*eps2rt*eps3rt
1012             evdw=evdw+evdwij+e_augm
1013             ij=icant(itypi,itypj)
1014             aux=eps1*eps2rt**2*eps3rt**2
1015 c            if (lprn) then
1016 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1017 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1018 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1019 c     &        restyp(itypi),i,restyp(itypj),j,
1020 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1021 c     &        chi1,chi2,chip1,chip2,
1022 c     &        eps1,eps2rt**2,eps3rt**2,
1023 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1024 c     &        evdwij+e_augm
1025 c            endif
1026             if (calc_grad) then
1027 C Calculate gradient components.
1028             e1=e1*eps1*eps2rt**2*eps3rt**2
1029             fac=-expon*(e1+evdwij)*rij_shift
1030             sigder=fac*sigder
1031             fac=rij*fac-2*expon*rrij*e_augm
1032 C Calculate the radial part of the gradient
1033             gg(1)=xj*fac
1034             gg(2)=yj*fac
1035             gg(3)=zj*fac
1036 C Calculate angular part of the gradient.
1037             call sc_grad
1038             endif
1039             ENDIF    ! dyn_ss
1040           enddo      ! j
1041         enddo        ! iint
1042       enddo          ! i
1043       return
1044       end
1045 C-----------------------------------------------------------------------------
1046       subroutine sc_angular
1047 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1048 C om12. Called by ebp, egb, and egbv.
1049       implicit none
1050       include 'COMMON.CALC'
1051       erij(1)=xj*rij
1052       erij(2)=yj*rij
1053       erij(3)=zj*rij
1054       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1055       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1056       om12=dxi*dxj+dyi*dyj+dzi*dzj
1057       chiom12=chi12*om12
1058 C Calculate eps1(om12) and its derivative in om12
1059       faceps1=1.0D0-om12*chiom12
1060       faceps1_inv=1.0D0/faceps1
1061       eps1=dsqrt(faceps1_inv)
1062 C Following variable is eps1*deps1/dom12
1063       eps1_om12=faceps1_inv*chiom12
1064 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1065 C and om12.
1066       om1om2=om1*om2
1067       chiom1=chi1*om1
1068       chiom2=chi2*om2
1069       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1070       sigsq=1.0D0-facsig*faceps1_inv
1071       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1072       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1073       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1074 C Calculate eps2 and its derivatives in om1, om2, and om12.
1075       chipom1=chip1*om1
1076       chipom2=chip2*om2
1077       chipom12=chip12*om12
1078       facp=1.0D0-om12*chipom12
1079       facp_inv=1.0D0/facp
1080       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1081 C Following variable is the square root of eps2
1082       eps2rt=1.0D0-facp1*facp_inv
1083 C Following three variables are the derivatives of the square root of eps
1084 C in om1, om2, and om12.
1085       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1086       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1087       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1088 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1089       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1090 C Calculate whole angle-dependent part of epsilon and contributions
1091 C to its derivatives
1092       return
1093       end
1094 C----------------------------------------------------------------------------
1095       subroutine sc_grad
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       include 'sizesclu.dat'
1099       include 'COMMON.CHAIN'
1100       include 'COMMON.DERIV'
1101       include 'COMMON.CALC'
1102       double precision dcosom1(3),dcosom2(3)
1103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1104       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1105       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1106      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1107       do k=1,3
1108         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1109         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1110       enddo
1111       do k=1,3
1112         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1113       enddo
1114       do k=1,3
1115         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1117      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1118         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1119      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1120      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1121       enddo
1122 C
1123 C Calculate the components of the gradient in DC and X
1124 C
1125       do k=i,j-1
1126         do l=1,3
1127           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128         enddo
1129       enddo
1130       return
1131       end
1132 c------------------------------------------------------------------------------
1133       subroutine vec_and_deriv
1134       implicit real*8 (a-h,o-z)
1135       include 'DIMENSIONS'
1136       include 'sizesclu.dat'
1137       include 'COMMON.IOUNITS'
1138       include 'COMMON.GEO'
1139       include 'COMMON.VAR'
1140       include 'COMMON.LOCAL'
1141       include 'COMMON.CHAIN'
1142       include 'COMMON.VECTORS'
1143       include 'COMMON.DERIV'
1144       include 'COMMON.INTERACT'
1145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1146 C Compute the local reference systems. For reference system (i), the
1147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1149       do i=1,nres-1
1150 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1151           if (i.eq.nres-1) then
1152 C Case of the last full residue
1153 C Compute the Z-axis
1154             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1155             costh=dcos(pi-theta(nres))
1156             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1157             do k=1,3
1158               uz(k,i)=fac*uz(k,i)
1159             enddo
1160             if (calc_grad) then
1161 C Compute the derivatives of uz
1162             uzder(1,1,1)= 0.0d0
1163             uzder(2,1,1)=-dc_norm(3,i-1)
1164             uzder(3,1,1)= dc_norm(2,i-1)
1165             uzder(1,2,1)= dc_norm(3,i-1)
1166             uzder(2,2,1)= 0.0d0
1167             uzder(3,2,1)=-dc_norm(1,i-1)
1168             uzder(1,3,1)=-dc_norm(2,i-1)
1169             uzder(2,3,1)= dc_norm(1,i-1)
1170             uzder(3,3,1)= 0.0d0
1171             uzder(1,1,2)= 0.0d0
1172             uzder(2,1,2)= dc_norm(3,i)
1173             uzder(3,1,2)=-dc_norm(2,i)
1174             uzder(1,2,2)=-dc_norm(3,i)
1175             uzder(2,2,2)= 0.0d0
1176             uzder(3,2,2)= dc_norm(1,i)
1177             uzder(1,3,2)= dc_norm(2,i)
1178             uzder(2,3,2)=-dc_norm(1,i)
1179             uzder(3,3,2)= 0.0d0
1180             endif
1181 C Compute the Y-axis
1182             facy=fac
1183             do k=1,3
1184               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1185             enddo
1186             if (calc_grad) then
1187 C Compute the derivatives of uy
1188             do j=1,3
1189               do k=1,3
1190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1193               enddo
1194               uyder(j,j,1)=uyder(j,j,1)-costh
1195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1196             enddo
1197             do j=1,2
1198               do k=1,3
1199                 do l=1,3
1200                   uygrad(l,k,j,i)=uyder(l,k,j)
1201                   uzgrad(l,k,j,i)=uzder(l,k,j)
1202                 enddo
1203               enddo
1204             enddo
1205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1209             endif
1210           else
1211 C Other residues
1212 C Compute the Z-axis
1213             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1214             costh=dcos(pi-theta(i+2))
1215             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1216             do k=1,3
1217               uz(k,i)=fac*uz(k,i)
1218             enddo
1219             if (calc_grad) then
1220 C Compute the derivatives of uz
1221             uzder(1,1,1)= 0.0d0
1222             uzder(2,1,1)=-dc_norm(3,i+1)
1223             uzder(3,1,1)= dc_norm(2,i+1)
1224             uzder(1,2,1)= dc_norm(3,i+1)
1225             uzder(2,2,1)= 0.0d0
1226             uzder(3,2,1)=-dc_norm(1,i+1)
1227             uzder(1,3,1)=-dc_norm(2,i+1)
1228             uzder(2,3,1)= dc_norm(1,i+1)
1229             uzder(3,3,1)= 0.0d0
1230             uzder(1,1,2)= 0.0d0
1231             uzder(2,1,2)= dc_norm(3,i)
1232             uzder(3,1,2)=-dc_norm(2,i)
1233             uzder(1,2,2)=-dc_norm(3,i)
1234             uzder(2,2,2)= 0.0d0
1235             uzder(3,2,2)= dc_norm(1,i)
1236             uzder(1,3,2)= dc_norm(2,i)
1237             uzder(2,3,2)=-dc_norm(1,i)
1238             uzder(3,3,2)= 0.0d0
1239             endif
1240 C Compute the Y-axis
1241             facy=fac
1242             do k=1,3
1243               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1244             enddo
1245             if (calc_grad) then
1246 C Compute the derivatives of uy
1247             do j=1,3
1248               do k=1,3
1249                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1250      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1251                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1252               enddo
1253               uyder(j,j,1)=uyder(j,j,1)-costh
1254               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1255             enddo
1256             do j=1,2
1257               do k=1,3
1258                 do l=1,3
1259                   uygrad(l,k,j,i)=uyder(l,k,j)
1260                   uzgrad(l,k,j,i)=uzder(l,k,j)
1261                 enddo
1262               enddo
1263             enddo
1264             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1265             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1266             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1267             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1268           endif
1269           endif
1270       enddo
1271       if (calc_grad) then
1272       do i=1,nres-1
1273         vbld_inv_temp(1)=vbld_inv(i+1)
1274         if (i.lt.nres-1) then
1275           vbld_inv_temp(2)=vbld_inv(i+2)
1276         else
1277           vbld_inv_temp(2)=vbld_inv(i)
1278         endif
1279         do j=1,2
1280           do k=1,3
1281             do l=1,3
1282               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1283               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1284             enddo
1285           enddo
1286         enddo
1287       enddo
1288       endif
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine vec_and_deriv_test
1293       implicit real*8 (a-h,o-z)
1294       include 'DIMENSIONS'
1295       include 'sizesclu.dat'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.VECTORS'
1302       dimension uyder(3,3,2),uzder(3,3,2)
1303 C Compute the local reference systems. For reference system (i), the
1304 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1305 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1306       do i=1,nres-1
1307           if (i.eq.nres-1) then
1308 C Case of the last full residue
1309 C Compute the Z-axis
1310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1311             costh=dcos(pi-theta(nres))
1312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1313 c            write (iout,*) 'fac',fac,
1314 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1315             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1316             do k=1,3
1317               uz(k,i)=fac*uz(k,i)
1318             enddo
1319 C Compute the derivatives of uz
1320             uzder(1,1,1)= 0.0d0
1321             uzder(2,1,1)=-dc_norm(3,i-1)
1322             uzder(3,1,1)= dc_norm(2,i-1)
1323             uzder(1,2,1)= dc_norm(3,i-1)
1324             uzder(2,2,1)= 0.0d0
1325             uzder(3,2,1)=-dc_norm(1,i-1)
1326             uzder(1,3,1)=-dc_norm(2,i-1)
1327             uzder(2,3,1)= dc_norm(1,i-1)
1328             uzder(3,3,1)= 0.0d0
1329             uzder(1,1,2)= 0.0d0
1330             uzder(2,1,2)= dc_norm(3,i)
1331             uzder(3,1,2)=-dc_norm(2,i)
1332             uzder(1,2,2)=-dc_norm(3,i)
1333             uzder(2,2,2)= 0.0d0
1334             uzder(3,2,2)= dc_norm(1,i)
1335             uzder(1,3,2)= dc_norm(2,i)
1336             uzder(2,3,2)=-dc_norm(1,i)
1337             uzder(3,3,2)= 0.0d0
1338 C Compute the Y-axis
1339             do k=1,3
1340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1341             enddo
1342             facy=fac
1343             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1344      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1345      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1346             do k=1,3
1347 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348               uy(k,i)=
1349 c     &        facy*(
1350      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1351      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1352 c     &        )
1353             enddo
1354 c            write (iout,*) 'facy',facy,
1355 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1356             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1357             do k=1,3
1358               uy(k,i)=facy*uy(k,i)
1359             enddo
1360 C Compute the derivatives of uy
1361             do j=1,3
1362               do k=1,3
1363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1366               enddo
1367 c              uyder(j,j,1)=uyder(j,j,1)-costh
1368 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1369               uyder(j,j,1)=uyder(j,j,1)
1370      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1371               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1372      &          +uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386           else
1387 C Other residues
1388 C Compute the Z-axis
1389             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1390             costh=dcos(pi-theta(i+2))
1391             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i+1)
1399             uzder(3,1,1)= dc_norm(2,i+1)
1400             uzder(1,2,1)= dc_norm(3,i+1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i+1)
1403             uzder(1,3,1)=-dc_norm(2,i+1)
1404             uzder(2,3,1)= dc_norm(1,i+1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             facy=fac
1417             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1418      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1419      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1420             do k=1,3
1421 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1422               uy(k,i)=
1423 c     &        facy*(
1424      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1425      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1426 c     &        )
1427             enddo
1428 c            write (iout,*) 'facy',facy,
1429 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1430             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1431             do k=1,3
1432               uy(k,i)=facy*uy(k,i)
1433             enddo
1434 C Compute the derivatives of uy
1435             do j=1,3
1436               do k=1,3
1437                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1438      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1439                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1440               enddo
1441 c              uyder(j,j,1)=uyder(j,j,1)-costh
1442 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1443               uyder(j,j,1)=uyder(j,j,1)
1444      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1445               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1446      &          +uyder(j,j,2)
1447             enddo
1448             do j=1,2
1449               do k=1,3
1450                 do l=1,3
1451                   uygrad(l,k,j,i)=uyder(l,k,j)
1452                   uzgrad(l,k,j,i)=uzder(l,k,j)
1453                 enddo
1454               enddo
1455             enddo
1456             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1457             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1458             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1459             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1460           endif
1461       enddo
1462       do i=1,nres-1
1463         do j=1,2
1464           do k=1,3
1465             do l=1,3
1466               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1467               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1468             enddo
1469           enddo
1470         enddo
1471       enddo
1472       return
1473       end
1474 C-----------------------------------------------------------------------------
1475       subroutine check_vecgrad
1476       implicit real*8 (a-h,o-z)
1477       include 'DIMENSIONS'
1478       include 'sizesclu.dat'
1479       include 'COMMON.IOUNITS'
1480       include 'COMMON.GEO'
1481       include 'COMMON.VAR'
1482       include 'COMMON.LOCAL'
1483       include 'COMMON.CHAIN'
1484       include 'COMMON.VECTORS'
1485       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1486       dimension uyt(3,maxres),uzt(3,maxres)
1487       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1488       double precision delta /1.0d-7/
1489       call vec_and_deriv
1490 cd      do i=1,nres
1491 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1492 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1493 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1494 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1495 cd     &     (dc_norm(if90,i),if90=1,3)
1496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1497 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1498 cd          write(iout,'(a)')
1499 cd      enddo
1500       do i=1,nres
1501         do j=1,2
1502           do k=1,3
1503             do l=1,3
1504               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1505               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1506             enddo
1507           enddo
1508         enddo
1509       enddo
1510       call vec_and_deriv
1511       do i=1,nres
1512         do j=1,3
1513           uyt(j,i)=uy(j,i)
1514           uzt(j,i)=uz(j,i)
1515         enddo
1516       enddo
1517       do i=1,nres
1518 cd        write (iout,*) 'i=',i
1519         do k=1,3
1520           erij(k)=dc_norm(k,i)
1521         enddo
1522         do j=1,3
1523           do k=1,3
1524             dc_norm(k,i)=erij(k)
1525           enddo
1526           dc_norm(j,i)=dc_norm(j,i)+delta
1527 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1528 c          do k=1,3
1529 c            dc_norm(k,i)=dc_norm(k,i)/fac
1530 c          enddo
1531 c          write (iout,*) (dc_norm(k,i),k=1,3)
1532 c          write (iout,*) (erij(k),k=1,3)
1533           call vec_and_deriv
1534           do k=1,3
1535             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1536             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1537             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1538             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1539           enddo
1540 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1541 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1542 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1543         enddo
1544         do k=1,3
1545           dc_norm(k,i)=erij(k)
1546         enddo
1547 cd        do k=1,3
1548 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1549 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1550 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1551 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1552 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1553 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1554 cd          write (iout,'(a)')
1555 cd        enddo
1556       enddo
1557       return
1558       end
1559 C--------------------------------------------------------------------------
1560       subroutine set_matrices
1561       implicit real*8 (a-h,o-z)
1562       include 'DIMENSIONS'
1563       include 'sizesclu.dat'
1564       include 'COMMON.IOUNITS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.CONTACTS'
1572       include 'COMMON.TORSION'
1573       include 'COMMON.VECTORS'
1574       include 'COMMON.FFIELD'
1575       double precision auxvec(2),auxmat(2,2)
1576 C
1577 C Compute the virtual-bond-torsional-angle dependent quantities needed
1578 C to calculate the el-loc multibody terms of various order.
1579 C
1580       do i=3,nres+1
1581         if (i .lt. nres+1) then
1582           sin1=dsin(phi(i))
1583           cos1=dcos(phi(i))
1584           sintab(i-2)=sin1
1585           costab(i-2)=cos1
1586           obrot(1,i-2)=cos1
1587           obrot(2,i-2)=sin1
1588           sin2=dsin(2*phi(i))
1589           cos2=dcos(2*phi(i))
1590           sintab2(i-2)=sin2
1591           costab2(i-2)=cos2
1592           obrot2(1,i-2)=cos2
1593           obrot2(2,i-2)=sin2
1594           Ug(1,1,i-2)=-cos1
1595           Ug(1,2,i-2)=-sin1
1596           Ug(2,1,i-2)=-sin1
1597           Ug(2,2,i-2)= cos1
1598           Ug2(1,1,i-2)=-cos2
1599           Ug2(1,2,i-2)=-sin2
1600           Ug2(2,1,i-2)=-sin2
1601           Ug2(2,2,i-2)= cos2
1602         else
1603           costab(i-2)=1.0d0
1604           sintab(i-2)=0.0d0
1605           obrot(1,i-2)=1.0d0
1606           obrot(2,i-2)=0.0d0
1607           obrot2(1,i-2)=0.0d0
1608           obrot2(2,i-2)=0.0d0
1609           Ug(1,1,i-2)=1.0d0
1610           Ug(1,2,i-2)=0.0d0
1611           Ug(2,1,i-2)=0.0d0
1612           Ug(2,2,i-2)=1.0d0
1613           Ug2(1,1,i-2)=0.0d0
1614           Ug2(1,2,i-2)=0.0d0
1615           Ug2(2,1,i-2)=0.0d0
1616           Ug2(2,2,i-2)=0.0d0
1617         endif
1618         if (i .gt. 3 .and. i .lt. nres+1) then
1619           obrot_der(1,i-2)=-sin1
1620           obrot_der(2,i-2)= cos1
1621           Ugder(1,1,i-2)= sin1
1622           Ugder(1,2,i-2)=-cos1
1623           Ugder(2,1,i-2)=-cos1
1624           Ugder(2,2,i-2)=-sin1
1625           dwacos2=cos2+cos2
1626           dwasin2=sin2+sin2
1627           obrot2_der(1,i-2)=-dwasin2
1628           obrot2_der(2,i-2)= dwacos2
1629           Ug2der(1,1,i-2)= dwasin2
1630           Ug2der(1,2,i-2)=-dwacos2
1631           Ug2der(2,1,i-2)=-dwacos2
1632           Ug2der(2,2,i-2)=-dwasin2
1633         else
1634           obrot_der(1,i-2)=0.0d0
1635           obrot_der(2,i-2)=0.0d0
1636           Ugder(1,1,i-2)=0.0d0
1637           Ugder(1,2,i-2)=0.0d0
1638           Ugder(2,1,i-2)=0.0d0
1639           Ugder(2,2,i-2)=0.0d0
1640           obrot2_der(1,i-2)=0.0d0
1641           obrot2_der(2,i-2)=0.0d0
1642           Ug2der(1,1,i-2)=0.0d0
1643           Ug2der(1,2,i-2)=0.0d0
1644           Ug2der(2,1,i-2)=0.0d0
1645           Ug2der(2,2,i-2)=0.0d0
1646         endif
1647         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1648           iti = itortyp(itype(i-2))
1649         else
1650           iti=ntortyp+1
1651         endif
1652         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1653           iti1 = itortyp(itype(i-1))
1654         else
1655           iti1=ntortyp+1
1656         endif
1657 cd        write (iout,*) '*******i',i,' iti1',iti
1658 cd        write (iout,*) 'b1',b1(:,iti)
1659 cd        write (iout,*) 'b2',b2(:,iti)
1660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1661         if (i .gt. iatel_s+2) then
1662           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1663           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1664           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1665           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1666           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1667           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1668           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1669         else
1670           do k=1,2
1671             Ub2(k,i-2)=0.0d0
1672             Ctobr(k,i-2)=0.0d0
1673             Dtobr2(k,i-2)=0.0d0
1674             do l=1,2
1675               EUg(l,k,i-2)=0.0d0
1676               CUg(l,k,i-2)=0.0d0
1677               DUg(l,k,i-2)=0.0d0
1678               DtUg2(l,k,i-2)=0.0d0
1679             enddo
1680           enddo
1681         endif
1682         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1683         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1684         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1685         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1686         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1687         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1688         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1689         do k=1,2
1690           muder(k,i-2)=Ub2der(k,i-2)
1691         enddo
1692         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1693           iti1 = itortyp(itype(i-1))
1694         else
1695           iti1=ntortyp+1
1696         endif
1697         do k=1,2
1698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1699         enddo
1700 C Vectors and matrices dependent on a single virtual-bond dihedral.
1701         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1702         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1703         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1704         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1705         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1706         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1707         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1708         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1709         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1710 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1711 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1712       enddo
1713 C Matrices dependent on two consecutive virtual-bond dihedrals.
1714 C The order of matrices is from left to right.
1715       do i=2,nres-1
1716         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1717         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1718         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1719         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1720         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1721         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1722         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1723         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1724       enddo
1725 cd      do i=1,nres
1726 cd        iti = itortyp(itype(i))
1727 cd        write (iout,*) i
1728 cd        do j=1,2
1729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1731 cd        enddo
1732 cd      enddo
1733       return
1734       end
1735 C--------------------------------------------------------------------------
1736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1737 C
1738 C This subroutine calculates the average interaction energy and its gradient
1739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1741 C The potential depends both on the distance of peptide-group centers and on
1742 C the orientation of the CA-CA virtual bonds.
1743 C
1744       implicit real*8 (a-h,o-z)
1745       include 'DIMENSIONS'
1746       include 'sizesclu.dat'
1747       include 'COMMON.CONTROL'
1748       include 'COMMON.IOUNITS'
1749       include 'COMMON.GEO'
1750       include 'COMMON.VAR'
1751       include 'COMMON.LOCAL'
1752       include 'COMMON.CHAIN'
1753       include 'COMMON.DERIV'
1754       include 'COMMON.INTERACT'
1755       include 'COMMON.CONTACTS'
1756       include 'COMMON.TORSION'
1757       include 'COMMON.VECTORS'
1758       include 'COMMON.FFIELD'
1759       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1760      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1761       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1765       double precision scal_el /0.5d0/
1766 C 12/13/98
1767 C 13-go grudnia roku pamietnego...
1768       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1769      &                   0.0d0,1.0d0,0.0d0,
1770      &                   0.0d0,0.0d0,1.0d0/
1771 cd      write(iout,*) 'In EELEC'
1772 cd      do i=1,nloctyp
1773 cd        write(iout,*) 'Type',i
1774 cd        write(iout,*) 'B1',B1(:,i)
1775 cd        write(iout,*) 'B2',B2(:,i)
1776 cd        write(iout,*) 'CC',CC(:,:,i)
1777 cd        write(iout,*) 'DD',DD(:,:,i)
1778 cd        write(iout,*) 'EE',EE(:,:,i)
1779 cd      enddo
1780 cd      call check_vecgrad
1781 cd      stop
1782       if (icheckgrad.eq.1) then
1783         do i=1,nres-1
1784           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1785           do k=1,3
1786             dc_norm(k,i)=dc(k,i)*fac
1787           enddo
1788 c          write (iout,*) 'i',i,' fac',fac
1789         enddo
1790       endif
1791       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1792      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1793      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1794 cd      if (wel_loc.gt.0.0d0) then
1795         if (icheckgrad.eq.1) then
1796         call vec_and_deriv_test
1797         else
1798         call vec_and_deriv
1799         endif
1800         call set_matrices
1801       endif
1802 cd      do i=1,nres-1
1803 cd        write (iout,*) 'i=',i
1804 cd        do k=1,3
1805 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1806 cd        enddo
1807 cd        do k=1,3
1808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1810 cd        enddo
1811 cd      enddo
1812       num_conti_hb=0
1813       ees=0.0D0
1814       evdw1=0.0D0
1815       eel_loc=0.0d0
1816       eello_turn3=0.0d0
1817       eello_turn4=0.0d0
1818       ind=0
1819       do i=1,nres
1820         num_cont_hb(i)=0
1821       enddo
1822 cd      print '(a)','Enter EELEC'
1823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1824       do i=1,nres
1825         gel_loc_loc(i)=0.0d0
1826         gcorr_loc(i)=0.0d0
1827       enddo
1828       do i=iatel_s,iatel_e
1829         if (itel(i).eq.0) goto 1215
1830         dxi=dc(1,i)
1831         dyi=dc(2,i)
1832         dzi=dc(3,i)
1833         dx_normi=dc_norm(1,i)
1834         dy_normi=dc_norm(2,i)
1835         dz_normi=dc_norm(3,i)
1836         xmedi=c(1,i)+0.5d0*dxi
1837         ymedi=c(2,i)+0.5d0*dyi
1838         zmedi=c(3,i)+0.5d0*dzi
1839         num_conti=0
1840 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1841         do j=ielstart(i),ielend(i)
1842           if (itel(j).eq.0) goto 1216
1843           ind=ind+1
1844           iteli=itel(i)
1845           itelj=itel(j)
1846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1847           aaa=app(iteli,itelj)
1848           bbb=bpp(iteli,itelj)
1849 C Diagnostics only!!!
1850 c         aaa=0.0D0
1851 c         bbb=0.0D0
1852 c         ael6i=0.0D0
1853 c         ael3i=0.0D0
1854 C End diagnostics
1855           ael6i=ael6(iteli,itelj)
1856           ael3i=ael3(iteli,itelj)
1857           dxj=dc(1,j)
1858           dyj=dc(2,j)
1859           dzj=dc(3,j)
1860           dx_normj=dc_norm(1,j)
1861           dy_normj=dc_norm(2,j)
1862           dz_normj=dc_norm(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           rrmij=1.0D0/rij
1868           rij=dsqrt(rij)
1869           rmij=1.0D0/rij
1870           r3ij=rrmij*rmij
1871           r6ij=r3ij*r3ij
1872           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1873           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1874           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1875           fac=cosa-3.0D0*cosb*cosg
1876           ev1=aaa*r6ij*r6ij
1877 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1878           if (j.eq.i+2) ev1=scal_el*ev1
1879           ev2=bbb*r6ij
1880           fac3=ael6i*r6ij
1881           fac4=ael3i*r3ij
1882           evdwij=ev1+ev2
1883           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1884           el2=fac4*fac
1885           eesij=el1+el2
1886 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1887 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1888           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1889           ees=ees+eesij
1890           evdw1=evdw1+evdwij
1891 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1892 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1893 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1894 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1895 C
1896 C Calculate contributions to the Cartesian gradient.
1897 C
1898 #ifdef SPLITELE
1899           facvdw=-6*rrmij*(ev1+evdwij)
1900           facel=-3*rrmij*(el1+eesij)
1901           fac1=fac
1902           erij(1)=xj*rmij
1903           erij(2)=yj*rmij
1904           erij(3)=zj*rmij
1905           if (calc_grad) then
1906 *
1907 * Radial derivatives. First process both termini of the fragment (i,j)
1908 *
1909           ggg(1)=facel*xj
1910           ggg(2)=facel*yj
1911           ggg(3)=facel*zj
1912           do k=1,3
1913             ghalf=0.5D0*ggg(k)
1914             gelc(k,i)=gelc(k,i)+ghalf
1915             gelc(k,j)=gelc(k,j)+ghalf
1916           enddo
1917 *
1918 * Loop over residues i+1 thru j-1.
1919 *
1920           do k=i+1,j-1
1921             do l=1,3
1922               gelc(l,k)=gelc(l,k)+ggg(l)
1923             enddo
1924           enddo
1925           ggg(1)=facvdw*xj
1926           ggg(2)=facvdw*yj
1927           ggg(3)=facvdw*zj
1928           do k=1,3
1929             ghalf=0.5D0*ggg(k)
1930             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1931             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1932           enddo
1933 *
1934 * Loop over residues i+1 thru j-1.
1935 *
1936           do k=i+1,j-1
1937             do l=1,3
1938               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1939             enddo
1940           enddo
1941 #else
1942           facvdw=ev1+evdwij
1943           facel=el1+eesij
1944           fac1=fac
1945           fac=-3*rrmij*(facvdw+facvdw+facel)
1946           erij(1)=xj*rmij
1947           erij(2)=yj*rmij
1948           erij(3)=zj*rmij
1949           if (calc_grad) then
1950 *
1951 * Radial derivatives. First process both termini of the fragment (i,j)
1952 *
1953           ggg(1)=fac*xj
1954           ggg(2)=fac*yj
1955           ggg(3)=fac*zj
1956           do k=1,3
1957             ghalf=0.5D0*ggg(k)
1958             gelc(k,i)=gelc(k,i)+ghalf
1959             gelc(k,j)=gelc(k,j)+ghalf
1960           enddo
1961 *
1962 * Loop over residues i+1 thru j-1.
1963 *
1964           do k=i+1,j-1
1965             do l=1,3
1966               gelc(l,k)=gelc(l,k)+ggg(l)
1967             enddo
1968           enddo
1969 #endif
1970 *
1971 * Angular part
1972 *
1973           ecosa=2.0D0*fac3*fac1+fac4
1974           fac4=-3.0D0*fac4
1975           fac3=-6.0D0*fac3
1976           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1977           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1978           do k=1,3
1979             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1980             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1981           enddo
1982 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1983 cd   &          (dcosg(k),k=1,3)
1984           do k=1,3
1985             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1986           enddo
1987           do k=1,3
1988             ghalf=0.5D0*ggg(k)
1989             gelc(k,i)=gelc(k,i)+ghalf
1990      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1991      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1992             gelc(k,j)=gelc(k,j)+ghalf
1993      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1994      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1995           enddo
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           endif
2002
2003           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2004      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2005      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2006 C
2007 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2008 C   energy of a peptide unit is assumed in the form of a second-order
2009 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2010 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2011 C   are computed for EVERY pair of non-contiguous peptide groups.
2012 C
2013           if (j.lt.nres-1) then
2014             j1=j+1
2015             j2=j-1
2016           else
2017             j1=j-1
2018             j2=j-2
2019           endif
2020           kkk=0
2021           do k=1,2
2022             do l=1,2
2023               kkk=kkk+1
2024               muij(kkk)=mu(k,i)*mu(l,j)
2025             enddo
2026           enddo
2027 cd         write (iout,*) 'EELEC: i',i,' j',j
2028 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2029 cd          write(iout,*) 'muij',muij
2030           ury=scalar(uy(1,i),erij)
2031           urz=scalar(uz(1,i),erij)
2032           vry=scalar(uy(1,j),erij)
2033           vrz=scalar(uz(1,j),erij)
2034           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2035           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2036           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2037           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2038 C For diagnostics only
2039 cd          a22=1.0d0
2040 cd          a23=1.0d0
2041 cd          a32=1.0d0
2042 cd          a33=1.0d0
2043           fac=dsqrt(-ael6i)*r3ij
2044 cd          write (2,*) 'fac=',fac
2045 C For diagnostics only
2046 cd          fac=1.0d0
2047           a22=a22*fac
2048           a23=a23*fac
2049           a32=a32*fac
2050           a33=a33*fac
2051 cd          write (iout,'(4i5,4f10.5)')
2052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2055 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2056 cd          write (iout,'(4f10.5)')
2057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2060 cd           write (iout,'(2i3,9f10.5/)') i,j,
2061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2062           if (calc_grad) then
2063 C Derivatives of the elements of A in virtual-bond vectors
2064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2065 cd          do k=1,3
2066 cd            do l=1,3
2067 cd              erder(k,l)=0.0d0
2068 cd            enddo
2069 cd          enddo
2070           do k=1,3
2071             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2072             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2073             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2074             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2075             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2076             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2077             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2078             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2079             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2080             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2081             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2082             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2083           enddo
2084 cd          do k=1,3
2085 cd            do l=1,3
2086 cd              uryg(k,l)=0.0d0
2087 cd              urzg(k,l)=0.0d0
2088 cd              vryg(k,l)=0.0d0
2089 cd              vrzg(k,l)=0.0d0
2090 cd            enddo
2091 cd          enddo
2092 C Compute radial contributions to the gradient
2093           facr=-3.0d0*rrmij
2094           a22der=a22*facr
2095           a23der=a23*facr
2096           a32der=a32*facr
2097           a33der=a33*facr
2098 cd          a22der=0.0d0
2099 cd          a23der=0.0d0
2100 cd          a32der=0.0d0
2101 cd          a33der=0.0d0
2102           agg(1,1)=a22der*xj
2103           agg(2,1)=a22der*yj
2104           agg(3,1)=a22der*zj
2105           agg(1,2)=a23der*xj
2106           agg(2,2)=a23der*yj
2107           agg(3,2)=a23der*zj
2108           agg(1,3)=a32der*xj
2109           agg(2,3)=a32der*yj
2110           agg(3,3)=a32der*zj
2111           agg(1,4)=a33der*xj
2112           agg(2,4)=a33der*yj
2113           agg(3,4)=a33der*zj
2114 C Add the contributions coming from er
2115           fac3=-3.0d0*fac
2116           do k=1,3
2117             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2118             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2119             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2120             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2121           enddo
2122           do k=1,3
2123 C Derivatives in DC(i)
2124             ghalf1=0.5d0*agg(k,1)
2125             ghalf2=0.5d0*agg(k,2)
2126             ghalf3=0.5d0*agg(k,3)
2127             ghalf4=0.5d0*agg(k,4)
2128             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2129      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2130             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2131      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2132             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2133      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2134             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2135      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2136 C Derivatives in DC(i+1)
2137             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2138      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2139             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2140      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2141             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2142      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2143             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2144      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2145 C Derivatives in DC(j)
2146             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2147      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2148             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2149      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2150             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2151      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2152             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2153      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2154 C Derivatives in DC(j+1) or DC(nres-1)
2155             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2156      &      -3.0d0*vryg(k,3)*ury)
2157             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2158      &      -3.0d0*vrzg(k,3)*ury)
2159             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2160      &      -3.0d0*vryg(k,3)*urz)
2161             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2162      &      -3.0d0*vrzg(k,3)*urz)
2163 cd            aggi(k,1)=ghalf1
2164 cd            aggi(k,2)=ghalf2
2165 cd            aggi(k,3)=ghalf3
2166 cd            aggi(k,4)=ghalf4
2167 C Derivatives in DC(i+1)
2168 cd            aggi1(k,1)=agg(k,1)
2169 cd            aggi1(k,2)=agg(k,2)
2170 cd            aggi1(k,3)=agg(k,3)
2171 cd            aggi1(k,4)=agg(k,4)
2172 C Derivatives in DC(j)
2173 cd            aggj(k,1)=ghalf1
2174 cd            aggj(k,2)=ghalf2
2175 cd            aggj(k,3)=ghalf3
2176 cd            aggj(k,4)=ghalf4
2177 C Derivatives in DC(j+1)
2178 cd            aggj1(k,1)=0.0d0
2179 cd            aggj1(k,2)=0.0d0
2180 cd            aggj1(k,3)=0.0d0
2181 cd            aggj1(k,4)=0.0d0
2182             if (j.eq.nres-1 .and. i.lt.j-2) then
2183               do l=1,4
2184                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2185 cd                aggj1(k,l)=agg(k,l)
2186               enddo
2187             endif
2188           enddo
2189           endif
2190 c          goto 11111
2191 C Check the loc-el terms by numerical integration
2192           acipa(1,1)=a22
2193           acipa(1,2)=a23
2194           acipa(2,1)=a32
2195           acipa(2,2)=a33
2196           a22=-a22
2197           a23=-a23
2198           do l=1,2
2199             do k=1,3
2200               agg(k,l)=-agg(k,l)
2201               aggi(k,l)=-aggi(k,l)
2202               aggi1(k,l)=-aggi1(k,l)
2203               aggj(k,l)=-aggj(k,l)
2204               aggj1(k,l)=-aggj1(k,l)
2205             enddo
2206           enddo
2207           if (j.lt.nres-1) then
2208             a22=-a22
2209             a32=-a32
2210             do l=1,3,2
2211               do k=1,3
2212                 agg(k,l)=-agg(k,l)
2213                 aggi(k,l)=-aggi(k,l)
2214                 aggi1(k,l)=-aggi1(k,l)
2215                 aggj(k,l)=-aggj(k,l)
2216                 aggj1(k,l)=-aggj1(k,l)
2217               enddo
2218             enddo
2219           else
2220             a22=-a22
2221             a23=-a23
2222             a32=-a32
2223             a33=-a33
2224             do l=1,4
2225               do k=1,3
2226                 agg(k,l)=-agg(k,l)
2227                 aggi(k,l)=-aggi(k,l)
2228                 aggi1(k,l)=-aggi1(k,l)
2229                 aggj(k,l)=-aggj(k,l)
2230                 aggj1(k,l)=-aggj1(k,l)
2231               enddo
2232             enddo
2233           endif
2234           ENDIF ! WCORR
2235 11111     continue
2236           IF (wel_loc.gt.0.0d0) THEN
2237 C Contribution to the local-electrostatic energy coming from the i-j pair
2238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2239      &     +a33*muij(4)
2240 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2241 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2242           eel_loc=eel_loc+eel_loc_ij
2243 C Partial derivatives in virtual-bond dihedral angles gamma
2244           if (calc_grad) then
2245           if (i.gt.1)
2246      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2247      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2248      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2249           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2250      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2251      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2252 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2253 cd          write(iout,*) 'agg  ',agg
2254 cd          write(iout,*) 'aggi ',aggi
2255 cd          write(iout,*) 'aggi1',aggi1
2256 cd          write(iout,*) 'aggj ',aggj
2257 cd          write(iout,*) 'aggj1',aggj1
2258
2259 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2260           do l=1,3
2261             ggg(l)=agg(l,1)*muij(1)+
2262      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2263           enddo
2264           do k=i+2,j2
2265             do l=1,3
2266               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2267             enddo
2268           enddo
2269 C Remaining derivatives of eello
2270           do l=1,3
2271             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2272      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2273             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2274      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2275             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2276      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2277             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2278      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2279           enddo
2280           endif
2281           ENDIF
2282           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2283 C Contributions from turns
2284             a_temp(1,1)=a22
2285             a_temp(1,2)=a23
2286             a_temp(2,1)=a32
2287             a_temp(2,2)=a33
2288             call eturn34(i,j,eello_turn3,eello_turn4)
2289           endif
2290 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2291           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2292 C
2293 C Calculate the contact function. The ith column of the array JCONT will
2294 C contain the numbers of atoms that make contacts with the atom I (of numbers
2295 C greater than I). The arrays FACONT and GACONT will contain the values of
2296 C the contact function and its derivative.
2297 c           r0ij=1.02D0*rpp(iteli,itelj)
2298 c           r0ij=1.11D0*rpp(iteli,itelj)
2299             r0ij=2.20D0*rpp(iteli,itelj)
2300 c           r0ij=1.55D0*rpp(iteli,itelj)
2301             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2302             if (fcont.gt.0.0D0) then
2303               num_conti=num_conti+1
2304               if (num_conti.gt.maxconts) then
2305                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2306      &                         ' will skip next contacts for this conf.'
2307               else
2308                 jcont_hb(num_conti,i)=j
2309                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2310      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2311 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2312 C  terms.
2313                 d_cont(num_conti,i)=rij
2314 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2315 C     --- Electrostatic-interaction matrix ---
2316                 a_chuj(1,1,num_conti,i)=a22
2317                 a_chuj(1,2,num_conti,i)=a23
2318                 a_chuj(2,1,num_conti,i)=a32
2319                 a_chuj(2,2,num_conti,i)=a33
2320 C     --- Gradient of rij
2321                 do kkk=1,3
2322                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2323                 enddo
2324 c             if (i.eq.1) then
2325 c                a_chuj(1,1,num_conti,i)=-0.61d0
2326 c                a_chuj(1,2,num_conti,i)= 0.4d0
2327 c                a_chuj(2,1,num_conti,i)= 0.65d0
2328 c                a_chuj(2,2,num_conti,i)= 0.50d0
2329 c             else if (i.eq.2) then
2330 c                a_chuj(1,1,num_conti,i)= 0.0d0
2331 c                a_chuj(1,2,num_conti,i)= 0.0d0
2332 c                a_chuj(2,1,num_conti,i)= 0.0d0
2333 c                a_chuj(2,2,num_conti,i)= 0.0d0
2334 c             endif
2335 C     --- and its gradients
2336 cd                write (iout,*) 'i',i,' j',j
2337 cd                do kkk=1,3
2338 cd                write (iout,*) 'iii 1 kkk',kkk
2339 cd                write (iout,*) agg(kkk,:)
2340 cd                enddo
2341 cd                do kkk=1,3
2342 cd                write (iout,*) 'iii 2 kkk',kkk
2343 cd                write (iout,*) aggi(kkk,:)
2344 cd                enddo
2345 cd                do kkk=1,3
2346 cd                write (iout,*) 'iii 3 kkk',kkk
2347 cd                write (iout,*) aggi1(kkk,:)
2348 cd                enddo
2349 cd                do kkk=1,3
2350 cd                write (iout,*) 'iii 4 kkk',kkk
2351 cd                write (iout,*) aggj(kkk,:)
2352 cd                enddo
2353 cd                do kkk=1,3
2354 cd                write (iout,*) 'iii 5 kkk',kkk
2355 cd                write (iout,*) aggj1(kkk,:)
2356 cd                enddo
2357                 kkll=0
2358                 do k=1,2
2359                   do l=1,2
2360                     kkll=kkll+1
2361                     do m=1,3
2362                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2363                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2364                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2365                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2366                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2367 c                      do mm=1,5
2368 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2369 c                      enddo
2370                     enddo
2371                   enddo
2372                 enddo
2373                 ENDIF
2374                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2375 C Calculate contact energies
2376                 cosa4=4.0D0*cosa
2377                 wij=cosa-3.0D0*cosb*cosg
2378                 cosbg1=cosb+cosg
2379                 cosbg2=cosb-cosg
2380 c               fac3=dsqrt(-ael6i)/r0ij**3
2381                 fac3=dsqrt(-ael6i)*r3ij
2382                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2383                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2384 c               ees0mij=0.0D0
2385                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2386                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2387 C Diagnostics. Comment out or remove after debugging!
2388 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2389 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2390 c               ees0m(num_conti,i)=0.0D0
2391 C End diagnostics.
2392 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2393 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2394                 facont_hb(num_conti,i)=fcont
2395                 if (calc_grad) then
2396 C Angular derivatives of the contact function
2397                 ees0pij1=fac3/ees0pij
2398                 ees0mij1=fac3/ees0mij
2399                 fac3p=-3.0D0*fac3*rrmij
2400                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2401                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2402 c               ees0mij1=0.0D0
2403                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2404                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2405                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2406                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2407                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2408                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2409                 ecosap=ecosa1+ecosa2
2410                 ecosbp=ecosb1+ecosb2
2411                 ecosgp=ecosg1+ecosg2
2412                 ecosam=ecosa1-ecosa2
2413                 ecosbm=ecosb1-ecosb2
2414                 ecosgm=ecosg1-ecosg2
2415 C Diagnostics
2416 c               ecosap=ecosa1
2417 c               ecosbp=ecosb1
2418 c               ecosgp=ecosg1
2419 c               ecosam=0.0D0
2420 c               ecosbm=0.0D0
2421 c               ecosgm=0.0D0
2422 C End diagnostics
2423                 fprimcont=fprimcont/rij
2424 cd              facont_hb(num_conti,i)=1.0D0
2425 C Following line is for diagnostics.
2426 cd              fprimcont=0.0D0
2427                 do k=1,3
2428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2430                 enddo
2431                 do k=1,3
2432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2434                 enddo
2435                 gggp(1)=gggp(1)+ees0pijp*xj
2436                 gggp(2)=gggp(2)+ees0pijp*yj
2437                 gggp(3)=gggp(3)+ees0pijp*zj
2438                 gggm(1)=gggm(1)+ees0mijp*xj
2439                 gggm(2)=gggm(2)+ees0mijp*yj
2440                 gggm(3)=gggm(3)+ees0mijp*zj
2441 C Derivatives due to the contact function
2442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2445                 do k=1,3
2446                   ghalfp=0.5D0*gggp(k)
2447                   ghalfm=0.5D0*gggm(k)
2448                   gacontp_hb1(k,num_conti,i)=ghalfp
2449      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2450      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2451                   gacontp_hb2(k,num_conti,i)=ghalfp
2452      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2453      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2454                   gacontp_hb3(k,num_conti,i)=gggp(k)
2455                   gacontm_hb1(k,num_conti,i)=ghalfm
2456      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2457      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2458                   gacontm_hb2(k,num_conti,i)=ghalfm
2459      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2460      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2461                   gacontm_hb3(k,num_conti,i)=gggm(k)
2462                 enddo
2463                 endif
2464 C Diagnostics. Comment out or remove after debugging!
2465 cdiag           do k=1,3
2466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2472 cdiag           enddo
2473               ENDIF ! wcorr
2474               endif  ! num_conti.le.maxconts
2475             endif  ! fcont.gt.0
2476           endif    ! j.gt.i+1
2477  1216     continue
2478         enddo ! j
2479         num_cont_hb(i)=num_conti
2480  1215   continue
2481       enddo   ! i
2482 cd      do i=1,nres
2483 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2484 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2485 cd      enddo
2486 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2487 ccc      eel_loc=eel_loc+eello_turn3
2488       return
2489       end
2490 C-----------------------------------------------------------------------------
2491       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2492 C Third- and fourth-order contributions from turns
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'sizesclu.dat'
2496       include 'COMMON.IOUNITS'
2497       include 'COMMON.GEO'
2498       include 'COMMON.VAR'
2499       include 'COMMON.LOCAL'
2500       include 'COMMON.CHAIN'
2501       include 'COMMON.DERIV'
2502       include 'COMMON.INTERACT'
2503       include 'COMMON.CONTACTS'
2504       include 'COMMON.TORSION'
2505       include 'COMMON.VECTORS'
2506       include 'COMMON.FFIELD'
2507       dimension ggg(3)
2508       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2509      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2510      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2511       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2512      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2514       if (j.eq.i+2) then
2515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2516 C
2517 C               Third-order contributions
2518 C
2519 C                 (i+2)o----(i+3)
2520 C                      | |
2521 C                      | |
2522 C                 (i+1)o----i
2523 C
2524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2525 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2526         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2527         call transpose2(auxmat(1,1),auxmat1(1,1))
2528         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2529         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2530 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2531 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2532 cd     &    ' eello_turn3_num',4*eello_turn3_num
2533         if (calc_grad) then
2534 C Derivatives in gamma(i)
2535         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2536         call transpose2(auxmat2(1,1),pizda(1,1))
2537         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2538         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2539 C Derivatives in gamma(i+1)
2540         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2541         call transpose2(auxmat2(1,1),pizda(1,1))
2542         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2543         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2544      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2545 C Cartesian derivatives
2546         do l=1,3
2547           a_temp(1,1)=aggi(l,1)
2548           a_temp(1,2)=aggi(l,2)
2549           a_temp(2,1)=aggi(l,3)
2550           a_temp(2,2)=aggi(l,4)
2551           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2552           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2553      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2554           a_temp(1,1)=aggi1(l,1)
2555           a_temp(1,2)=aggi1(l,2)
2556           a_temp(2,1)=aggi1(l,3)
2557           a_temp(2,2)=aggi1(l,4)
2558           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2559           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2560      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2561           a_temp(1,1)=aggj(l,1)
2562           a_temp(1,2)=aggj(l,2)
2563           a_temp(2,1)=aggj(l,3)
2564           a_temp(2,2)=aggj(l,4)
2565           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2566           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2567      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2568           a_temp(1,1)=aggj1(l,1)
2569           a_temp(1,2)=aggj1(l,2)
2570           a_temp(2,1)=aggj1(l,3)
2571           a_temp(2,2)=aggj1(l,4)
2572           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2573           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2574      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2575         enddo
2576         endif
2577       else if (j.eq.i+3) then
2578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2579 C
2580 C               Fourth-order contributions
2581 C
2582 C                 (i+3)o----(i+4)
2583 C                     /  |
2584 C               (i+2)o   |
2585 C                     \  |
2586 C                 (i+1)o----i
2587 C
2588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2589 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2590         iti1=itortyp(itype(i+1))
2591         iti2=itortyp(itype(i+2))
2592         iti3=itortyp(itype(i+3))
2593         call transpose2(EUg(1,1,i+1),e1t(1,1))
2594         call transpose2(Eug(1,1,i+2),e2t(1,1))
2595         call transpose2(Eug(1,1,i+3),e3t(1,1))
2596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2597         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2598         s1=scalar2(b1(1,iti2),auxvec(1))
2599         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2601         s2=scalar2(b1(1,iti1),auxvec(1))
2602         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2603         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2604         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2605         eello_turn4=eello_turn4-(s1+s2+s3)
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2607 cd     &    ' eello_turn4_num',8*eello_turn4_num
2608 C Derivatives in gamma(i)
2609         if (calc_grad) then
2610         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2611         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2613         s1=scalar2(b1(1,iti2),auxvec(1))
2614         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2615         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2617 C Derivatives in gamma(i+1)
2618         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2619         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2620         s2=scalar2(b1(1,iti1),auxvec(1))
2621         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2622         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2623         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2624         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2625 C Derivatives in gamma(i+2)
2626         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2627         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2628         s1=scalar2(b1(1,iti2),auxvec(1))
2629         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2631         s2=scalar2(b1(1,iti1),auxvec(1))
2632         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2633         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2634         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2636 C Cartesian derivatives
2637 C Derivatives of this turn contributions in DC(i+2)
2638         if (j.lt.nres-1) then
2639           do l=1,3
2640             a_temp(1,1)=agg(l,1)
2641             a_temp(1,2)=agg(l,2)
2642             a_temp(2,1)=agg(l,3)
2643             a_temp(2,2)=agg(l,4)
2644             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2645             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2646             s1=scalar2(b1(1,iti2),auxvec(1))
2647             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2648             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2649             s2=scalar2(b1(1,iti1),auxvec(1))
2650             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2651             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2652             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653             ggg(l)=-(s1+s2+s3)
2654             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2655           enddo
2656         endif
2657 C Remaining derivatives of this turn contribution
2658         do l=1,3
2659           a_temp(1,1)=aggi(l,1)
2660           a_temp(1,2)=aggi(l,2)
2661           a_temp(2,1)=aggi(l,3)
2662           a_temp(2,2)=aggi(l,4)
2663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2665           s1=scalar2(b1(1,iti2),auxvec(1))
2666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2668           s2=scalar2(b1(1,iti1),auxvec(1))
2669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2672           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2673           a_temp(1,1)=aggi1(l,1)
2674           a_temp(1,2)=aggi1(l,2)
2675           a_temp(2,1)=aggi1(l,3)
2676           a_temp(2,2)=aggi1(l,4)
2677           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2678           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2679           s1=scalar2(b1(1,iti2),auxvec(1))
2680           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2681           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2682           s2=scalar2(b1(1,iti1),auxvec(1))
2683           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2684           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2685           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2686           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2687           a_temp(1,1)=aggj(l,1)
2688           a_temp(1,2)=aggj(l,2)
2689           a_temp(2,1)=aggj(l,3)
2690           a_temp(2,2)=aggj(l,4)
2691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2693           s1=scalar2(b1(1,iti2),auxvec(1))
2694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2696           s2=scalar2(b1(1,iti1),auxvec(1))
2697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2701           a_temp(1,1)=aggj1(l,1)
2702           a_temp(1,2)=aggj1(l,2)
2703           a_temp(2,1)=aggj1(l,3)
2704           a_temp(2,2)=aggj1(l,4)
2705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2707           s1=scalar2(b1(1,iti2),auxvec(1))
2708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2710           s2=scalar2(b1(1,iti1),auxvec(1))
2711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2714           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2715         enddo
2716         endif
2717       endif
2718       return
2719       end
2720 C-----------------------------------------------------------------------------
2721       subroutine vecpr(u,v,w)
2722       implicit real*8(a-h,o-z)
2723       dimension u(3),v(3),w(3)
2724       w(1)=u(2)*v(3)-u(3)*v(2)
2725       w(2)=-u(1)*v(3)+u(3)*v(1)
2726       w(3)=u(1)*v(2)-u(2)*v(1)
2727       return
2728       end
2729 C-----------------------------------------------------------------------------
2730       subroutine unormderiv(u,ugrad,unorm,ungrad)
2731 C This subroutine computes the derivatives of a normalized vector u, given
2732 C the derivatives computed without normalization conditions, ugrad. Returns
2733 C ungrad.
2734       implicit none
2735       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2736       double precision vec(3)
2737       double precision scalar
2738       integer i,j
2739 c      write (2,*) 'ugrad',ugrad
2740 c      write (2,*) 'u',u
2741       do i=1,3
2742         vec(i)=scalar(ugrad(1,i),u(1))
2743       enddo
2744 c      write (2,*) 'vec',vec
2745       do i=1,3
2746         do j=1,3
2747           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2748         enddo
2749       enddo
2750 c      write (2,*) 'ungrad',ungrad
2751       return
2752       end
2753 C-----------------------------------------------------------------------------
2754       subroutine escp(evdw2,evdw2_14)
2755 C
2756 C This subroutine calculates the excluded-volume interaction energy between
2757 C peptide-group centers and side chains and its gradient in virtual-bond and
2758 C side-chain vectors.
2759 C
2760       implicit real*8 (a-h,o-z)
2761       include 'DIMENSIONS'
2762       include 'sizesclu.dat'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.FFIELD'
2770       include 'COMMON.IOUNITS'
2771       dimension ggg(3)
2772       evdw2=0.0D0
2773       evdw2_14=0.0d0
2774 cd    print '(a)','Enter ESCP'
2775 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2776 c     &  ' scal14',scal14
2777       do i=iatscp_s,iatscp_e
2778         iteli=itel(i)
2779 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2780 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2781         if (iteli.eq.0) goto 1225
2782         xi=0.5D0*(c(1,i)+c(1,i+1))
2783         yi=0.5D0*(c(2,i)+c(2,i+1))
2784         zi=0.5D0*(c(3,i)+c(3,i+1))
2785
2786         do iint=1,nscp_gr(i)
2787
2788         do j=iscpstart(i,iint),iscpend(i,iint)
2789           itypj=itype(j)
2790 C Uncomment following three lines for SC-p interactions
2791 c         xj=c(1,nres+j)-xi
2792 c         yj=c(2,nres+j)-yi
2793 c         zj=c(3,nres+j)-zi
2794 C Uncomment following three lines for Ca-p interactions
2795           xj=c(1,j)-xi
2796           yj=c(2,j)-yi
2797           zj=c(3,j)-zi
2798           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2799           fac=rrij**expon2
2800           e1=fac*fac*aad(itypj,iteli)
2801           e2=fac*bad(itypj,iteli)
2802           if (iabs(j-i) .le. 2) then
2803             e1=scal14*e1
2804             e2=scal14*e2
2805             evdw2_14=evdw2_14+e1+e2
2806           endif
2807           evdwij=e1+e2
2808 c          write (iout,*) i,j,evdwij
2809           evdw2=evdw2+evdwij
2810           if (calc_grad) then
2811 C
2812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2813 C
2814           fac=-(evdwij+e1)*rrij
2815           ggg(1)=xj*fac
2816           ggg(2)=yj*fac
2817           ggg(3)=zj*fac
2818           if (j.lt.i) then
2819 cd          write (iout,*) 'j<i'
2820 C Uncomment following three lines for SC-p interactions
2821 c           do k=1,3
2822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2823 c           enddo
2824           else
2825 cd          write (iout,*) 'j>i'
2826             do k=1,3
2827               ggg(k)=-ggg(k)
2828 C Uncomment following line for SC-p interactions
2829 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2830             enddo
2831           endif
2832           do k=1,3
2833             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2834           enddo
2835           kstart=min0(i+1,j)
2836           kend=max0(i-1,j-1)
2837 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2838 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2839           do k=kstart,kend
2840             do l=1,3
2841               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2842             enddo
2843           enddo
2844           endif
2845         enddo
2846         enddo ! iint
2847  1225   continue
2848       enddo ! i
2849       do i=1,nct
2850         do j=1,3
2851           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2852           gradx_scp(j,i)=expon*gradx_scp(j,i)
2853         enddo
2854       enddo
2855 C******************************************************************************
2856 C
2857 C                              N O T E !!!
2858 C
2859 C To save time the factor EXPON has been extracted from ALL components
2860 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2861 C use!
2862 C
2863 C******************************************************************************
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine edis(ehpb)
2868 C
2869 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2870 C
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873       include 'COMMON.SBRIDGE'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.VAR'
2877       include 'COMMON.INTERACT'
2878       include 'COMMON.IOUNITS'
2879       dimension ggg(3)
2880       ehpb=0.0D0
2881 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2882 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2883       if (link_end.eq.0) return
2884       do i=link_start,link_end
2885 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2886 C CA-CA distance used in regularization of structure.
2887         ii=ihpb(i)
2888         jj=jhpb(i)
2889 C iii and jjj point to the residues for which the distance is assigned.
2890         if (ii.gt.nres) then
2891           iii=ii-nres
2892           jjj=jj-nres
2893         else
2894           iii=ii
2895           jjj=jj
2896         endif
2897 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2898 c     &    dhpb(i),dhpb1(i),forcon(i)
2899 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2900 C    distance and angle dependent SS bond potential.
2901         if (.not.dyn_ss .and. i.le.nss) then
2902 C 15/02/13 CC dynamic SSbond - additional check
2903         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2904           call ssbond_ene(iii,jjj,eij)
2905           ehpb=ehpb+2*eij
2906 cd          write (iout,*) "eij",eij
2907         endif
2908         else if (ii.gt.nres .and. jj.gt.nres) then
2909 c Restraints from contact prediction
2910           dd=dist(ii,jj)
2911           if (dhpb1(i).gt.0.0d0) then
2912             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2913             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2914 c            write (iout,*) "beta nmr",
2915 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2916           else
2917             dd=dist(ii,jj)
2918             rdis=dd-dhpb(i)
2919 C Get the force constant corresponding to this distance.
2920             waga=forcon(i)
2921 C Calculate the contribution to energy.
2922             ehpb=ehpb+waga*rdis*rdis
2923 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2924 C
2925 C Evaluate gradient.
2926 C
2927             fac=waga*rdis/dd
2928           endif
2929           do j=1,3
2930             ggg(j)=fac*(c(j,jj)-c(j,ii))
2931           enddo
2932           do j=1,3
2933             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2934             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2935           enddo
2936           do k=1,3
2937             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2938             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2939           enddo
2940         else
2941 C Calculate the distance between the two points and its difference from the
2942 C target distance.
2943           dd=dist(ii,jj)
2944           if (dhpb1(i).gt.0.0d0) then
2945             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2946             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2947 c            write (iout,*) "alph nmr",
2948 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2949           else
2950             rdis=dd-dhpb(i)
2951 C Get the force constant corresponding to this distance.
2952             waga=forcon(i)
2953 C Calculate the contribution to energy.
2954             ehpb=ehpb+waga*rdis*rdis
2955 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2956 C
2957 C Evaluate gradient.
2958 C
2959             fac=waga*rdis/dd
2960           endif
2961 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2962 cd   &   ' waga=',waga,' fac=',fac
2963             do j=1,3
2964               ggg(j)=fac*(c(j,jj)-c(j,ii))
2965             enddo
2966 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2967 C If this is a SC-SC distance, we need to calculate the contributions to the
2968 C Cartesian gradient in the SC vectors (ghpbx).
2969           if (iii.lt.ii) then
2970           do j=1,3
2971             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2972             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2973           enddo
2974           endif
2975           do k=1,3
2976             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2977             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2978           enddo
2979         endif
2980       enddo
2981       ehpb=0.5D0*ehpb
2982       return
2983       end
2984 C--------------------------------------------------------------------------
2985       subroutine ssbond_ene(i,j,eij)
2986 C
2987 C Calculate the distance and angle dependent SS-bond potential energy
2988 C using a free-energy function derived based on RHF/6-31G** ab initio
2989 C calculations of diethyl disulfide.
2990 C
2991 C A. Liwo and U. Kozlowska, 11/24/03
2992 C
2993       implicit real*8 (a-h,o-z)
2994       include 'DIMENSIONS'
2995       include 'sizesclu.dat'
2996       include 'COMMON.SBRIDGE'
2997       include 'COMMON.CHAIN'
2998       include 'COMMON.DERIV'
2999       include 'COMMON.LOCAL'
3000       include 'COMMON.INTERACT'
3001       include 'COMMON.VAR'
3002       include 'COMMON.IOUNITS'
3003       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3004       itypi=itype(i)
3005       xi=c(1,nres+i)
3006       yi=c(2,nres+i)
3007       zi=c(3,nres+i)
3008       dxi=dc_norm(1,nres+i)
3009       dyi=dc_norm(2,nres+i)
3010       dzi=dc_norm(3,nres+i)
3011       dsci_inv=dsc_inv(itypi)
3012       itypj=itype(j)
3013       dscj_inv=dsc_inv(itypj)
3014       xj=c(1,nres+j)-xi
3015       yj=c(2,nres+j)-yi
3016       zj=c(3,nres+j)-zi
3017       dxj=dc_norm(1,nres+j)
3018       dyj=dc_norm(2,nres+j)
3019       dzj=dc_norm(3,nres+j)
3020       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3021       rij=dsqrt(rrij)
3022       erij(1)=xj*rij
3023       erij(2)=yj*rij
3024       erij(3)=zj*rij
3025       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3026       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3027       om12=dxi*dxj+dyi*dyj+dzi*dzj
3028       do k=1,3
3029         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3030         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3031       enddo
3032       rij=1.0d0/rij
3033       deltad=rij-d0cm
3034       deltat1=1.0d0-om1
3035       deltat2=1.0d0+om2
3036       deltat12=om2-om1+2.0d0
3037       cosphi=om12-om1*om2
3038       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3039      &  +akct*deltad*deltat12+ebr
3040      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3041 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3042 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3043 c     &  " deltat12",deltat12," eij",eij
3044       ed=2*akcm*deltad+akct*deltat12
3045       pom1=akct*deltad
3046       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3047       eom1=-2*akth*deltat1-pom1-om2*pom2
3048       eom2= 2*akth*deltat2+pom1-om1*pom2
3049       eom12=pom2
3050       do k=1,3
3051         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3052       enddo
3053       do k=1,3
3054         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3055      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3056         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3057      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3058       enddo
3059 C
3060 C Calculate the components of the gradient in DC and X
3061 C
3062       do k=i,j-1
3063         do l=1,3
3064           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3065         enddo
3066       enddo
3067       return
3068       end
3069
3070 C--------------------------------------------------------------------------
3071
3072
3073 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3074       subroutine e_modeller(ehomology_constr)
3075       implicit real*8 (a-h,o-z)
3076
3077       include 'DIMENSIONS'
3078
3079       integer nnn, i, j, k, ki, irec, l
3080       integer katy, odleglosci, test7
3081       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3082       real*8 distance(max_template),distancek(max_template),
3083      &    min_odl,godl(max_template),dih_diff(max_template)
3084
3085 c
3086 c     FP - 30/10/2014 Temporary specifications for homology restraints
3087 c
3088       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3089      &                 sgtheta
3090       double precision, dimension (maxres) :: guscdiff,usc_diff
3091       double precision, dimension (max_template) ::
3092      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3093      &           theta_diff
3094
3095       include 'COMMON.SBRIDGE'
3096       include 'COMMON.CHAIN'
3097       include 'COMMON.GEO'
3098       include 'COMMON.DERIV'
3099       include 'COMMON.LOCAL'
3100       include 'COMMON.INTERACT'
3101       include 'COMMON.VAR'
3102       include 'COMMON.IOUNITS'
3103       include 'COMMON.CONTROL'
3104       include 'COMMON.HOMRESTR'
3105 c
3106       include 'COMMON.SETUP'
3107       include 'COMMON.NAMES'
3108
3109       do i=1,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
3442 c       Final value of gradient using same var as in Econstr_back
3443         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3444      &               *waga_homology(iset)
3445 c       dutheta(i)=sum_sgtheta/sum_gtheta
3446 c
3447 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3448 #endif
3449         Eval=Eval-dLOG(gutheta_i/constr_homology)
3450 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3451 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3452 c       Uconst_back=Uconst_back+utheta(i)
3453       enddo ! (i-loop for theta)
3454 #ifdef DEBUG
3455       write(iout,*) "------- theta restrs end -------"
3456 #endif
3457       endif
3458 c
3459 c Deviation of local SC geometry
3460 c
3461 c Separation of two i-loops (instructed by AL - 11/3/2014)
3462 c
3463 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3464 c     write (iout,*) "waga_d",waga_d
3465
3466 #ifdef DEBUG
3467       write(iout,*) "------- SC restrs start -------"
3468       write (iout,*) "Initial duscdiff,duscdiffx"
3469       do i=loc_start,loc_end
3470         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3471      &                 (duscdiffx(jik,i),jik=1,3)
3472       enddo
3473 #endif
3474       do i=loc_start,loc_end
3475         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3476         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3477 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3478 c       write(iout,*) "xxtab, yytab, zztab"
3479 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3480         do k=1,constr_homology
3481 c
3482           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3483 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3484           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3485           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3486 c         write(iout,*) "dxx, dyy, dzz"
3487 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3488 c
3489           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3490 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3491 c         uscdiffk(k)=usc_diff(i)
3492           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3493           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3494 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3495 c     &      xxref(j),yyref(j),zzref(j)
3496         enddo
3497 c
3498 c       Gradient
3499 c
3500 c       Generalized expression for multiple Gaussian acc to that for a single
3501 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3502 c
3503 c       Original implementation
3504 c       sum_guscdiff=guscdiff(i)
3505 c
3506 c       sum_sguscdiff=0.0d0
3507 c       do k=1,constr_homology
3508 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3509 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3510 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3511 c       enddo
3512 c
3513 c       Implementation of new expressions for gradient (Jan. 2015)
3514 c
3515 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3516 #ifdef GRAD
3517         do k=1,constr_homology
3518 c
3519 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3520 c       before. Now the drivatives should be correct
3521 c
3522           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3523 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3524           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3525           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3526 c
3527 c         New implementation
3528 c
3529           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3530      &                 sigma_d(k,i) ! for the grad wrt r'
3531 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3532 c
3533 c
3534 c        New implementation
3535          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3536          do jik=1,3
3537             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3538      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3539      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3540             duscdiff(jik,i)=duscdiff(jik,i)+
3541      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3542      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3543             duscdiffx(jik,i)=duscdiffx(jik,i)+
3544      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3545      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3546 c
3547 #ifdef DEBUG
3548              write(iout,*) "jik",jik,"i",i
3549              write(iout,*) "dxx, dyy, dzz"
3550              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3551              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3552 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3553 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3554 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3555 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3556 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3557 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3558 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3559 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3560 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3561 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3562 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3563 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3564 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3565 c            endif
3566 #endif
3567          enddo
3568         enddo
3569 #endif
3570 c
3571 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3572 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3573 c
3574 c        write (iout,*) i," uscdiff",uscdiff(i)
3575 c
3576 c Put together deviations from local geometry
3577
3578 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3579 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3580         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3581 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3582 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3583 c       Uconst_back=Uconst_back+usc_diff(i)
3584 c
3585 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3586 c
3587 c     New implment: multiplied by sum_sguscdiff
3588 c
3589
3590       enddo ! (i-loop for dscdiff)
3591
3592 c      endif
3593
3594 #ifdef DEBUG
3595       write(iout,*) "------- SC restrs end -------"
3596         write (iout,*) "------ After SC loop in e_modeller ------"
3597         do i=loc_start,loc_end
3598          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3599          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3600         enddo
3601       if (waga_theta.eq.1.0d0) then
3602       write (iout,*) "in e_modeller after SC restr end: dutheta"
3603       do i=ithet_start,ithet_end
3604         write (iout,*) i,dutheta(i)
3605       enddo
3606       endif
3607       if (waga_d.eq.1.0d0) then
3608       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3609       do i=1,nres
3610         write (iout,*) i,(duscdiff(j,i),j=1,3)
3611         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3612       enddo
3613       endif
3614 #endif
3615
3616 c Total energy from homology restraints
3617 #ifdef DEBUG
3618       write (iout,*) "odleg",odleg," kat",kat
3619       write (iout,*) "odleg",odleg," kat",kat
3620       write (iout,*) "Eval",Eval," Erot",Erot
3621       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3622       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3623       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3624       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3625 #endif
3626 c
3627 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3628 c
3629 c     ehomology_constr=odleg+kat
3630 c
3631 c     For Lorentzian-type Urestr
3632 c
3633
3634       if (waga_dist.ge.0.0d0) then
3635 c
3636 c          For Gaussian-type Urestr
3637 c
3638         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3639      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3640 c     write (iout,*) "ehomology_constr=",ehomology_constr
3641       else
3642 c
3643 c          For Lorentzian-type Urestr
3644 c
3645         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3646      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3647 c     write (iout,*) "ehomology_constr=",ehomology_constr
3648       endif
3649 #ifdef DEBUG
3650       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
3651       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3652      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
3653       write (iout,*) "ehomology_constr",ehomology_constr
3654 #endif
3655       return
3656
3657   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3658   747 format(a12,i4,i4,i4,f8.3,f8.3)
3659   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3660   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3661   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3662      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3663       end
3664 C--------------------------------------------------------------------------
3665       subroutine ebond(estr)
3666 c
3667 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3668 c
3669       implicit real*8 (a-h,o-z)
3670       include 'DIMENSIONS'
3671       include 'COMMON.LOCAL'
3672       include 'COMMON.GEO'
3673       include 'COMMON.INTERACT'
3674       include 'COMMON.DERIV'
3675       include 'COMMON.VAR'
3676       include 'COMMON.CHAIN'
3677       include 'COMMON.IOUNITS'
3678       include 'COMMON.NAMES'
3679       include 'COMMON.FFIELD'
3680       include 'COMMON.CONTROL'
3681       double precision u(3),ud(3)
3682       estr=0.0d0
3683       do i=nnt+1,nct
3684         diff = vbld(i)-vbldp0
3685 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3686         estr=estr+diff*diff
3687         do j=1,3
3688           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3689         enddo
3690       enddo
3691       estr=0.5d0*AKP*estr
3692 c
3693 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3694 c
3695       do i=nnt,nct
3696         iti=itype(i)
3697         if (iti.ne.10) then
3698           nbi=nbondterm(iti)
3699           if (nbi.eq.1) then
3700             diff=vbld(i+nres)-vbldsc0(1,iti)
3701 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3702 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3703             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3704             do j=1,3
3705               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3706             enddo
3707           else
3708             do j=1,nbi
3709               diff=vbld(i+nres)-vbldsc0(j,iti)
3710               ud(j)=aksc(j,iti)*diff
3711               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3712             enddo
3713             uprod=u(1)
3714             do j=2,nbi
3715               uprod=uprod*u(j)
3716             enddo
3717             usum=0.0d0
3718             usumsqder=0.0d0
3719             do j=1,nbi
3720               uprod1=1.0d0
3721               uprod2=1.0d0
3722               do k=1,nbi
3723                 if (k.ne.j) then
3724                   uprod1=uprod1*u(k)
3725                   uprod2=uprod2*u(k)*u(k)
3726                 endif
3727               enddo
3728               usum=usum+uprod1
3729               usumsqder=usumsqder+ud(j)*uprod2
3730             enddo
3731 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3732 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3733             estr=estr+uprod/usum
3734             do j=1,3
3735              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3736             enddo
3737           endif
3738         endif
3739       enddo
3740       return
3741       end
3742 #ifdef CRYST_THETA
3743 C--------------------------------------------------------------------------
3744       subroutine ebend(etheta)
3745 C
3746 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3747 C angles gamma and its derivatives in consecutive thetas and gammas.
3748 C
3749       implicit real*8 (a-h,o-z)
3750       include 'DIMENSIONS'
3751       include 'sizesclu.dat'
3752       include 'COMMON.LOCAL'
3753       include 'COMMON.GEO'
3754       include 'COMMON.INTERACT'
3755       include 'COMMON.DERIV'
3756       include 'COMMON.VAR'
3757       include 'COMMON.CHAIN'
3758       include 'COMMON.IOUNITS'
3759       include 'COMMON.NAMES'
3760       include 'COMMON.FFIELD'
3761       common /calcthet/ term1,term2,termm,diffak,ratak,
3762      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3763      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3764       double precision y(2),z(2)
3765       delta=0.02d0*pi
3766       time11=dexp(-2*time)
3767       time12=1.0d0
3768       etheta=0.0D0
3769 c      write (iout,*) "nres",nres
3770 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3771 c      write (iout,*) ithet_start,ithet_end
3772       do i=ithet_start,ithet_end
3773 C Zero the energy function and its derivative at 0 or pi.
3774         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3775         it=itype(i-1)
3776 c        if (i.gt.ithet_start .and.
3777 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3778 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3779 c          phii=phi(i)
3780 c          y(1)=dcos(phii)
3781 c          y(2)=dsin(phii)
3782 c        else
3783 c          y(1)=0.0D0
3784 c          y(2)=0.0D0
3785 c        endif
3786 c        if (i.lt.nres .and. itel(i).ne.0) then
3787 c          phii1=phi(i+1)
3788 c          z(1)=dcos(phii1)
3789 c          z(2)=dsin(phii1)
3790 c        else
3791 c          z(1)=0.0D0
3792 c          z(2)=0.0D0
3793 c        endif
3794         if (i.gt.3) then
3795 #ifdef OSF
3796           phii=phi(i)
3797           icrc=0
3798           call proc_proc(phii,icrc)
3799           if (icrc.eq.1) phii=150.0
3800 #else
3801           phii=phi(i)
3802 #endif
3803           y(1)=dcos(phii)
3804           y(2)=dsin(phii)
3805         else
3806           y(1)=0.0D0
3807           y(2)=0.0D0
3808         endif
3809         if (i.lt.nres) then
3810 #ifdef OSF
3811           phii1=phi(i+1)
3812           icrc=0
3813           call proc_proc(phii1,icrc)
3814           if (icrc.eq.1) phii1=150.0
3815           phii1=pinorm(phii1)
3816           z(1)=cos(phii1)
3817 #else
3818           phii1=phi(i+1)
3819           z(1)=dcos(phii1)
3820 #endif
3821           z(2)=dsin(phii1)
3822         else
3823           z(1)=0.0D0
3824           z(2)=0.0D0
3825         endif
3826 C Calculate the "mean" value of theta from the part of the distribution
3827 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3828 C In following comments this theta will be referred to as t_c.
3829         thet_pred_mean=0.0d0
3830         do k=1,2
3831           athetk=athet(k,it)
3832           bthetk=bthet(k,it)
3833           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3834         enddo
3835 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3836         dthett=thet_pred_mean*ssd
3837         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3838 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3839 C Derivatives of the "mean" values in gamma1 and gamma2.
3840         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3841         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3842         if (theta(i).gt.pi-delta) then
3843           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3844      &         E_tc0)
3845           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3846           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3847           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3848      &        E_theta)
3849           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3850      &        E_tc)
3851         else if (theta(i).lt.delta) then
3852           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3853           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3854           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3855      &        E_theta)
3856           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3857           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3858      &        E_tc)
3859         else
3860           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3861      &        E_theta,E_tc)
3862         endif
3863         etheta=etheta+ethetai
3864 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3865 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3866         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3867         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3868         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3869  1215   continue
3870       enddo
3871 C Ufff.... We've done all this!!!
3872       return
3873       end
3874 C---------------------------------------------------------------------------
3875       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3876      &     E_tc)
3877       implicit real*8 (a-h,o-z)
3878       include 'DIMENSIONS'
3879       include 'COMMON.LOCAL'
3880       include 'COMMON.IOUNITS'
3881       common /calcthet/ term1,term2,termm,diffak,ratak,
3882      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3883      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3884 C Calculate the contributions to both Gaussian lobes.
3885 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3886 C The "polynomial part" of the "standard deviation" of this part of
3887 C the distribution.
3888         sig=polthet(3,it)
3889         do j=2,0,-1
3890           sig=sig*thet_pred_mean+polthet(j,it)
3891         enddo
3892 C Derivative of the "interior part" of the "standard deviation of the"
3893 C gamma-dependent Gaussian lobe in t_c.
3894         sigtc=3*polthet(3,it)
3895         do j=2,1,-1
3896           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3897         enddo
3898         sigtc=sig*sigtc
3899 C Set the parameters of both Gaussian lobes of the distribution.
3900 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3901         fac=sig*sig+sigc0(it)
3902         sigcsq=fac+fac
3903         sigc=1.0D0/sigcsq
3904 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3905         sigsqtc=-4.0D0*sigcsq*sigtc
3906 c       print *,i,sig,sigtc,sigsqtc
3907 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3908         sigtc=-sigtc/(fac*fac)
3909 C Following variable is sigma(t_c)**(-2)
3910         sigcsq=sigcsq*sigcsq
3911         sig0i=sig0(it)
3912         sig0inv=1.0D0/sig0i**2
3913         delthec=thetai-thet_pred_mean
3914         delthe0=thetai-theta0i
3915         term1=-0.5D0*sigcsq*delthec*delthec
3916         term2=-0.5D0*sig0inv*delthe0*delthe0
3917 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3918 C NaNs in taking the logarithm. We extract the largest exponent which is added
3919 C to the energy (this being the log of the distribution) at the end of energy
3920 C term evaluation for this virtual-bond angle.
3921         if (term1.gt.term2) then
3922           termm=term1
3923           term2=dexp(term2-termm)
3924           term1=1.0d0
3925         else
3926           termm=term2
3927           term1=dexp(term1-termm)
3928           term2=1.0d0
3929         endif
3930 C The ratio between the gamma-independent and gamma-dependent lobes of
3931 C the distribution is a Gaussian function of thet_pred_mean too.
3932         diffak=gthet(2,it)-thet_pred_mean
3933         ratak=diffak/gthet(3,it)**2
3934         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3935 C Let's differentiate it in thet_pred_mean NOW.
3936         aktc=ak*ratak
3937 C Now put together the distribution terms to make complete distribution.
3938         termexp=term1+ak*term2
3939         termpre=sigc+ak*sig0i
3940 C Contribution of the bending energy from this theta is just the -log of
3941 C the sum of the contributions from the two lobes and the pre-exponential
3942 C factor. Simple enough, isn't it?
3943         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3944 C NOW the derivatives!!!
3945 C 6/6/97 Take into account the deformation.
3946         E_theta=(delthec*sigcsq*term1
3947      &       +ak*delthe0*sig0inv*term2)/termexp
3948         E_tc=((sigtc+aktc*sig0i)/termpre
3949      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3950      &       aktc*term2)/termexp)
3951       return
3952       end
3953 c-----------------------------------------------------------------------------
3954       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3955       implicit real*8 (a-h,o-z)
3956       include 'DIMENSIONS'
3957       include 'COMMON.LOCAL'
3958       include 'COMMON.IOUNITS'
3959       common /calcthet/ term1,term2,termm,diffak,ratak,
3960      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3961      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3962       delthec=thetai-thet_pred_mean
3963       delthe0=thetai-theta0i
3964 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3965       t3 = thetai-thet_pred_mean
3966       t6 = t3**2
3967       t9 = term1
3968       t12 = t3*sigcsq
3969       t14 = t12+t6*sigsqtc
3970       t16 = 1.0d0
3971       t21 = thetai-theta0i
3972       t23 = t21**2
3973       t26 = term2
3974       t27 = t21*t26
3975       t32 = termexp
3976       t40 = t32**2
3977       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3978      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3979      & *(-t12*t9-ak*sig0inv*t27)
3980       return
3981       end
3982 #else
3983 C--------------------------------------------------------------------------
3984       subroutine ebend(etheta)
3985 C
3986 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3987 C angles gamma and its derivatives in consecutive thetas and gammas.
3988 C ab initio-derived potentials from
3989 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3990 C
3991       implicit real*8 (a-h,o-z)
3992       include 'DIMENSIONS'
3993       include 'COMMON.LOCAL'
3994       include 'COMMON.GEO'
3995       include 'COMMON.INTERACT'
3996       include 'COMMON.DERIV'
3997       include 'COMMON.VAR'
3998       include 'COMMON.CHAIN'
3999       include 'COMMON.IOUNITS'
4000       include 'COMMON.NAMES'
4001       include 'COMMON.FFIELD'
4002       include 'COMMON.CONTROL'
4003       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4004      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4005      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4006      & sinph1ph2(maxdouble,maxdouble)
4007       logical lprn /.false./, lprn1 /.false./
4008       etheta=0.0D0
4009       do i=ithet_start,ithet_end
4010         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4011      &    (itype(i).eq.ntyp1)) cycle
4012         dethetai=0.0d0
4013         dephii=0.0d0
4014         dephii1=0.0d0
4015         theti2=0.5d0*theta(i)
4016         ityp2=ithetyp(itype(i-1))
4017         do k=1,nntheterm
4018           coskt(k)=dcos(k*theti2)
4019           sinkt(k)=dsin(k*theti2)
4020         enddo
4021         if (i.gt.3  .and. itype(i-3).ne.ntyp1) then
4022 #ifdef OSF
4023           phii=phi(i)
4024           if (phii.ne.phii) phii=150.0
4025 #else
4026           phii=phi(i)
4027 #endif
4028           ityp1=ithetyp(itype(i-2))
4029           do k=1,nsingle
4030             cosph1(k)=dcos(k*phii)
4031             sinph1(k)=dsin(k*phii)
4032           enddo
4033         else
4034           phii=0.0d0
4035           ityp1=ithetyp(itype(i-2))
4036           do k=1,nsingle
4037             cosph1(k)=0.0d0
4038             sinph1(k)=0.0d0
4039           enddo
4040         endif
4041         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4042 #ifdef OSF
4043           phii1=phi(i+1)
4044           if (phii1.ne.phii1) phii1=150.0
4045           phii1=pinorm(phii1)
4046 #else
4047           phii1=phi(i+1)
4048 #endif
4049           ityp3=ithetyp(itype(i))
4050           do k=1,nsingle
4051             cosph2(k)=dcos(k*phii1)
4052             sinph2(k)=dsin(k*phii1)
4053           enddo
4054         else
4055           phii1=0.0d0
4056           ityp3=ithetyp(itype(i))
4057           do k=1,nsingle
4058             cosph2(k)=0.0d0
4059             sinph2(k)=0.0d0
4060           enddo
4061         endif
4062 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4063 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4064 c        call flush(iout)
4065         ethetai=aa0thet(ityp1,ityp2,ityp3)
4066         do k=1,ndouble
4067           do l=1,k-1
4068             ccl=cosph1(l)*cosph2(k-l)
4069             ssl=sinph1(l)*sinph2(k-l)
4070             scl=sinph1(l)*cosph2(k-l)
4071             csl=cosph1(l)*sinph2(k-l)
4072             cosph1ph2(l,k)=ccl-ssl
4073             cosph1ph2(k,l)=ccl+ssl
4074             sinph1ph2(l,k)=scl+csl
4075             sinph1ph2(k,l)=scl-csl
4076           enddo
4077         enddo
4078         if (lprn) then
4079         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4080      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4081         write (iout,*) "coskt and sinkt"
4082         do k=1,nntheterm
4083           write (iout,*) k,coskt(k),sinkt(k)
4084         enddo
4085         endif
4086         do k=1,ntheterm
4087           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4088           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4089      &      *coskt(k)
4090           if (lprn)
4091      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4092      &     " ethetai",ethetai
4093         enddo
4094         if (lprn) then
4095         write (iout,*) "cosph and sinph"
4096         do k=1,nsingle
4097           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4098         enddo
4099         write (iout,*) "cosph1ph2 and sinph2ph2"
4100         do k=2,ndouble
4101           do l=1,k-1
4102             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4103      &         sinph1ph2(l,k),sinph1ph2(k,l)
4104           enddo
4105         enddo
4106         write(iout,*) "ethetai",ethetai
4107         endif
4108         do m=1,ntheterm2
4109           do k=1,nsingle
4110             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4111      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4112      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4113      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4114             ethetai=ethetai+sinkt(m)*aux
4115             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4116             dephii=dephii+k*sinkt(m)*(
4117      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4118      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4119             dephii1=dephii1+k*sinkt(m)*(
4120      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4121      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4122             if (lprn)
4123      &      write (iout,*) "m",m," k",k," bbthet",
4124      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4125      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4126      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4127      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4128           enddo
4129         enddo
4130         if (lprn)
4131      &  write(iout,*) "ethetai",ethetai
4132         do m=1,ntheterm3
4133           do k=2,ndouble
4134             do l=1,k-1
4135               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4136      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4137      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4138      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4139               ethetai=ethetai+sinkt(m)*aux
4140               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4141               dephii=dephii+l*sinkt(m)*(
4142      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4143      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4144      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4145      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4146               dephii1=dephii1+(k-l)*sinkt(m)*(
4147      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4148      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4149      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4150      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4151               if (lprn) then
4152               write (iout,*) "m",m," k",k," l",l," ffthet",
4153      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4154      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4155      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4156      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4157               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4158      &            cosph1ph2(k,l)*sinkt(m),
4159      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4160               endif
4161             enddo
4162           enddo
4163         enddo
4164 10      continue
4165 c        lprn1=.true.
4166         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4167      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4168      &   phii1*rad2deg,ethetai
4169 c        lprn1=.false.
4170         etheta=etheta+ethetai
4171
4172         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4173         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4174         gloc(nphi+i-2,icg)=wang*dethetai
4175       enddo
4176       return
4177       end
4178 #endif
4179 #ifdef CRYST_SC
4180 c-----------------------------------------------------------------------------
4181       subroutine esc(escloc)
4182 C Calculate the local energy of a side chain and its derivatives in the
4183 C corresponding virtual-bond valence angles THETA and the spherical angles
4184 C ALPHA and OMEGA.
4185       implicit real*8 (a-h,o-z)
4186       include 'DIMENSIONS'
4187       include 'sizesclu.dat'
4188       include 'COMMON.GEO'
4189       include 'COMMON.LOCAL'
4190       include 'COMMON.VAR'
4191       include 'COMMON.INTERACT'
4192       include 'COMMON.DERIV'
4193       include 'COMMON.CHAIN'
4194       include 'COMMON.IOUNITS'
4195       include 'COMMON.NAMES'
4196       include 'COMMON.FFIELD'
4197       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4198      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4199       common /sccalc/ time11,time12,time112,theti,it,nlobit
4200       delta=0.02d0*pi
4201       escloc=0.0D0
4202 c     write (iout,'(a)') 'ESC'
4203       do i=loc_start,loc_end
4204         it=itype(i)
4205         if (it.eq.10) goto 1
4206         nlobit=nlob(it)
4207 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4208 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4209         theti=theta(i+1)-pipol
4210         x(1)=dtan(theti)
4211         x(2)=alph(i)
4212         x(3)=omeg(i)
4213 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4214
4215         if (x(2).gt.pi-delta) then
4216           xtemp(1)=x(1)
4217           xtemp(2)=pi-delta
4218           xtemp(3)=x(3)
4219           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4220           xtemp(2)=pi
4221           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4222           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4223      &        escloci,dersc(2))
4224           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4225      &        ddersc0(1),dersc(1))
4226           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4227      &        ddersc0(3),dersc(3))
4228           xtemp(2)=pi-delta
4229           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4230           xtemp(2)=pi
4231           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4232           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4233      &            dersc0(2),esclocbi,dersc02)
4234           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4235      &            dersc12,dersc01)
4236           call splinthet(x(2),0.5d0*delta,ss,ssd)
4237           dersc0(1)=dersc01
4238           dersc0(2)=dersc02
4239           dersc0(3)=0.0d0
4240           do k=1,3
4241             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4242           enddo
4243           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4244 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4245 c    &             esclocbi,ss,ssd
4246           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4247 c         escloci=esclocbi
4248 c         write (iout,*) escloci
4249         else if (x(2).lt.delta) then
4250           xtemp(1)=x(1)
4251           xtemp(2)=delta
4252           xtemp(3)=x(3)
4253           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4254           xtemp(2)=0.0d0
4255           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4256           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4257      &        escloci,dersc(2))
4258           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4259      &        ddersc0(1),dersc(1))
4260           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4261      &        ddersc0(3),dersc(3))
4262           xtemp(2)=delta
4263           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4264           xtemp(2)=0.0d0
4265           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4266           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4267      &            dersc0(2),esclocbi,dersc02)
4268           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4269      &            dersc12,dersc01)
4270           dersc0(1)=dersc01
4271           dersc0(2)=dersc02
4272           dersc0(3)=0.0d0
4273           call splinthet(x(2),0.5d0*delta,ss,ssd)
4274           do k=1,3
4275             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4276           enddo
4277           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4278 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4279 c    &             esclocbi,ss,ssd
4280           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4281 c         write (iout,*) escloci
4282         else
4283           call enesc(x,escloci,dersc,ddummy,.false.)
4284         endif
4285
4286         escloc=escloc+escloci
4287 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4288
4289         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4290      &   wscloc*dersc(1)
4291         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4292         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4293     1   continue
4294       enddo
4295       return
4296       end
4297 C---------------------------------------------------------------------------
4298       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.GEO'
4302       include 'COMMON.LOCAL'
4303       include 'COMMON.IOUNITS'
4304       common /sccalc/ time11,time12,time112,theti,it,nlobit
4305       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4306       double precision contr(maxlob,-1:1)
4307       logical mixed
4308 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4309         escloc_i=0.0D0
4310         do j=1,3
4311           dersc(j)=0.0D0
4312           if (mixed) ddersc(j)=0.0d0
4313         enddo
4314         x3=x(3)
4315
4316 C Because of periodicity of the dependence of the SC energy in omega we have
4317 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4318 C To avoid underflows, first compute & store the exponents.
4319
4320         do iii=-1,1
4321
4322           x(3)=x3+iii*dwapi
4323
4324           do j=1,nlobit
4325             do k=1,3
4326               z(k)=x(k)-censc(k,j,it)
4327             enddo
4328             do k=1,3
4329               Axk=0.0D0
4330               do l=1,3
4331                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4332               enddo
4333               Ax(k,j,iii)=Axk
4334             enddo
4335             expfac=0.0D0
4336             do k=1,3
4337               expfac=expfac+Ax(k,j,iii)*z(k)
4338             enddo
4339             contr(j,iii)=expfac
4340           enddo ! j
4341
4342         enddo ! iii
4343
4344         x(3)=x3
4345 C As in the case of ebend, we want to avoid underflows in exponentiation and
4346 C subsequent NaNs and INFs in energy calculation.
4347 C Find the largest exponent
4348         emin=contr(1,-1)
4349         do iii=-1,1
4350           do j=1,nlobit
4351             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4352           enddo
4353         enddo
4354         emin=0.5D0*emin
4355 cd      print *,'it=',it,' emin=',emin
4356
4357 C Compute the contribution to SC energy and derivatives
4358         do iii=-1,1
4359
4360           do j=1,nlobit
4361             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4362 cd          print *,'j=',j,' expfac=',expfac
4363             escloc_i=escloc_i+expfac
4364             do k=1,3
4365               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4366             enddo
4367             if (mixed) then
4368               do k=1,3,2
4369                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4370      &            +gaussc(k,2,j,it))*expfac
4371               enddo
4372             endif
4373           enddo
4374
4375         enddo ! iii
4376
4377         dersc(1)=dersc(1)/cos(theti)**2
4378         ddersc(1)=ddersc(1)/cos(theti)**2
4379         ddersc(3)=ddersc(3)
4380
4381         escloci=-(dlog(escloc_i)-emin)
4382         do j=1,3
4383           dersc(j)=dersc(j)/escloc_i
4384         enddo
4385         if (mixed) then
4386           do j=1,3,2
4387             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4388           enddo
4389         endif
4390       return
4391       end
4392 C------------------------------------------------------------------------------
4393       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4394       implicit real*8 (a-h,o-z)
4395       include 'DIMENSIONS'
4396       include 'COMMON.GEO'
4397       include 'COMMON.LOCAL'
4398       include 'COMMON.IOUNITS'
4399       common /sccalc/ time11,time12,time112,theti,it,nlobit
4400       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4401       double precision contr(maxlob)
4402       logical mixed
4403
4404       escloc_i=0.0D0
4405
4406       do j=1,3
4407         dersc(j)=0.0D0
4408       enddo
4409
4410       do j=1,nlobit
4411         do k=1,2
4412           z(k)=x(k)-censc(k,j,it)
4413         enddo
4414         z(3)=dwapi
4415         do k=1,3
4416           Axk=0.0D0
4417           do l=1,3
4418             Axk=Axk+gaussc(l,k,j,it)*z(l)
4419           enddo
4420           Ax(k,j)=Axk
4421         enddo
4422         expfac=0.0D0
4423         do k=1,3
4424           expfac=expfac+Ax(k,j)*z(k)
4425         enddo
4426         contr(j)=expfac
4427       enddo ! j
4428
4429 C As in the case of ebend, we want to avoid underflows in exponentiation and
4430 C subsequent NaNs and INFs in energy calculation.
4431 C Find the largest exponent
4432       emin=contr(1)
4433       do j=1,nlobit
4434         if (emin.gt.contr(j)) emin=contr(j)
4435       enddo
4436       emin=0.5D0*emin
4437
4438 C Compute the contribution to SC energy and derivatives
4439
4440       dersc12=0.0d0
4441       do j=1,nlobit
4442         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4443         escloc_i=escloc_i+expfac
4444         do k=1,2
4445           dersc(k)=dersc(k)+Ax(k,j)*expfac
4446         enddo
4447         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4448      &            +gaussc(1,2,j,it))*expfac
4449         dersc(3)=0.0d0
4450       enddo
4451
4452       dersc(1)=dersc(1)/cos(theti)**2
4453       dersc12=dersc12/cos(theti)**2
4454       escloci=-(dlog(escloc_i)-emin)
4455       do j=1,2
4456         dersc(j)=dersc(j)/escloc_i
4457       enddo
4458       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4459       return
4460       end
4461 #else
4462 c----------------------------------------------------------------------------------
4463       subroutine esc(escloc)
4464 C Calculate the local energy of a side chain and its derivatives in the
4465 C corresponding virtual-bond valence angles THETA and the spherical angles
4466 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4467 C added by Urszula Kozlowska. 07/11/2007
4468 C
4469       implicit real*8 (a-h,o-z)
4470       include 'DIMENSIONS'
4471       include 'COMMON.GEO'
4472       include 'COMMON.LOCAL'
4473       include 'COMMON.VAR'
4474       include 'COMMON.SCROT'
4475       include 'COMMON.INTERACT'
4476       include 'COMMON.DERIV'
4477       include 'COMMON.CHAIN'
4478       include 'COMMON.IOUNITS'
4479       include 'COMMON.NAMES'
4480       include 'COMMON.FFIELD'
4481       include 'COMMON.CONTROL'
4482       include 'COMMON.VECTORS'
4483       double precision x_prime(3),y_prime(3),z_prime(3)
4484      &    , sumene,dsc_i,dp2_i,x(65),
4485      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4486      &    de_dxx,de_dyy,de_dzz,de_dt
4487       double precision s1_t,s1_6_t,s2_t,s2_6_t
4488       double precision
4489      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4490      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4491      & dt_dCi(3),dt_dCi1(3)
4492       common /sccalc/ time11,time12,time112,theti,it,nlobit
4493       delta=0.02d0*pi
4494       escloc=0.0D0
4495       do i=loc_start,loc_end
4496         costtab(i+1) =dcos(theta(i+1))
4497         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4498         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4499         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4500         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4501         cosfac=dsqrt(cosfac2)
4502         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4503         sinfac=dsqrt(sinfac2)
4504         it=itype(i)
4505         if (it.eq.10) goto 1
4506 c
4507 C  Compute the axes of tghe local cartesian coordinates system; store in
4508 c   x_prime, y_prime and z_prime
4509 c
4510         do j=1,3
4511           x_prime(j) = 0.00
4512           y_prime(j) = 0.00
4513           z_prime(j) = 0.00
4514         enddo
4515 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4516 C     &   dc_norm(3,i+nres)
4517         do j = 1,3
4518           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4519           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4520         enddo
4521         do j = 1,3
4522           z_prime(j) = -uz(j,i-1)
4523         enddo
4524 c       write (2,*) "i",i
4525 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4526 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4527 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4528 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4529 c      & " xy",scalar(x_prime(1),y_prime(1)),
4530 c      & " xz",scalar(x_prime(1),z_prime(1)),
4531 c      & " yy",scalar(y_prime(1),y_prime(1)),
4532 c      & " yz",scalar(y_prime(1),z_prime(1)),
4533 c      & " zz",scalar(z_prime(1),z_prime(1))
4534 c
4535 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4536 C to local coordinate system. Store in xx, yy, zz.
4537 c
4538         xx=0.0d0
4539         yy=0.0d0
4540         zz=0.0d0
4541         do j = 1,3
4542           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4543           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4544           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4545         enddo
4546
4547         xxtab(i)=xx
4548         yytab(i)=yy
4549         zztab(i)=zz
4550 C
4551 C Compute the energy of the ith side cbain
4552 C
4553 c        write (2,*) "xx",xx," yy",yy," zz",zz
4554         it=itype(i)
4555         do j = 1,65
4556           x(j) = sc_parmin(j,it)
4557         enddo
4558 #ifdef CHECK_COORD
4559 Cc diagnostics - remove later
4560         xx1 = dcos(alph(2))
4561         yy1 = dsin(alph(2))*dcos(omeg(2))
4562         zz1 = -dsin(alph(2))*dsin(omeg(2))
4563         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4564      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4565      &    xx1,yy1,zz1
4566 C,"  --- ", xx_w,yy_w,zz_w
4567 c end diagnostics
4568 #endif
4569         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4570      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4571      &   + x(10)*yy*zz
4572         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4573      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4574      & + x(20)*yy*zz
4575         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4576      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4577      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4578      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4579      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4580      &  +x(40)*xx*yy*zz
4581         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4582      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4583      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4584      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4585      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4586      &  +x(60)*xx*yy*zz
4587         dsc_i   = 0.743d0+x(61)
4588         dp2_i   = 1.9d0+x(62)
4589         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4590      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4591         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4592      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4593         s1=(1+x(63))/(0.1d0 + dscp1)
4594         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4595         s2=(1+x(65))/(0.1d0 + dscp2)
4596         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4597         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4598      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4599 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4600 c     &   sumene4,
4601 c     &   dscp1,dscp2,sumene
4602 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4603         escloc = escloc + sumene
4604 c        write (2,*) "escloc",escloc
4605         if (.not. calc_grad) goto 1
4606 #ifdef DEBUG
4607 C
4608 C This section to check the numerical derivatives of the energy of ith side
4609 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4610 C #define DEBUG in the code to turn it on.
4611 C
4612         write (2,*) "sumene               =",sumene
4613         aincr=1.0d-7
4614         xxsave=xx
4615         xx=xx+aincr
4616         write (2,*) xx,yy,zz
4617         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4618         de_dxx_num=(sumenep-sumene)/aincr
4619         xx=xxsave
4620         write (2,*) "xx+ sumene from enesc=",sumenep
4621         yysave=yy
4622         yy=yy+aincr
4623         write (2,*) xx,yy,zz
4624         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4625         de_dyy_num=(sumenep-sumene)/aincr
4626         yy=yysave
4627         write (2,*) "yy+ sumene from enesc=",sumenep
4628         zzsave=zz
4629         zz=zz+aincr
4630         write (2,*) xx,yy,zz
4631         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4632         de_dzz_num=(sumenep-sumene)/aincr
4633         zz=zzsave
4634         write (2,*) "zz+ sumene from enesc=",sumenep
4635         costsave=cost2tab(i+1)
4636         sintsave=sint2tab(i+1)
4637         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4638         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4639         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4640         de_dt_num=(sumenep-sumene)/aincr
4641         write (2,*) " t+ sumene from enesc=",sumenep
4642         cost2tab(i+1)=costsave
4643         sint2tab(i+1)=sintsave
4644 C End of diagnostics section.
4645 #endif
4646 C
4647 C Compute the gradient of esc
4648 C
4649         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4650         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4651         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4652         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4653         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4654         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4655         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4656         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4657         pom1=(sumene3*sint2tab(i+1)+sumene1)
4658      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4659         pom2=(sumene4*cost2tab(i+1)+sumene2)
4660      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4661         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4662         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4663      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4664      &  +x(40)*yy*zz
4665         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4666         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4667      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4668      &  +x(60)*yy*zz
4669         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4670      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4671      &        +(pom1+pom2)*pom_dx
4672 #ifdef DEBUG
4673         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4674 #endif
4675 C
4676         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4677         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4678      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4679      &  +x(40)*xx*zz
4680         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4681         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4682      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4683      &  +x(59)*zz**2 +x(60)*xx*zz
4684         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4685      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4686      &        +(pom1-pom2)*pom_dy
4687 #ifdef DEBUG
4688         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4689 #endif
4690 C
4691         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4692      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4693      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4694      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4695      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4696      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4697      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4698      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4699 #ifdef DEBUG
4700         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4701 #endif
4702 C
4703         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4704      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4705      &  +pom1*pom_dt1+pom2*pom_dt2
4706 #ifdef DEBUG
4707         write(2,*), "de_dt = ", de_dt,de_dt_num
4708 #endif
4709 c
4710 C
4711        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4712        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4713        cosfac2xx=cosfac2*xx
4714        sinfac2yy=sinfac2*yy
4715        do k = 1,3
4716          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4717      &      vbld_inv(i+1)
4718          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4719      &      vbld_inv(i)
4720          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4721          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4722 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4723 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4724 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4725 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4726          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4727          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4728          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4729          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4730          dZZ_Ci1(k)=0.0d0
4731          dZZ_Ci(k)=0.0d0
4732          do j=1,3
4733            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4734            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4735          enddo
4736
4737          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4738          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4739          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4740 c
4741          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4742          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4743        enddo
4744
4745        do k=1,3
4746          dXX_Ctab(k,i)=dXX_Ci(k)
4747          dXX_C1tab(k,i)=dXX_Ci1(k)
4748          dYY_Ctab(k,i)=dYY_Ci(k)
4749          dYY_C1tab(k,i)=dYY_Ci1(k)
4750          dZZ_Ctab(k,i)=dZZ_Ci(k)
4751          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4752          dXX_XYZtab(k,i)=dXX_XYZ(k)
4753          dYY_XYZtab(k,i)=dYY_XYZ(k)
4754          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4755        enddo
4756
4757        do k = 1,3
4758 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4759 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4760 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4761 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4762 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4763 c     &    dt_dci(k)
4764 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4765 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4766          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4767      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4768          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4769      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4770          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4771      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4772        enddo
4773 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4774 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4775
4776 C to check gradient call subroutine check_grad
4777
4778     1 continue
4779       enddo
4780       return
4781       end
4782 #endif
4783 c------------------------------------------------------------------------------
4784       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4785 C
4786 C This procedure calculates two-body contact function g(rij) and its derivative:
4787 C
4788 C           eps0ij                                     !       x < -1
4789 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4790 C            0                                         !       x > 1
4791 C
4792 C where x=(rij-r0ij)/delta
4793 C
4794 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4795 C
4796       implicit none
4797       double precision rij,r0ij,eps0ij,fcont,fprimcont
4798       double precision x,x2,x4,delta
4799 c     delta=0.02D0*r0ij
4800 c      delta=0.2D0*r0ij
4801       x=(rij-r0ij)/delta
4802       if (x.lt.-1.0D0) then
4803         fcont=eps0ij
4804         fprimcont=0.0D0
4805       else if (x.le.1.0D0) then
4806         x2=x*x
4807         x4=x2*x2
4808         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4809         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4810       else
4811         fcont=0.0D0
4812         fprimcont=0.0D0
4813       endif
4814       return
4815       end
4816 c------------------------------------------------------------------------------
4817       subroutine splinthet(theti,delta,ss,ssder)
4818       implicit real*8 (a-h,o-z)
4819       include 'DIMENSIONS'
4820       include 'sizesclu.dat'
4821       include 'COMMON.VAR'
4822       include 'COMMON.GEO'
4823       thetup=pi-delta
4824       thetlow=delta
4825       if (theti.gt.pipol) then
4826         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4827       else
4828         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4829         ssder=-ssder
4830       endif
4831       return
4832       end
4833 c------------------------------------------------------------------------------
4834       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4835       implicit none
4836       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4837       double precision ksi,ksi2,ksi3,a1,a2,a3
4838       a1=fprim0*delta/(f1-f0)
4839       a2=3.0d0-2.0d0*a1
4840       a3=a1-2.0d0
4841       ksi=(x-x0)/delta
4842       ksi2=ksi*ksi
4843       ksi3=ksi2*ksi
4844       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4845       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4846       return
4847       end
4848 c------------------------------------------------------------------------------
4849       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4850       implicit none
4851       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4852       double precision ksi,ksi2,ksi3,a1,a2,a3
4853       ksi=(x-x0)/delta
4854       ksi2=ksi*ksi
4855       ksi3=ksi2*ksi
4856       a1=fprim0x*delta
4857       a2=3*(f1x-f0x)-2*fprim0x*delta
4858       a3=fprim0x*delta-2*(f1x-f0x)
4859       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4860       return
4861       end
4862 C-----------------------------------------------------------------------------
4863 #ifdef CRYST_TOR
4864 C-----------------------------------------------------------------------------
4865       subroutine etor(etors,edihcnstr,fact)
4866       implicit real*8 (a-h,o-z)
4867       include 'DIMENSIONS'
4868       include 'sizesclu.dat'
4869       include 'COMMON.VAR'
4870       include 'COMMON.GEO'
4871       include 'COMMON.LOCAL'
4872       include 'COMMON.TORSION'
4873       include 'COMMON.INTERACT'
4874       include 'COMMON.DERIV'
4875       include 'COMMON.CHAIN'
4876       include 'COMMON.NAMES'
4877       include 'COMMON.IOUNITS'
4878       include 'COMMON.FFIELD'
4879       include 'COMMON.TORCNSTR'
4880       logical lprn
4881 C Set lprn=.true. for debugging
4882       lprn=.false.
4883 c      lprn=.true.
4884       etors=0.0D0
4885       do i=iphi_start,iphi_end
4886         itori=itortyp(itype(i-2))
4887         itori1=itortyp(itype(i-1))
4888         phii=phi(i)
4889         gloci=0.0D0
4890 C Proline-Proline pair is a special case...
4891         if (itori.eq.3 .and. itori1.eq.3) then
4892           if (phii.gt.-dwapi3) then
4893             cosphi=dcos(3*phii)
4894             fac=1.0D0/(1.0D0-cosphi)
4895             etorsi=v1(1,3,3)*fac
4896             etorsi=etorsi+etorsi
4897             etors=etors+etorsi-v1(1,3,3)
4898             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4899           endif
4900           do j=1,3
4901             v1ij=v1(j+1,itori,itori1)
4902             v2ij=v2(j+1,itori,itori1)
4903             cosphi=dcos(j*phii)
4904             sinphi=dsin(j*phii)
4905             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4906             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4907           enddo
4908         else
4909           do j=1,nterm_old
4910             v1ij=v1(j,itori,itori1)
4911             v2ij=v2(j,itori,itori1)
4912             cosphi=dcos(j*phii)
4913             sinphi=dsin(j*phii)
4914             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4915             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4916           enddo
4917         endif
4918         if (lprn)
4919      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4920      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4921      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4922         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4923 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4924       enddo
4925 ! 6/20/98 - dihedral angle constraints
4926       edihcnstr=0.0d0
4927       do i=1,ndih_constr
4928         itori=idih_constr(i)
4929         phii=phi(itori)
4930         difi=pinorm(phii-phi0(i))
4931         if (difi.gt.drange(i)) then
4932           difi=difi-drange(i)
4933           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4934           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4935         else if (difi.lt.-drange(i)) then
4936           difi=difi+drange(i)
4937           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4938           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4939         endif
4940 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4941 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4942       enddo
4943       write (iout,*) 'edihcnstr',edihcnstr
4944       return
4945       end
4946 c------------------------------------------------------------------------------
4947 #else
4948       subroutine etor(etors,edihcnstr,fact)
4949       implicit real*8 (a-h,o-z)
4950       include 'DIMENSIONS'
4951       include 'sizesclu.dat'
4952       include 'COMMON.VAR'
4953       include 'COMMON.GEO'
4954       include 'COMMON.LOCAL'
4955       include 'COMMON.TORSION'
4956       include 'COMMON.INTERACT'
4957       include 'COMMON.DERIV'
4958       include 'COMMON.CHAIN'
4959       include 'COMMON.NAMES'
4960       include 'COMMON.IOUNITS'
4961       include 'COMMON.FFIELD'
4962       include 'COMMON.TORCNSTR'
4963       logical lprn
4964 C Set lprn=.true. for debugging
4965       lprn=.false.
4966 c      lprn=.true.
4967       etors=0.0D0
4968       do i=iphi_start,iphi_end
4969         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4970         itori=itortyp(itype(i-2))
4971         itori1=itortyp(itype(i-1))
4972         phii=phi(i)
4973         gloci=0.0D0
4974 C Regular cosine and sine terms
4975         do j=1,nterm(itori,itori1)
4976           v1ij=v1(j,itori,itori1)
4977           v2ij=v2(j,itori,itori1)
4978           cosphi=dcos(j*phii)
4979           sinphi=dsin(j*phii)
4980           etors=etors+v1ij*cosphi+v2ij*sinphi
4981           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4982         enddo
4983 C Lorentz terms
4984 C                         v1
4985 C  E = SUM ----------------------------------- - v1
4986 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4987 C
4988         cosphi=dcos(0.5d0*phii)
4989         sinphi=dsin(0.5d0*phii)
4990         do j=1,nlor(itori,itori1)
4991           vl1ij=vlor1(j,itori,itori1)
4992           vl2ij=vlor2(j,itori,itori1)
4993           vl3ij=vlor3(j,itori,itori1)
4994           pom=vl2ij*cosphi+vl3ij*sinphi
4995           pom1=1.0d0/(pom*pom+1.0d0)
4996           etors=etors+vl1ij*pom1
4997           pom=-pom*pom1*pom1
4998           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4999         enddo
5000 C Subtract the constant term
5001         etors=etors-v0(itori,itori1)
5002         if (lprn)
5003      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5004      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5005      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5006         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5007 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5008  1215   continue
5009       enddo
5010 ! 6/20/98 - dihedral angle constraints
5011       edihcnstr=0.0d0
5012 c      write (iout,*) "Dihedral angle restraint energy"
5013       do i=1,ndih_constr
5014         itori=idih_constr(i)
5015         phii=phi(itori)
5016         difi=pinorm(phii-phi0(i))
5017 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5018 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5019         if (difi.gt.drange(i)) then
5020           difi=difi-drange(i)
5021           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5022           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5023 c          write (iout,*) 0.25d0*ftors*difi**4
5024         else if (difi.lt.-drange(i)) then
5025           difi=difi+drange(i)
5026           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5027           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5028 c          write (iout,*) 0.25d0*ftors*difi**4
5029         endif
5030       enddo
5031 c      write (iout,*) 'edihcnstr',edihcnstr
5032       return
5033       end
5034 c----------------------------------------------------------------------------
5035       subroutine etor_d(etors_d,fact2)
5036 C 6/23/01 Compute double torsional energy
5037       implicit real*8 (a-h,o-z)
5038       include 'DIMENSIONS'
5039       include 'sizesclu.dat'
5040       include 'COMMON.VAR'
5041       include 'COMMON.GEO'
5042       include 'COMMON.LOCAL'
5043       include 'COMMON.TORSION'
5044       include 'COMMON.INTERACT'
5045       include 'COMMON.DERIV'
5046       include 'COMMON.CHAIN'
5047       include 'COMMON.NAMES'
5048       include 'COMMON.IOUNITS'
5049       include 'COMMON.FFIELD'
5050       include 'COMMON.TORCNSTR'
5051       logical lprn
5052 C Set lprn=.true. for debugging
5053       lprn=.false.
5054 c     lprn=.true.
5055       etors_d=0.0D0
5056       do i=iphi_start,iphi_end-1
5057         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5058      &     goto 1215
5059         itori=itortyp(itype(i-2))
5060         itori1=itortyp(itype(i-1))
5061         itori2=itortyp(itype(i))
5062         phii=phi(i)
5063         phii1=phi(i+1)
5064         gloci1=0.0D0
5065         gloci2=0.0D0
5066 C Regular cosine and sine terms
5067         do j=1,ntermd_1(itori,itori1,itori2)
5068           v1cij=v1c(1,j,itori,itori1,itori2)
5069           v1sij=v1s(1,j,itori,itori1,itori2)
5070           v2cij=v1c(2,j,itori,itori1,itori2)
5071           v2sij=v1s(2,j,itori,itori1,itori2)
5072           cosphi1=dcos(j*phii)
5073           sinphi1=dsin(j*phii)
5074           cosphi2=dcos(j*phii1)
5075           sinphi2=dsin(j*phii1)
5076           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5077      &     v2cij*cosphi2+v2sij*sinphi2
5078           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5079           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5080         enddo
5081         do k=2,ntermd_2(itori,itori1,itori2)
5082           do l=1,k-1
5083             v1cdij = v2c(k,l,itori,itori1,itori2)
5084             v2cdij = v2c(l,k,itori,itori1,itori2)
5085             v1sdij = v2s(k,l,itori,itori1,itori2)
5086             v2sdij = v2s(l,k,itori,itori1,itori2)
5087             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5088             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5089             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5090             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5091             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5092      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5093             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5094      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5095             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5096      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5097           enddo
5098         enddo
5099         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5100         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5101  1215   continue
5102       enddo
5103       return
5104       end
5105 #endif
5106 c------------------------------------------------------------------------------
5107       subroutine eback_sc_corr(esccor,fact)
5108 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5109 c        conformational states; temporarily implemented as differences
5110 c        between UNRES torsional potentials (dependent on three types of
5111 c        residues) and the torsional potentials dependent on all 20 types
5112 c        of residues computed from AM1 energy surfaces of terminally-blocked
5113 c        amino-acid residues.
5114       implicit real*8 (a-h,o-z)
5115       include 'DIMENSIONS'
5116       include 'COMMON.VAR'
5117       include 'COMMON.GEO'
5118       include 'COMMON.LOCAL'
5119       include 'COMMON.TORSION'
5120       include 'COMMON.SCCOR'
5121       include 'COMMON.INTERACT'
5122       include 'COMMON.DERIV'
5123       include 'COMMON.CHAIN'
5124       include 'COMMON.NAMES'
5125       include 'COMMON.IOUNITS'
5126       include 'COMMON.FFIELD'
5127       include 'COMMON.CONTROL'
5128       logical lprn
5129 C Set lprn=.true. for debugging
5130       lprn=.false.
5131 c      lprn=.true.
5132 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5133       esccor=0.0D0
5134       do i=itau_start,itau_end
5135         esccor_ii=0.0D0
5136         isccori=isccortyp(itype(i-2))
5137         isccori1=isccortyp(itype(i-1))
5138         phii=phi(i)
5139 cccc  Added 9 May 2012
5140 cc Tauangle is torsional engle depending on the value of first digit
5141 c(see comment below)
5142 cc Omicron is flat angle depending on the value of first digit
5143 c(see comment below)
5144
5145
5146         do intertyp=1,3 !intertyp
5147 cc Added 09 May 2012 (Adasko)
5148 cc  Intertyp means interaction type of backbone mainchain correlation:
5149 c   1 = SC...Ca...Ca...Ca
5150 c   2 = Ca...Ca...Ca...SC
5151 c   3 = SC...Ca...Ca...SCi
5152         gloci=0.0D0
5153         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5154      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5155      &      (itype(i-1).eq.21)))
5156      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5157      &     .or.(itype(i-2).eq.21)))
5158      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5159      &      (itype(i-1).eq.21)))) cycle
5160         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5161         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5162      & cycle
5163         do j=1,nterm_sccor(isccori,isccori1)
5164           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5165           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5166           cosphi=dcos(j*tauangle(intertyp,i))
5167           sinphi=dsin(j*tauangle(intertyp,i))
5168           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5169 #define DEBUG
5170 #ifdef DEBUG
5171           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5172 #endif
5173 #undef DEBUG
5174           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5175         enddo
5176         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5177 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5178 c     &gloc_sc(intertyp,i-3,icg)
5179         if (lprn)
5180      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5181      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5182      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5183      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5184         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5185        enddo !intertyp
5186 #ifdef DEBUG
5187        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5188 #endif
5189       enddo
5190
5191       return
5192       end
5193 c------------------------------------------------------------------------------
5194       subroutine multibody(ecorr)
5195 C This subroutine calculates multi-body contributions to energy following
5196 C the idea of Skolnick et al. If side chains I and J make a contact and
5197 C at the same time side chains I+1 and J+1 make a contact, an extra
5198 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5199       implicit real*8 (a-h,o-z)
5200       include 'DIMENSIONS'
5201       include 'COMMON.IOUNITS'
5202       include 'COMMON.DERIV'
5203       include 'COMMON.INTERACT'
5204       include 'COMMON.CONTACTS'
5205       double precision gx(3),gx1(3)
5206       logical lprn
5207
5208 C Set lprn=.true. for debugging
5209       lprn=.false.
5210
5211       if (lprn) then
5212         write (iout,'(a)') 'Contact function values:'
5213         do i=nnt,nct-2
5214           write (iout,'(i2,20(1x,i2,f10.5))')
5215      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5216         enddo
5217       endif
5218       ecorr=0.0D0
5219       do i=nnt,nct
5220         do j=1,3
5221           gradcorr(j,i)=0.0D0
5222           gradxorr(j,i)=0.0D0
5223         enddo
5224       enddo
5225       do i=nnt,nct-2
5226
5227         DO ISHIFT = 3,4
5228
5229         i1=i+ishift
5230         num_conti=num_cont(i)
5231         num_conti1=num_cont(i1)
5232         do jj=1,num_conti
5233           j=jcont(jj,i)
5234           do kk=1,num_conti1
5235             j1=jcont(kk,i1)
5236             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5237 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5238 cd   &                   ' ishift=',ishift
5239 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5240 C The system gains extra energy.
5241               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5242             endif   ! j1==j+-ishift
5243           enddo     ! kk
5244         enddo       ! jj
5245
5246         ENDDO ! ISHIFT
5247
5248       enddo         ! i
5249       return
5250       end
5251 c------------------------------------------------------------------------------
5252       double precision function esccorr(i,j,k,l,jj,kk)
5253       implicit real*8 (a-h,o-z)
5254       include 'DIMENSIONS'
5255       include 'COMMON.IOUNITS'
5256       include 'COMMON.DERIV'
5257       include 'COMMON.INTERACT'
5258       include 'COMMON.CONTACTS'
5259       double precision gx(3),gx1(3)
5260       logical lprn
5261       lprn=.false.
5262       eij=facont(jj,i)
5263       ekl=facont(kk,k)
5264 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5265 C Calculate the multi-body contribution to energy.
5266 C Calculate multi-body contributions to the gradient.
5267 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5268 cd   & k,l,(gacont(m,kk,k),m=1,3)
5269       do m=1,3
5270         gx(m) =ekl*gacont(m,jj,i)
5271         gx1(m)=eij*gacont(m,kk,k)
5272         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5273         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5274         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5275         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5276       enddo
5277       do m=i,j-1
5278         do ll=1,3
5279           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5280         enddo
5281       enddo
5282       do m=k,l-1
5283         do ll=1,3
5284           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5285         enddo
5286       enddo
5287       esccorr=-eij*ekl
5288       return
5289       end
5290 c------------------------------------------------------------------------------
5291 #ifdef MPL
5292       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5293       implicit real*8 (a-h,o-z)
5294       include 'DIMENSIONS'
5295       integer dimen1,dimen2,atom,indx
5296       double precision buffer(dimen1,dimen2)
5297       double precision zapas
5298       common /contacts_hb/ zapas(3,20,maxres,7),
5299      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5300      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5301       num_kont=num_cont_hb(atom)
5302       do i=1,num_kont
5303         do k=1,7
5304           do j=1,3
5305             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5306           enddo ! j
5307         enddo ! k
5308         buffer(i,indx+22)=facont_hb(i,atom)
5309         buffer(i,indx+23)=ees0p(i,atom)
5310         buffer(i,indx+24)=ees0m(i,atom)
5311         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5312       enddo ! i
5313       buffer(1,indx+26)=dfloat(num_kont)
5314       return
5315       end
5316 c------------------------------------------------------------------------------
5317       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5318       implicit real*8 (a-h,o-z)
5319       include 'DIMENSIONS'
5320       integer dimen1,dimen2,atom,indx
5321       double precision buffer(dimen1,dimen2)
5322       double precision zapas
5323       common /contacts_hb/ zapas(3,20,maxres,7),
5324      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5325      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5326       num_kont=buffer(1,indx+26)
5327       num_kont_old=num_cont_hb(atom)
5328       num_cont_hb(atom)=num_kont+num_kont_old
5329       do i=1,num_kont
5330         ii=i+num_kont_old
5331         do k=1,7
5332           do j=1,3
5333             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5334           enddo ! j
5335         enddo ! k
5336         facont_hb(ii,atom)=buffer(i,indx+22)
5337         ees0p(ii,atom)=buffer(i,indx+23)
5338         ees0m(ii,atom)=buffer(i,indx+24)
5339         jcont_hb(ii,atom)=buffer(i,indx+25)
5340       enddo ! i
5341       return
5342       end
5343 c------------------------------------------------------------------------------
5344 #endif
5345       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5346 C This subroutine calculates multi-body contributions to hydrogen-bonding
5347       implicit real*8 (a-h,o-z)
5348       include 'DIMENSIONS'
5349       include 'sizesclu.dat'
5350       include 'COMMON.IOUNITS'
5351 #ifdef MPL
5352       include 'COMMON.INFO'
5353 #endif
5354       include 'COMMON.FFIELD'
5355       include 'COMMON.DERIV'
5356       include 'COMMON.INTERACT'
5357       include 'COMMON.CONTACTS'
5358 #ifdef MPL
5359       parameter (max_cont=maxconts)
5360       parameter (max_dim=2*(8*3+2))
5361       parameter (msglen1=max_cont*max_dim*4)
5362       parameter (msglen2=2*msglen1)
5363       integer source,CorrelType,CorrelID,Error
5364       double precision buffer(max_cont,max_dim)
5365 #endif
5366       double precision gx(3),gx1(3)
5367       logical lprn,ldone
5368
5369 C Set lprn=.true. for debugging
5370       lprn=.false.
5371 #ifdef MPL
5372       n_corr=0
5373       n_corr1=0
5374       if (fgProcs.le.1) goto 30
5375       if (lprn) then
5376         write (iout,'(a)') 'Contact function values:'
5377         do i=nnt,nct-2
5378           write (iout,'(2i3,50(1x,i2,f5.2))')
5379      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5380      &    j=1,num_cont_hb(i))
5381         enddo
5382       endif
5383 C Caution! Following code assumes that electrostatic interactions concerning
5384 C a given atom are split among at most two processors!
5385       CorrelType=477
5386       CorrelID=MyID+1
5387       ldone=.false.
5388       do i=1,max_cont
5389         do j=1,max_dim
5390           buffer(i,j)=0.0D0
5391         enddo
5392       enddo
5393       mm=mod(MyRank,2)
5394 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5395       if (mm) 20,20,10
5396    10 continue
5397 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5398       if (MyRank.gt.0) then
5399 C Send correlation contributions to the preceding processor
5400         msglen=msglen1
5401         nn=num_cont_hb(iatel_s)
5402         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5403 cd      write (iout,*) 'The BUFFER array:'
5404 cd      do i=1,nn
5405 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5406 cd      enddo
5407         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5408           msglen=msglen2
5409             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5410 C Clear the contacts of the atom passed to the neighboring processor
5411         nn=num_cont_hb(iatel_s+1)
5412 cd      do i=1,nn
5413 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5414 cd      enddo
5415             num_cont_hb(iatel_s)=0
5416         endif
5417 cd      write (iout,*) 'Processor ',MyID,MyRank,
5418 cd   & ' is sending correlation contribution to processor',MyID-1,
5419 cd   & ' msglen=',msglen
5420 cd      write (*,*) 'Processor ',MyID,MyRank,
5421 cd   & ' is sending correlation contribution to processor',MyID-1,
5422 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5423         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5424 cd      write (iout,*) 'Processor ',MyID,
5425 cd   & ' has sent correlation contribution to processor',MyID-1,
5426 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5427 cd      write (*,*) 'Processor ',MyID,
5428 cd   & ' has sent correlation contribution to processor',MyID-1,
5429 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5430         msglen=msglen1
5431       endif ! (MyRank.gt.0)
5432       if (ldone) goto 30
5433       ldone=.true.
5434    20 continue
5435 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5436       if (MyRank.lt.fgProcs-1) then
5437 C Receive correlation contributions from the next processor
5438         msglen=msglen1
5439         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5440 cd      write (iout,*) 'Processor',MyID,
5441 cd   & ' is receiving correlation contribution from processor',MyID+1,
5442 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5443 cd      write (*,*) 'Processor',MyID,
5444 cd   & ' is receiving correlation contribution from processor',MyID+1,
5445 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5446         nbytes=-1
5447         do while (nbytes.le.0)
5448           call mp_probe(MyID+1,CorrelType,nbytes)
5449         enddo
5450 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5451         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5452 cd      write (iout,*) 'Processor',MyID,
5453 cd   & ' has received correlation contribution from processor',MyID+1,
5454 cd   & ' msglen=',msglen,' nbytes=',nbytes
5455 cd      write (iout,*) 'The received BUFFER array:'
5456 cd      do i=1,max_cont
5457 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5458 cd      enddo
5459         if (msglen.eq.msglen1) then
5460           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5461         else if (msglen.eq.msglen2)  then
5462           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5463           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5464         else
5465           write (iout,*)
5466      & 'ERROR!!!! message length changed while processing correlations.'
5467           write (*,*)
5468      & 'ERROR!!!! message length changed while processing correlations.'
5469           call mp_stopall(Error)
5470         endif ! msglen.eq.msglen1
5471       endif ! MyRank.lt.fgProcs-1
5472       if (ldone) goto 30
5473       ldone=.true.
5474       goto 10
5475    30 continue
5476 #endif
5477       if (lprn) then
5478         write (iout,'(a)') 'Contact function values:'
5479         do i=nnt,nct-2
5480           write (iout,'(2i3,50(1x,i2,f5.2))')
5481      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5482      &    j=1,num_cont_hb(i))
5483         enddo
5484       endif
5485       ecorr=0.0D0
5486 C Remove the loop below after debugging !!!
5487       do i=nnt,nct
5488         do j=1,3
5489           gradcorr(j,i)=0.0D0
5490           gradxorr(j,i)=0.0D0
5491         enddo
5492       enddo
5493 C Calculate the local-electrostatic correlation terms
5494       do i=iatel_s,iatel_e+1
5495         i1=i+1
5496         num_conti=num_cont_hb(i)
5497         num_conti1=num_cont_hb(i+1)
5498         do jj=1,num_conti
5499           j=jcont_hb(jj,i)
5500           do kk=1,num_conti1
5501             j1=jcont_hb(kk,i1)
5502 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5503 c     &         ' jj=',jj,' kk=',kk
5504             if (j1.eq.j+1 .or. j1.eq.j-1) then
5505 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5506 C The system gains extra energy.
5507               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5508               n_corr=n_corr+1
5509             else if (j1.eq.j) then
5510 C Contacts I-J and I-(J+1) occur simultaneously.
5511 C The system loses extra energy.
5512 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5513             endif
5514           enddo ! kk
5515           do kk=1,num_conti
5516             j1=jcont_hb(kk,i)
5517 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5518 c    &         ' jj=',jj,' kk=',kk
5519             if (j1.eq.j+1) then
5520 C Contacts I-J and (I+1)-J occur simultaneously.
5521 C The system loses extra energy.
5522 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5523             endif ! j1==j+1
5524           enddo ! kk
5525         enddo ! jj
5526       enddo ! i
5527       return
5528       end
5529 c------------------------------------------------------------------------------
5530       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5531      &  n_corr1)
5532 C This subroutine calculates multi-body contributions to hydrogen-bonding
5533       implicit real*8 (a-h,o-z)
5534       include 'DIMENSIONS'
5535       include 'sizesclu.dat'
5536       include 'COMMON.IOUNITS'
5537 #ifdef MPL
5538       include 'COMMON.INFO'
5539 #endif
5540       include 'COMMON.FFIELD'
5541       include 'COMMON.DERIV'
5542       include 'COMMON.INTERACT'
5543       include 'COMMON.CONTACTS'
5544 #ifdef MPL
5545       parameter (max_cont=maxconts)
5546       parameter (max_dim=2*(8*3+2))
5547       parameter (msglen1=max_cont*max_dim*4)
5548       parameter (msglen2=2*msglen1)
5549       integer source,CorrelType,CorrelID,Error
5550       double precision buffer(max_cont,max_dim)
5551 #endif
5552       double precision gx(3),gx1(3)
5553       logical lprn,ldone
5554
5555 C Set lprn=.true. for debugging
5556       lprn=.false.
5557       eturn6=0.0d0
5558       ecorr6=0.0d0
5559 #ifdef MPL
5560       n_corr=0
5561       n_corr1=0
5562       if (fgProcs.le.1) goto 30
5563       if (lprn) then
5564         write (iout,'(a)') 'Contact function values:'
5565         do i=nnt,nct-2
5566           write (iout,'(2i3,50(1x,i2,f5.2))')
5567      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5568      &    j=1,num_cont_hb(i))
5569         enddo
5570       endif
5571 C Caution! Following code assumes that electrostatic interactions concerning
5572 C a given atom are split among at most two processors!
5573       CorrelType=477
5574       CorrelID=MyID+1
5575       ldone=.false.
5576       do i=1,max_cont
5577         do j=1,max_dim
5578           buffer(i,j)=0.0D0
5579         enddo
5580       enddo
5581       mm=mod(MyRank,2)
5582 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5583       if (mm) 20,20,10
5584    10 continue
5585 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5586       if (MyRank.gt.0) then
5587 C Send correlation contributions to the preceding processor
5588         msglen=msglen1
5589         nn=num_cont_hb(iatel_s)
5590         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5591 cd      write (iout,*) 'The BUFFER array:'
5592 cd      do i=1,nn
5593 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5594 cd      enddo
5595         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5596           msglen=msglen2
5597             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5598 C Clear the contacts of the atom passed to the neighboring processor
5599         nn=num_cont_hb(iatel_s+1)
5600 cd      do i=1,nn
5601 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5602 cd      enddo
5603             num_cont_hb(iatel_s)=0
5604         endif
5605 cd      write (iout,*) 'Processor ',MyID,MyRank,
5606 cd   & ' is sending correlation contribution to processor',MyID-1,
5607 cd   & ' msglen=',msglen
5608 cd      write (*,*) 'Processor ',MyID,MyRank,
5609 cd   & ' is sending correlation contribution to processor',MyID-1,
5610 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5611         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5612 cd      write (iout,*) 'Processor ',MyID,
5613 cd   & ' has sent correlation contribution to processor',MyID-1,
5614 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5615 cd      write (*,*) 'Processor ',MyID,
5616 cd   & ' has sent correlation contribution to processor',MyID-1,
5617 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5618         msglen=msglen1
5619       endif ! (MyRank.gt.0)
5620       if (ldone) goto 30
5621       ldone=.true.
5622    20 continue
5623 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5624       if (MyRank.lt.fgProcs-1) then
5625 C Receive correlation contributions from the next processor
5626         msglen=msglen1
5627         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5628 cd      write (iout,*) 'Processor',MyID,
5629 cd   & ' is receiving correlation contribution from processor',MyID+1,
5630 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5631 cd      write (*,*) 'Processor',MyID,
5632 cd   & ' is receiving correlation contribution from processor',MyID+1,
5633 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5634         nbytes=-1
5635         do while (nbytes.le.0)
5636           call mp_probe(MyID+1,CorrelType,nbytes)
5637         enddo
5638 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5639         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5640 cd      write (iout,*) 'Processor',MyID,
5641 cd   & ' has received correlation contribution from processor',MyID+1,
5642 cd   & ' msglen=',msglen,' nbytes=',nbytes
5643 cd      write (iout,*) 'The received BUFFER array:'
5644 cd      do i=1,max_cont
5645 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5646 cd      enddo
5647         if (msglen.eq.msglen1) then
5648           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5649         else if (msglen.eq.msglen2)  then
5650           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5651           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5652         else
5653           write (iout,*)
5654      & 'ERROR!!!! message length changed while processing correlations.'
5655           write (*,*)
5656      & 'ERROR!!!! message length changed while processing correlations.'
5657           call mp_stopall(Error)
5658         endif ! msglen.eq.msglen1
5659       endif ! MyRank.lt.fgProcs-1
5660       if (ldone) goto 30
5661       ldone=.true.
5662       goto 10
5663    30 continue
5664 #endif
5665       if (lprn) then
5666         write (iout,'(a)') 'Contact function values:'
5667         do i=nnt,nct-2
5668           write (iout,'(2i3,50(1x,i2,f5.2))')
5669      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5670      &    j=1,num_cont_hb(i))
5671         enddo
5672       endif
5673       ecorr=0.0D0
5674       ecorr5=0.0d0
5675       ecorr6=0.0d0
5676 C Remove the loop below after debugging !!!
5677       do i=nnt,nct
5678         do j=1,3
5679           gradcorr(j,i)=0.0D0
5680           gradxorr(j,i)=0.0D0
5681         enddo
5682       enddo
5683 C Calculate the dipole-dipole interaction energies
5684       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5685       do i=iatel_s,iatel_e+1
5686         num_conti=num_cont_hb(i)
5687         do jj=1,num_conti
5688           j=jcont_hb(jj,i)
5689           call dipole(i,j,jj)
5690         enddo
5691       enddo
5692       endif
5693 C Calculate the local-electrostatic correlation terms
5694       do i=iatel_s,iatel_e+1
5695         i1=i+1
5696         num_conti=num_cont_hb(i)
5697         num_conti1=num_cont_hb(i+1)
5698         do jj=1,num_conti
5699           j=jcont_hb(jj,i)
5700           do kk=1,num_conti1
5701             j1=jcont_hb(kk,i1)
5702 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5703 c     &         ' jj=',jj,' kk=',kk
5704             if (j1.eq.j+1 .or. j1.eq.j-1) then
5705 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5706 C The system gains extra energy.
5707               n_corr=n_corr+1
5708               sqd1=dsqrt(d_cont(jj,i))
5709               sqd2=dsqrt(d_cont(kk,i1))
5710               sred_geom = sqd1*sqd2
5711               IF (sred_geom.lt.cutoff_corr) THEN
5712                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5713      &            ekont,fprimcont)
5714 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5715 c     &         ' jj=',jj,' kk=',kk
5716                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5717                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5718                 do l=1,3
5719                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5720                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5721                 enddo
5722                 n_corr1=n_corr1+1
5723 cd               write (iout,*) 'sred_geom=',sred_geom,
5724 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5725                 call calc_eello(i,j,i+1,j1,jj,kk)
5726                 if (wcorr4.gt.0.0d0)
5727      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5728                 if (wcorr5.gt.0.0d0)
5729      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5730 c                print *,"wcorr5",ecorr5
5731 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5732 cd                write(2,*)'ijkl',i,j,i+1,j1
5733                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5734      &               .or. wturn6.eq.0.0d0))then
5735 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5736 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5737 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5738 c     &            'ecorr6=',ecorr6, wcorr6
5739 cd                write (iout,'(4e15.5)') sred_geom,
5740 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5741 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5742 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5743                 else if (wturn6.gt.0.0d0
5744      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5745 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5746                   eturn6=eturn6+eello_turn6(i,jj,kk)
5747 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5748                 endif
5749               ENDIF
5750 1111          continue
5751             else if (j1.eq.j) then
5752 C Contacts I-J and I-(J+1) occur simultaneously.
5753 C The system loses extra energy.
5754 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5755             endif
5756           enddo ! kk
5757           do kk=1,num_conti
5758             j1=jcont_hb(kk,i)
5759 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5760 c    &         ' jj=',jj,' kk=',kk
5761             if (j1.eq.j+1) then
5762 C Contacts I-J and (I+1)-J occur simultaneously.
5763 C The system loses extra energy.
5764 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5765             endif ! j1==j+1
5766           enddo ! kk
5767         enddo ! jj
5768       enddo ! i
5769       return
5770       end
5771 c------------------------------------------------------------------------------
5772       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5773       implicit real*8 (a-h,o-z)
5774       include 'DIMENSIONS'
5775       include 'COMMON.IOUNITS'
5776       include 'COMMON.DERIV'
5777       include 'COMMON.INTERACT'
5778       include 'COMMON.CONTACTS'
5779       double precision gx(3),gx1(3)
5780       logical lprn
5781       lprn=.false.
5782       eij=facont_hb(jj,i)
5783       ekl=facont_hb(kk,k)
5784       ees0pij=ees0p(jj,i)
5785       ees0pkl=ees0p(kk,k)
5786       ees0mij=ees0m(jj,i)
5787       ees0mkl=ees0m(kk,k)
5788       ekont=eij*ekl
5789       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5790 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5791 C Following 4 lines for diagnostics.
5792 cd    ees0pkl=0.0D0
5793 cd    ees0pij=1.0D0
5794 cd    ees0mkl=0.0D0
5795 cd    ees0mij=1.0D0
5796 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5797 c    &   ' and',k,l
5798 c     write (iout,*)'Contacts have occurred for peptide groups',
5799 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5800 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5801 C Calculate the multi-body contribution to energy.
5802       ecorr=ecorr+ekont*ees
5803       if (calc_grad) then
5804 C Calculate multi-body contributions to the gradient.
5805       do ll=1,3
5806         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5807         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5808      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5809      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5810         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5811      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5812      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5813         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5814         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5815      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5816      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5817         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5818      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5819      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5820       enddo
5821       do m=i+1,j-1
5822         do ll=1,3
5823           gradcorr(ll,m)=gradcorr(ll,m)+
5824      &     ees*ekl*gacont_hbr(ll,jj,i)-
5825      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5826      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5827         enddo
5828       enddo
5829       do m=k+1,l-1
5830         do ll=1,3
5831           gradcorr(ll,m)=gradcorr(ll,m)+
5832      &     ees*eij*gacont_hbr(ll,kk,k)-
5833      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5834      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5835         enddo
5836       enddo
5837       endif
5838       ehbcorr=ekont*ees
5839       return
5840       end
5841 C---------------------------------------------------------------------------
5842       subroutine dipole(i,j,jj)
5843       implicit real*8 (a-h,o-z)
5844       include 'DIMENSIONS'
5845       include 'sizesclu.dat'
5846       include 'COMMON.IOUNITS'
5847       include 'COMMON.CHAIN'
5848       include 'COMMON.FFIELD'
5849       include 'COMMON.DERIV'
5850       include 'COMMON.INTERACT'
5851       include 'COMMON.CONTACTS'
5852       include 'COMMON.TORSION'
5853       include 'COMMON.VAR'
5854       include 'COMMON.GEO'
5855       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5856      &  auxmat(2,2)
5857       iti1 = itortyp(itype(i+1))
5858       if (j.lt.nres-1) then
5859         itj1 = itortyp(itype(j+1))
5860       else
5861         itj1=ntortyp+1
5862       endif
5863       do iii=1,2
5864         dipi(iii,1)=Ub2(iii,i)
5865         dipderi(iii)=Ub2der(iii,i)
5866         dipi(iii,2)=b1(iii,iti1)
5867         dipj(iii,1)=Ub2(iii,j)
5868         dipderj(iii)=Ub2der(iii,j)
5869         dipj(iii,2)=b1(iii,itj1)
5870       enddo
5871       kkk=0
5872       do iii=1,2
5873         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5874         do jjj=1,2
5875           kkk=kkk+1
5876           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5877         enddo
5878       enddo
5879       if (.not.calc_grad) return
5880       do kkk=1,5
5881         do lll=1,3
5882           mmm=0
5883           do iii=1,2
5884             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5885      &        auxvec(1))
5886             do jjj=1,2
5887               mmm=mmm+1
5888               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5889             enddo
5890           enddo
5891         enddo
5892       enddo
5893       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5894       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5895       do iii=1,2
5896         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5897       enddo
5898       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5899       do iii=1,2
5900         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5901       enddo
5902       return
5903       end
5904 C---------------------------------------------------------------------------
5905       subroutine calc_eello(i,j,k,l,jj,kk)
5906 C
5907 C This subroutine computes matrices and vectors needed to calculate
5908 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5909 C
5910       implicit real*8 (a-h,o-z)
5911       include 'DIMENSIONS'
5912       include 'sizesclu.dat'
5913       include 'COMMON.IOUNITS'
5914       include 'COMMON.CHAIN'
5915       include 'COMMON.DERIV'
5916       include 'COMMON.INTERACT'
5917       include 'COMMON.CONTACTS'
5918       include 'COMMON.TORSION'
5919       include 'COMMON.VAR'
5920       include 'COMMON.GEO'
5921       include 'COMMON.FFIELD'
5922       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5923      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5924       logical lprn
5925       common /kutas/ lprn
5926 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5927 cd     & ' jj=',jj,' kk=',kk
5928 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5929       do iii=1,2
5930         do jjj=1,2
5931           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5932           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5933         enddo
5934       enddo
5935       call transpose2(aa1(1,1),aa1t(1,1))
5936       call transpose2(aa2(1,1),aa2t(1,1))
5937       do kkk=1,5
5938         do lll=1,3
5939           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5940      &      aa1tder(1,1,lll,kkk))
5941           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5942      &      aa2tder(1,1,lll,kkk))
5943         enddo
5944       enddo
5945       if (l.eq.j+1) then
5946 C parallel orientation of the two CA-CA-CA frames.
5947         if (i.gt.1) then
5948           iti=itortyp(itype(i))
5949         else
5950           iti=ntortyp+1
5951         endif
5952         itk1=itortyp(itype(k+1))
5953         itj=itortyp(itype(j))
5954         if (l.lt.nres-1) then
5955           itl1=itortyp(itype(l+1))
5956         else
5957           itl1=ntortyp+1
5958         endif
5959 C A1 kernel(j+1) A2T
5960 cd        do iii=1,2
5961 cd          write (iout,'(3f10.5,5x,3f10.5)')
5962 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5963 cd        enddo
5964         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5965      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5966      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5967 C Following matrices are needed only for 6-th order cumulants
5968         IF (wcorr6.gt.0.0d0) THEN
5969         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5970      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5971      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5972         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5973      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5974      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5975      &   ADtEAderx(1,1,1,1,1,1))
5976         lprn=.false.
5977         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5978      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5979      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5980      &   ADtEA1derx(1,1,1,1,1,1))
5981         ENDIF
5982 C End 6-th order cumulants
5983 cd        lprn=.false.
5984 cd        if (lprn) then
5985 cd        write (2,*) 'In calc_eello6'
5986 cd        do iii=1,2
5987 cd          write (2,*) 'iii=',iii
5988 cd          do kkk=1,5
5989 cd            write (2,*) 'kkk=',kkk
5990 cd            do jjj=1,2
5991 cd              write (2,'(3(2f10.5),5x)')
5992 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5993 cd            enddo
5994 cd          enddo
5995 cd        enddo
5996 cd        endif
5997         call transpose2(EUgder(1,1,k),auxmat(1,1))
5998         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5999         call transpose2(EUg(1,1,k),auxmat(1,1))
6000         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6001         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6002         do iii=1,2
6003           do kkk=1,5
6004             do lll=1,3
6005               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6006      &          EAEAderx(1,1,lll,kkk,iii,1))
6007             enddo
6008           enddo
6009         enddo
6010 C A1T kernel(i+1) A2
6011         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6012      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6013      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6014 C Following matrices are needed only for 6-th order cumulants
6015         IF (wcorr6.gt.0.0d0) THEN
6016         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6017      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6018      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6019         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6020      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6021      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6022      &   ADtEAderx(1,1,1,1,1,2))
6023         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6024      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6025      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6026      &   ADtEA1derx(1,1,1,1,1,2))
6027         ENDIF
6028 C End 6-th order cumulants
6029         call transpose2(EUgder(1,1,l),auxmat(1,1))
6030         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6031         call transpose2(EUg(1,1,l),auxmat(1,1))
6032         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6033         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6034         do iii=1,2
6035           do kkk=1,5
6036             do lll=1,3
6037               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6038      &          EAEAderx(1,1,lll,kkk,iii,2))
6039             enddo
6040           enddo
6041         enddo
6042 C AEAb1 and AEAb2
6043 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6044 C They are needed only when the fifth- or the sixth-order cumulants are
6045 C indluded.
6046         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6047         call transpose2(AEA(1,1,1),auxmat(1,1))
6048         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6049         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6050         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6051         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6052         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6053         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6054         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6055         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6056         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6057         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6058         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6059         call transpose2(AEA(1,1,2),auxmat(1,1))
6060         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6061         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6062         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6063         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6064         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6065         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6066         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6067         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6068         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6069         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6070         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6071 C Calculate the Cartesian derivatives of the vectors.
6072         do iii=1,2
6073           do kkk=1,5
6074             do lll=1,3
6075               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6076               call matvec2(auxmat(1,1),b1(1,iti),
6077      &          AEAb1derx(1,lll,kkk,iii,1,1))
6078               call matvec2(auxmat(1,1),Ub2(1,i),
6079      &          AEAb2derx(1,lll,kkk,iii,1,1))
6080               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6081      &          AEAb1derx(1,lll,kkk,iii,2,1))
6082               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6083      &          AEAb2derx(1,lll,kkk,iii,2,1))
6084               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6085               call matvec2(auxmat(1,1),b1(1,itj),
6086      &          AEAb1derx(1,lll,kkk,iii,1,2))
6087               call matvec2(auxmat(1,1),Ub2(1,j),
6088      &          AEAb2derx(1,lll,kkk,iii,1,2))
6089               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6090      &          AEAb1derx(1,lll,kkk,iii,2,2))
6091               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6092      &          AEAb2derx(1,lll,kkk,iii,2,2))
6093             enddo
6094           enddo
6095         enddo
6096         ENDIF
6097 C End vectors
6098       else
6099 C Antiparallel orientation of the two CA-CA-CA frames.
6100         if (i.gt.1) then
6101           iti=itortyp(itype(i))
6102         else
6103           iti=ntortyp+1
6104         endif
6105         itk1=itortyp(itype(k+1))
6106         itl=itortyp(itype(l))
6107         itj=itortyp(itype(j))
6108         if (j.lt.nres-1) then
6109           itj1=itortyp(itype(j+1))
6110         else
6111           itj1=ntortyp+1
6112         endif
6113 C A2 kernel(j-1)T A1T
6114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6115      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6116      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6117 C Following matrices are needed only for 6-th order cumulants
6118         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6119      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6120         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6121      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6122      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6123         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6124      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6125      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6126      &   ADtEAderx(1,1,1,1,1,1))
6127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6128      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6129      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6130      &   ADtEA1derx(1,1,1,1,1,1))
6131         ENDIF
6132 C End 6-th order cumulants
6133         call transpose2(EUgder(1,1,k),auxmat(1,1))
6134         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6135         call transpose2(EUg(1,1,k),auxmat(1,1))
6136         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6137         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6138         do iii=1,2
6139           do kkk=1,5
6140             do lll=1,3
6141               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6142      &          EAEAderx(1,1,lll,kkk,iii,1))
6143             enddo
6144           enddo
6145         enddo
6146 C A2T kernel(i+1)T A1
6147         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6148      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6149      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6150 C Following matrices are needed only for 6-th order cumulants
6151         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6152      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6153         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6154      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6155      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6156         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6157      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6158      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6159      &   ADtEAderx(1,1,1,1,1,2))
6160         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6161      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6162      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6163      &   ADtEA1derx(1,1,1,1,1,2))
6164         ENDIF
6165 C End 6-th order cumulants
6166         call transpose2(EUgder(1,1,j),auxmat(1,1))
6167         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6168         call transpose2(EUg(1,1,j),auxmat(1,1))
6169         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6170         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6171         do iii=1,2
6172           do kkk=1,5
6173             do lll=1,3
6174               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6175      &          EAEAderx(1,1,lll,kkk,iii,2))
6176             enddo
6177           enddo
6178         enddo
6179 C AEAb1 and AEAb2
6180 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6181 C They are needed only when the fifth- or the sixth-order cumulants are
6182 C indluded.
6183         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6184      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6185         call transpose2(AEA(1,1,1),auxmat(1,1))
6186         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6187         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6188         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6189         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6190         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6191         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6192         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6193         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6194         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6195         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6196         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6197         call transpose2(AEA(1,1,2),auxmat(1,1))
6198         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6199         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6200         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6201         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6202         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6203         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6204         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6205         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6206         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6207         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6208         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6209 C Calculate the Cartesian derivatives of the vectors.
6210         do iii=1,2
6211           do kkk=1,5
6212             do lll=1,3
6213               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6214               call matvec2(auxmat(1,1),b1(1,iti),
6215      &          AEAb1derx(1,lll,kkk,iii,1,1))
6216               call matvec2(auxmat(1,1),Ub2(1,i),
6217      &          AEAb2derx(1,lll,kkk,iii,1,1))
6218               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6219      &          AEAb1derx(1,lll,kkk,iii,2,1))
6220               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6221      &          AEAb2derx(1,lll,kkk,iii,2,1))
6222               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6223               call matvec2(auxmat(1,1),b1(1,itl),
6224      &          AEAb1derx(1,lll,kkk,iii,1,2))
6225               call matvec2(auxmat(1,1),Ub2(1,l),
6226      &          AEAb2derx(1,lll,kkk,iii,1,2))
6227               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6228      &          AEAb1derx(1,lll,kkk,iii,2,2))
6229               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6230      &          AEAb2derx(1,lll,kkk,iii,2,2))
6231             enddo
6232           enddo
6233         enddo
6234         ENDIF
6235 C End vectors
6236       endif
6237       return
6238       end
6239 C---------------------------------------------------------------------------
6240       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6241      &  KK,KKderg,AKA,AKAderg,AKAderx)
6242       implicit none
6243       integer nderg
6244       logical transp
6245       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6246      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6247      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6248       integer iii,kkk,lll
6249       integer jjj,mmm
6250       logical lprn
6251       common /kutas/ lprn
6252       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6253       do iii=1,nderg
6254         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6255      &    AKAderg(1,1,iii))
6256       enddo
6257 cd      if (lprn) write (2,*) 'In kernel'
6258       do kkk=1,5
6259 cd        if (lprn) write (2,*) 'kkk=',kkk
6260         do lll=1,3
6261           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6262      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6263 cd          if (lprn) then
6264 cd            write (2,*) 'lll=',lll
6265 cd            write (2,*) 'iii=1'
6266 cd            do jjj=1,2
6267 cd              write (2,'(3(2f10.5),5x)')
6268 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6269 cd            enddo
6270 cd          endif
6271           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6272      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6273 cd          if (lprn) then
6274 cd            write (2,*) 'lll=',lll
6275 cd            write (2,*) 'iii=2'
6276 cd            do jjj=1,2
6277 cd              write (2,'(3(2f10.5),5x)')
6278 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6279 cd            enddo
6280 cd          endif
6281         enddo
6282       enddo
6283       return
6284       end
6285 C---------------------------------------------------------------------------
6286       double precision function eello4(i,j,k,l,jj,kk)
6287       implicit real*8 (a-h,o-z)
6288       include 'DIMENSIONS'
6289       include 'sizesclu.dat'
6290       include 'COMMON.IOUNITS'
6291       include 'COMMON.CHAIN'
6292       include 'COMMON.DERIV'
6293       include 'COMMON.INTERACT'
6294       include 'COMMON.CONTACTS'
6295       include 'COMMON.TORSION'
6296       include 'COMMON.VAR'
6297       include 'COMMON.GEO'
6298       double precision pizda(2,2),ggg1(3),ggg2(3)
6299 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6300 cd        eello4=0.0d0
6301 cd        return
6302 cd      endif
6303 cd      print *,'eello4:',i,j,k,l,jj,kk
6304 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6305 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6306 cold      eij=facont_hb(jj,i)
6307 cold      ekl=facont_hb(kk,k)
6308 cold      ekont=eij*ekl
6309       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6310       if (calc_grad) then
6311 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6312       gcorr_loc(k-1)=gcorr_loc(k-1)
6313      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6314       if (l.eq.j+1) then
6315         gcorr_loc(l-1)=gcorr_loc(l-1)
6316      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6317       else
6318         gcorr_loc(j-1)=gcorr_loc(j-1)
6319      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6320       endif
6321       do iii=1,2
6322         do kkk=1,5
6323           do lll=1,3
6324             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6325      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6326 cd            derx(lll,kkk,iii)=0.0d0
6327           enddo
6328         enddo
6329       enddo
6330 cd      gcorr_loc(l-1)=0.0d0
6331 cd      gcorr_loc(j-1)=0.0d0
6332 cd      gcorr_loc(k-1)=0.0d0
6333 cd      eel4=1.0d0
6334 cd      write (iout,*)'Contacts have occurred for peptide groups',
6335 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6336 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6337       if (j.lt.nres-1) then
6338         j1=j+1
6339         j2=j-1
6340       else
6341         j1=j-1
6342         j2=j-2
6343       endif
6344       if (l.lt.nres-1) then
6345         l1=l+1
6346         l2=l-1
6347       else
6348         l1=l-1
6349         l2=l-2
6350       endif
6351       do ll=1,3
6352 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6353         ggg1(ll)=eel4*g_contij(ll,1)
6354         ggg2(ll)=eel4*g_contij(ll,2)
6355         ghalf=0.5d0*ggg1(ll)
6356 cd        ghalf=0.0d0
6357         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6358         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6359         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6360         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6361 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6362         ghalf=0.5d0*ggg2(ll)
6363 cd        ghalf=0.0d0
6364         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6365         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6366         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6367         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6368       enddo
6369 cd      goto 1112
6370       do m=i+1,j-1
6371         do ll=1,3
6372 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6373           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6374         enddo
6375       enddo
6376       do m=k+1,l-1
6377         do ll=1,3
6378 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6379           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6380         enddo
6381       enddo
6382 1112  continue
6383       do m=i+2,j2
6384         do ll=1,3
6385           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6386         enddo
6387       enddo
6388       do m=k+2,l2
6389         do ll=1,3
6390           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6391         enddo
6392       enddo
6393 cd      do iii=1,nres-3
6394 cd        write (2,*) iii,gcorr_loc(iii)
6395 cd      enddo
6396       endif
6397       eello4=ekont*eel4
6398 cd      write (2,*) 'ekont',ekont
6399 cd      write (iout,*) 'eello4',ekont*eel4
6400       return
6401       end
6402 C---------------------------------------------------------------------------
6403       double precision function eello5(i,j,k,l,jj,kk)
6404       implicit real*8 (a-h,o-z)
6405       include 'DIMENSIONS'
6406       include 'sizesclu.dat'
6407       include 'COMMON.IOUNITS'
6408       include 'COMMON.CHAIN'
6409       include 'COMMON.DERIV'
6410       include 'COMMON.INTERACT'
6411       include 'COMMON.CONTACTS'
6412       include 'COMMON.TORSION'
6413       include 'COMMON.VAR'
6414       include 'COMMON.GEO'
6415       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6416       double precision ggg1(3),ggg2(3)
6417 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6418 C                                                                              C
6419 C                            Parallel chains                                   C
6420 C                                                                              C
6421 C          o             o                   o             o                   C
6422 C         /l\           / \             \   / \           / \   /              C
6423 C        /   \         /   \             \ /   \         /   \ /               C
6424 C       j| o |l1       | o |              o| o |         | o |o                C
6425 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6426 C      \i/   \         /   \ /             /   \         /   \                 C
6427 C       o    k1             o                                                  C
6428 C         (I)          (II)                (III)          (IV)                 C
6429 C                                                                              C
6430 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6431 C                                                                              C
6432 C                            Antiparallel chains                               C
6433 C                                                                              C
6434 C          o             o                   o             o                   C
6435 C         /j\           / \             \   / \           / \   /              C
6436 C        /   \         /   \             \ /   \         /   \ /               C
6437 C      j1| o |l        | o |              o| o |         | o |o                C
6438 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6439 C      \i/   \         /   \ /             /   \         /   \                 C
6440 C       o     k1            o                                                  C
6441 C         (I)          (II)                (III)          (IV)                 C
6442 C                                                                              C
6443 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6444 C                                                                              C
6445 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6446 C                                                                              C
6447 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6448 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6449 cd        eello5=0.0d0
6450 cd        return
6451 cd      endif
6452 cd      write (iout,*)
6453 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6454 cd     &   ' and',k,l
6455       itk=itortyp(itype(k))
6456       itl=itortyp(itype(l))
6457       itj=itortyp(itype(j))
6458       eello5_1=0.0d0
6459       eello5_2=0.0d0
6460       eello5_3=0.0d0
6461       eello5_4=0.0d0
6462 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6463 cd     &   eel5_3_num,eel5_4_num)
6464       do iii=1,2
6465         do kkk=1,5
6466           do lll=1,3
6467             derx(lll,kkk,iii)=0.0d0
6468           enddo
6469         enddo
6470       enddo
6471 cd      eij=facont_hb(jj,i)
6472 cd      ekl=facont_hb(kk,k)
6473 cd      ekont=eij*ekl
6474 cd      write (iout,*)'Contacts have occurred for peptide groups',
6475 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6476 cd      goto 1111
6477 C Contribution from the graph I.
6478 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6479 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6480       call transpose2(EUg(1,1,k),auxmat(1,1))
6481       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6482       vv(1)=pizda(1,1)-pizda(2,2)
6483       vv(2)=pizda(1,2)+pizda(2,1)
6484       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6485      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6486       if (calc_grad) then
6487 C Explicit gradient in virtual-dihedral angles.
6488       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6489      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6490      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6491       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6492       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6493       vv(1)=pizda(1,1)-pizda(2,2)
6494       vv(2)=pizda(1,2)+pizda(2,1)
6495       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6496      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6497      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6498       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6499       vv(1)=pizda(1,1)-pizda(2,2)
6500       vv(2)=pizda(1,2)+pizda(2,1)
6501       if (l.eq.j+1) then
6502         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6503      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6504      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6505       else
6506         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6507      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6509       endif
6510 C Cartesian gradient
6511       do iii=1,2
6512         do kkk=1,5
6513           do lll=1,3
6514             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6515      &        pizda(1,1))
6516             vv(1)=pizda(1,1)-pizda(2,2)
6517             vv(2)=pizda(1,2)+pizda(2,1)
6518             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6519      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6520      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6521           enddo
6522         enddo
6523       enddo
6524 c      goto 1112
6525       endif
6526 c1111  continue
6527 C Contribution from graph II
6528       call transpose2(EE(1,1,itk),auxmat(1,1))
6529       call matmat2(auxmat(1,1),AEA(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       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6533      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6534       if (calc_grad) then
6535 C Explicit gradient in virtual-dihedral angles.
6536       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6537      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6538       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6539       vv(1)=pizda(1,1)+pizda(2,2)
6540       vv(2)=pizda(2,1)-pizda(1,2)
6541       if (l.eq.j+1) then
6542         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6543      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6544      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6545       else
6546         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6547      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6548      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6549       endif
6550 C Cartesian gradient
6551       do iii=1,2
6552         do kkk=1,5
6553           do lll=1,3
6554             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6555      &        pizda(1,1))
6556             vv(1)=pizda(1,1)+pizda(2,2)
6557             vv(2)=pizda(2,1)-pizda(1,2)
6558             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6559      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6560      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6561           enddo
6562         enddo
6563       enddo
6564 cd      goto 1112
6565       endif
6566 cd1111  continue
6567       if (l.eq.j+1) then
6568 cd        goto 1110
6569 C Parallel orientation
6570 C Contribution from graph III
6571         call transpose2(EUg(1,1,l),auxmat(1,1))
6572         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6573         vv(1)=pizda(1,1)-pizda(2,2)
6574         vv(2)=pizda(1,2)+pizda(2,1)
6575         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6576      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6577         if (calc_grad) then
6578 C Explicit gradient in virtual-dihedral angles.
6579         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6580      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6581      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6582         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6583         vv(1)=pizda(1,1)-pizda(2,2)
6584         vv(2)=pizda(1,2)+pizda(2,1)
6585         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6586      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6587      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6588         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6589         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6590         vv(1)=pizda(1,1)-pizda(2,2)
6591         vv(2)=pizda(1,2)+pizda(2,1)
6592         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6593      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6595 C Cartesian gradient
6596         do iii=1,2
6597           do kkk=1,5
6598             do lll=1,3
6599               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6600      &          pizda(1,1))
6601               vv(1)=pizda(1,1)-pizda(2,2)
6602               vv(2)=pizda(1,2)+pizda(2,1)
6603               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6604      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6605      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6606             enddo
6607           enddo
6608         enddo
6609 cd        goto 1112
6610         endif
6611 C Contribution from graph IV
6612 cd1110    continue
6613         call transpose2(EE(1,1,itl),auxmat(1,1))
6614         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6618      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6619         if (calc_grad) then
6620 C Explicit gradient in virtual-dihedral angles.
6621         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6622      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6623         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6624         vv(1)=pizda(1,1)+pizda(2,2)
6625         vv(2)=pizda(2,1)-pizda(1,2)
6626         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6627      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6628      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6629 C Cartesian gradient
6630         do iii=1,2
6631           do kkk=1,5
6632             do lll=1,3
6633               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6634      &          pizda(1,1))
6635               vv(1)=pizda(1,1)+pizda(2,2)
6636               vv(2)=pizda(2,1)-pizda(1,2)
6637               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6638      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6639      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6640             enddo
6641           enddo
6642         enddo
6643         endif
6644       else
6645 C Antiparallel orientation
6646 C Contribution from graph III
6647 c        goto 1110
6648         call transpose2(EUg(1,1,j),auxmat(1,1))
6649         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6650         vv(1)=pizda(1,1)-pizda(2,2)
6651         vv(2)=pizda(1,2)+pizda(2,1)
6652         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6653      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6654         if (calc_grad) then
6655 C Explicit gradient in virtual-dihedral angles.
6656         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6657      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6658      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6659         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6660         vv(1)=pizda(1,1)-pizda(2,2)
6661         vv(2)=pizda(1,2)+pizda(2,1)
6662         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6663      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6664      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6665         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6666         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6667         vv(1)=pizda(1,1)-pizda(2,2)
6668         vv(2)=pizda(1,2)+pizda(2,1)
6669         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6670      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6671      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6672 C Cartesian gradient
6673         do iii=1,2
6674           do kkk=1,5
6675             do lll=1,3
6676               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6677      &          pizda(1,1))
6678               vv(1)=pizda(1,1)-pizda(2,2)
6679               vv(2)=pizda(1,2)+pizda(2,1)
6680               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6681      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6682      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6683             enddo
6684           enddo
6685         enddo
6686 cd        goto 1112
6687         endif
6688 C Contribution from graph IV
6689 1110    continue
6690         call transpose2(EE(1,1,itj),auxmat(1,1))
6691         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6695      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6696         if (calc_grad) then
6697 C Explicit gradient in virtual-dihedral angles.
6698         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6699      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6700         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6701         vv(1)=pizda(1,1)+pizda(2,2)
6702         vv(2)=pizda(2,1)-pizda(1,2)
6703         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6704      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6705      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6706 C Cartesian gradient
6707         do iii=1,2
6708           do kkk=1,5
6709             do lll=1,3
6710               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6711      &          pizda(1,1))
6712               vv(1)=pizda(1,1)+pizda(2,2)
6713               vv(2)=pizda(2,1)-pizda(1,2)
6714               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6715      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6716      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6717             enddo
6718           enddo
6719         enddo
6720       endif
6721       endif
6722 1112  continue
6723       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6724 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6725 cd        write (2,*) 'ijkl',i,j,k,l
6726 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6727 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6728 cd      endif
6729 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6730 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6731 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6732 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6733       if (calc_grad) then
6734       if (j.lt.nres-1) then
6735         j1=j+1
6736         j2=j-1
6737       else
6738         j1=j-1
6739         j2=j-2
6740       endif
6741       if (l.lt.nres-1) then
6742         l1=l+1
6743         l2=l-1
6744       else
6745         l1=l-1
6746         l2=l-2
6747       endif
6748 cd      eij=1.0d0
6749 cd      ekl=1.0d0
6750 cd      ekont=1.0d0
6751 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6752       do ll=1,3
6753         ggg1(ll)=eel5*g_contij(ll,1)
6754         ggg2(ll)=eel5*g_contij(ll,2)
6755 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6756         ghalf=0.5d0*ggg1(ll)
6757 cd        ghalf=0.0d0
6758         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6759         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6760         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6761         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6762 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6763         ghalf=0.5d0*ggg2(ll)
6764 cd        ghalf=0.0d0
6765         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6766         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6767         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6768         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6769       enddo
6770 cd      goto 1112
6771       do m=i+1,j-1
6772         do ll=1,3
6773 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6774           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6775         enddo
6776       enddo
6777       do m=k+1,l-1
6778         do ll=1,3
6779 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6780           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6781         enddo
6782       enddo
6783 c1112  continue
6784       do m=i+2,j2
6785         do ll=1,3
6786           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6787         enddo
6788       enddo
6789       do m=k+2,l2
6790         do ll=1,3
6791           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6792         enddo
6793       enddo
6794 cd      do iii=1,nres-3
6795 cd        write (2,*) iii,g_corr5_loc(iii)
6796 cd      enddo
6797       endif
6798       eello5=ekont*eel5
6799 cd      write (2,*) 'ekont',ekont
6800 cd      write (iout,*) 'eello5',ekont*eel5
6801       return
6802       end
6803 c--------------------------------------------------------------------------
6804       double precision function eello6(i,j,k,l,jj,kk)
6805       implicit real*8 (a-h,o-z)
6806       include 'DIMENSIONS'
6807       include 'sizesclu.dat'
6808       include 'COMMON.IOUNITS'
6809       include 'COMMON.CHAIN'
6810       include 'COMMON.DERIV'
6811       include 'COMMON.INTERACT'
6812       include 'COMMON.CONTACTS'
6813       include 'COMMON.TORSION'
6814       include 'COMMON.VAR'
6815       include 'COMMON.GEO'
6816       include 'COMMON.FFIELD'
6817       double precision ggg1(3),ggg2(3)
6818 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6819 cd        eello6=0.0d0
6820 cd        return
6821 cd      endif
6822 cd      write (iout,*)
6823 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6824 cd     &   ' and',k,l
6825       eello6_1=0.0d0
6826       eello6_2=0.0d0
6827       eello6_3=0.0d0
6828       eello6_4=0.0d0
6829       eello6_5=0.0d0
6830       eello6_6=0.0d0
6831 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6832 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6833       do iii=1,2
6834         do kkk=1,5
6835           do lll=1,3
6836             derx(lll,kkk,iii)=0.0d0
6837           enddo
6838         enddo
6839       enddo
6840 cd      eij=facont_hb(jj,i)
6841 cd      ekl=facont_hb(kk,k)
6842 cd      ekont=eij*ekl
6843 cd      eij=1.0d0
6844 cd      ekl=1.0d0
6845 cd      ekont=1.0d0
6846       if (l.eq.j+1) then
6847         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6848         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6849         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6850         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6851         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6852         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6853       else
6854         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6855         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6856         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6857         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6858         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6859           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6860         else
6861           eello6_5=0.0d0
6862         endif
6863         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6864       endif
6865 C If turn contributions are considered, they will be handled separately.
6866       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6867 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6868 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6869 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6870 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6871 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6872 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6873 cd      goto 1112
6874       if (calc_grad) then
6875       if (j.lt.nres-1) then
6876         j1=j+1
6877         j2=j-1
6878       else
6879         j1=j-1
6880         j2=j-2
6881       endif
6882       if (l.lt.nres-1) then
6883         l1=l+1
6884         l2=l-1
6885       else
6886         l1=l-1
6887         l2=l-2
6888       endif
6889       do ll=1,3
6890         ggg1(ll)=eel6*g_contij(ll,1)
6891         ggg2(ll)=eel6*g_contij(ll,2)
6892 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6893         ghalf=0.5d0*ggg1(ll)
6894 cd        ghalf=0.0d0
6895         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6896         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6897         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6898         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6899         ghalf=0.5d0*ggg2(ll)
6900 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6901 cd        ghalf=0.0d0
6902         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6903         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6904         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6905         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6906       enddo
6907 cd      goto 1112
6908       do m=i+1,j-1
6909         do ll=1,3
6910 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6911           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6912         enddo
6913       enddo
6914       do m=k+1,l-1
6915         do ll=1,3
6916 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6917           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6918         enddo
6919       enddo
6920 1112  continue
6921       do m=i+2,j2
6922         do ll=1,3
6923           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6924         enddo
6925       enddo
6926       do m=k+2,l2
6927         do ll=1,3
6928           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6929         enddo
6930       enddo
6931 cd      do iii=1,nres-3
6932 cd        write (2,*) iii,g_corr6_loc(iii)
6933 cd      enddo
6934       endif
6935       eello6=ekont*eel6
6936 cd      write (2,*) 'ekont',ekont
6937 cd      write (iout,*) 'eello6',ekont*eel6
6938       return
6939       end
6940 c--------------------------------------------------------------------------
6941       double precision function eello6_graph1(i,j,k,l,imat,swap)
6942       implicit real*8 (a-h,o-z)
6943       include 'DIMENSIONS'
6944       include 'sizesclu.dat'
6945       include 'COMMON.IOUNITS'
6946       include 'COMMON.CHAIN'
6947       include 'COMMON.DERIV'
6948       include 'COMMON.INTERACT'
6949       include 'COMMON.CONTACTS'
6950       include 'COMMON.TORSION'
6951       include 'COMMON.VAR'
6952       include 'COMMON.GEO'
6953       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6954       logical swap
6955       logical lprn
6956       common /kutas/ lprn
6957 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6958 C                                                                              C
6959 C      Parallel       Antiparallel                                             C
6960 C                                                                              C
6961 C          o             o                                                     C
6962 C         /l\           /j\                                                    C
6963 C        /   \         /   \                                                   C
6964 C       /| o |         | o |\                                                  C
6965 C     \ j|/k\|  /   \  |/k\|l /                                                C
6966 C      \ /   \ /     \ /   \ /                                                 C
6967 C       o     o       o     o                                                  C
6968 C       i             i                                                        C
6969 C                                                                              C
6970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6971       itk=itortyp(itype(k))
6972       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6973       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6974       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6975       call transpose2(EUgC(1,1,k),auxmat(1,1))
6976       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6977       vv1(1)=pizda1(1,1)-pizda1(2,2)
6978       vv1(2)=pizda1(1,2)+pizda1(2,1)
6979       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6980       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6981       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6982       s5=scalar2(vv(1),Dtobr2(1,i))
6983 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6984       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6985       if (.not. calc_grad) return
6986       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6987      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6988      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6989      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6990      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6991      & +scalar2(vv(1),Dtobr2der(1,i)))
6992       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6993       vv1(1)=pizda1(1,1)-pizda1(2,2)
6994       vv1(2)=pizda1(1,2)+pizda1(2,1)
6995       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6996       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6997       if (l.eq.j+1) then
6998         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6999      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7000      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7001      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7002      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7003       else
7004         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7005      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7006      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7007      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7008      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7009       endif
7010       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7011       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7012       vv1(1)=pizda1(1,1)-pizda1(2,2)
7013       vv1(2)=pizda1(1,2)+pizda1(2,1)
7014       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7015      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7016      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7017      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7018       do iii=1,2
7019         if (swap) then
7020           ind=3-iii
7021         else
7022           ind=iii
7023         endif
7024         do kkk=1,5
7025           do lll=1,3
7026             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7027             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7028             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7029             call transpose2(EUgC(1,1,k),auxmat(1,1))
7030             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7031      &        pizda1(1,1))
7032             vv1(1)=pizda1(1,1)-pizda1(2,2)
7033             vv1(2)=pizda1(1,2)+pizda1(2,1)
7034             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7035             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7036      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7037             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7038      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7039             s5=scalar2(vv(1),Dtobr2(1,i))
7040             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7041           enddo
7042         enddo
7043       enddo
7044       return
7045       end
7046 c----------------------------------------------------------------------------
7047       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7048       implicit real*8 (a-h,o-z)
7049       include 'DIMENSIONS'
7050       include 'sizesclu.dat'
7051       include 'COMMON.IOUNITS'
7052       include 'COMMON.CHAIN'
7053       include 'COMMON.DERIV'
7054       include 'COMMON.INTERACT'
7055       include 'COMMON.CONTACTS'
7056       include 'COMMON.TORSION'
7057       include 'COMMON.VAR'
7058       include 'COMMON.GEO'
7059       logical swap
7060       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7061      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7062       logical lprn
7063       common /kutas/ lprn
7064 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7065 C                                                                              C
7066 C      Parallel       Antiparallel                                             C
7067 C                                                                              C
7068 C          o             o                                                     C
7069 C     \   /l\           /j\   /                                                C
7070 C      \ /   \         /   \ /                                                 C
7071 C       o| o |         | o |o                                                  C
7072 C     \ j|/k\|      \  |/k\|l                                                  C
7073 C      \ /   \       \ /   \                                                   C
7074 C       o             o                                                        C
7075 C       i             i                                                        C
7076 C                                                                              C
7077 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7078 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7079 C AL 7/4/01 s1 would occur in the sixth-order moment,
7080 C           but not in a cluster cumulant
7081 #ifdef MOMENT
7082       s1=dip(1,jj,i)*dip(1,kk,k)
7083 #endif
7084       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7085       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7086       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7087       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7088       call transpose2(EUg(1,1,k),auxmat(1,1))
7089       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7090       vv(1)=pizda(1,1)-pizda(2,2)
7091       vv(2)=pizda(1,2)+pizda(2,1)
7092       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7093 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7094 #ifdef MOMENT
7095       eello6_graph2=-(s1+s2+s3+s4)
7096 #else
7097       eello6_graph2=-(s2+s3+s4)
7098 #endif
7099 c      eello6_graph2=-s3
7100       if (.not. calc_grad) return
7101 C Derivatives in gamma(i-1)
7102       if (i.gt.1) then
7103 #ifdef MOMENT
7104         s1=dipderg(1,jj,i)*dip(1,kk,k)
7105 #endif
7106         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7107         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7108         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7109         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7110 #ifdef MOMENT
7111         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7112 #else
7113         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7114 #endif
7115 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7116       endif
7117 C Derivatives in gamma(k-1)
7118 #ifdef MOMENT
7119       s1=dip(1,jj,i)*dipderg(1,kk,k)
7120 #endif
7121       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7122       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7123       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7124       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7125       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7126       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7127       vv(1)=pizda(1,1)-pizda(2,2)
7128       vv(2)=pizda(1,2)+pizda(2,1)
7129       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7130 #ifdef MOMENT
7131       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7132 #else
7133       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7134 #endif
7135 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7136 C Derivatives in gamma(j-1) or gamma(l-1)
7137       if (j.gt.1) then
7138 #ifdef MOMENT
7139         s1=dipderg(3,jj,i)*dip(1,kk,k)
7140 #endif
7141         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7142         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7143         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7144         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7145         vv(1)=pizda(1,1)-pizda(2,2)
7146         vv(2)=pizda(1,2)+pizda(2,1)
7147         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7148 #ifdef MOMENT
7149         if (swap) then
7150           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7151         else
7152           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7153         endif
7154 #endif
7155         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7156 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7157       endif
7158 C Derivatives in gamma(l-1) or gamma(j-1)
7159       if (l.gt.1) then
7160 #ifdef MOMENT
7161         s1=dip(1,jj,i)*dipderg(3,kk,k)
7162 #endif
7163         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7164         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7165         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7166         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7167         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7168         vv(1)=pizda(1,1)-pizda(2,2)
7169         vv(2)=pizda(1,2)+pizda(2,1)
7170         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7171 #ifdef MOMENT
7172         if (swap) then
7173           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7174         else
7175           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7176         endif
7177 #endif
7178         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7179 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7180       endif
7181 C Cartesian derivatives.
7182       if (lprn) then
7183         write (2,*) 'In eello6_graph2'
7184         do iii=1,2
7185           write (2,*) 'iii=',iii
7186           do kkk=1,5
7187             write (2,*) 'kkk=',kkk
7188             do jjj=1,2
7189               write (2,'(3(2f10.5),5x)')
7190      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7191             enddo
7192           enddo
7193         enddo
7194       endif
7195       do iii=1,2
7196         do kkk=1,5
7197           do lll=1,3
7198 #ifdef MOMENT
7199             if (iii.eq.1) then
7200               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7201             else
7202               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7203             endif
7204 #endif
7205             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7206      &        auxvec(1))
7207             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7208             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7209      &        auxvec(1))
7210             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7211             call transpose2(EUg(1,1,k),auxmat(1,1))
7212             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7213      &        pizda(1,1))
7214             vv(1)=pizda(1,1)-pizda(2,2)
7215             vv(2)=pizda(1,2)+pizda(2,1)
7216             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7217 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7218 #ifdef MOMENT
7219             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7220 #else
7221             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7222 #endif
7223             if (swap) then
7224               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7225             else
7226               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7227             endif
7228           enddo
7229         enddo
7230       enddo
7231       return
7232       end
7233 c----------------------------------------------------------------------------
7234       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7235       implicit real*8 (a-h,o-z)
7236       include 'DIMENSIONS'
7237       include 'sizesclu.dat'
7238       include 'COMMON.IOUNITS'
7239       include 'COMMON.CHAIN'
7240       include 'COMMON.DERIV'
7241       include 'COMMON.INTERACT'
7242       include 'COMMON.CONTACTS'
7243       include 'COMMON.TORSION'
7244       include 'COMMON.VAR'
7245       include 'COMMON.GEO'
7246       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7247       logical swap
7248 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7249 C                                                                              C
7250 C      Parallel       Antiparallel                                             C
7251 C                                                                              C
7252 C          o             o                                                     C
7253 C         /l\   /   \   /j\                                                    C
7254 C        /   \ /     \ /   \                                                   C
7255 C       /| o |o       o| o |\                                                  C
7256 C       j|/k\|  /      |/k\|l /                                                C
7257 C        /   \ /       /   \ /                                                 C
7258 C       /     o       /     o                                                  C
7259 C       i             i                                                        C
7260 C                                                                              C
7261 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7262 C
7263 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7264 C           energy moment and not to the cluster cumulant.
7265       iti=itortyp(itype(i))
7266       if (j.lt.nres-1) then
7267         itj1=itortyp(itype(j+1))
7268       else
7269         itj1=ntortyp+1
7270       endif
7271       itk=itortyp(itype(k))
7272       itk1=itortyp(itype(k+1))
7273       if (l.lt.nres-1) then
7274         itl1=itortyp(itype(l+1))
7275       else
7276         itl1=ntortyp+1
7277       endif
7278 #ifdef MOMENT
7279       s1=dip(4,jj,i)*dip(4,kk,k)
7280 #endif
7281       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7282       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7283       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7284       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7285       call transpose2(EE(1,1,itk),auxmat(1,1))
7286       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7287       vv(1)=pizda(1,1)+pizda(2,2)
7288       vv(2)=pizda(2,1)-pizda(1,2)
7289       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7290 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7291 #ifdef MOMENT
7292       eello6_graph3=-(s1+s2+s3+s4)
7293 #else
7294       eello6_graph3=-(s2+s3+s4)
7295 #endif
7296 c      eello6_graph3=-s4
7297       if (.not. calc_grad) return
7298 C Derivatives in gamma(k-1)
7299       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7300       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7301       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7302       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7303 C Derivatives in gamma(l-1)
7304       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7305       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7306       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7307       vv(1)=pizda(1,1)+pizda(2,2)
7308       vv(2)=pizda(2,1)-pizda(1,2)
7309       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7310       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7311 C Cartesian derivatives.
7312       do iii=1,2
7313         do kkk=1,5
7314           do lll=1,3
7315 #ifdef MOMENT
7316             if (iii.eq.1) then
7317               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7318             else
7319               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7320             endif
7321 #endif
7322             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7323      &        auxvec(1))
7324             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7325             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7326      &        auxvec(1))
7327             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7328             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7329      &        pizda(1,1))
7330             vv(1)=pizda(1,1)+pizda(2,2)
7331             vv(2)=pizda(2,1)-pizda(1,2)
7332             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7333 #ifdef MOMENT
7334             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7335 #else
7336             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7337 #endif
7338             if (swap) then
7339               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7340             else
7341               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7342             endif
7343 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7344           enddo
7345         enddo
7346       enddo
7347       return
7348       end
7349 c----------------------------------------------------------------------------
7350       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7351       implicit real*8 (a-h,o-z)
7352       include 'DIMENSIONS'
7353       include 'sizesclu.dat'
7354       include 'COMMON.IOUNITS'
7355       include 'COMMON.CHAIN'
7356       include 'COMMON.DERIV'
7357       include 'COMMON.INTERACT'
7358       include 'COMMON.CONTACTS'
7359       include 'COMMON.TORSION'
7360       include 'COMMON.VAR'
7361       include 'COMMON.GEO'
7362       include 'COMMON.FFIELD'
7363       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7364      & auxvec1(2),auxmat1(2,2)
7365       logical swap
7366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7367 C                                                                              C
7368 C      Parallel       Antiparallel                                             C
7369 C                                                                              C
7370 C          o             o                                                     C
7371 C         /l\   /   \   /j\                                                    C
7372 C        /   \ /     \ /   \                                                   C
7373 C       /| o |o       o| o |\                                                  C
7374 C     \ j|/k\|      \  |/k\|l                                                  C
7375 C      \ /   \       \ /   \                                                   C
7376 C       o     \       o     \                                                  C
7377 C       i             i                                                        C
7378 C                                                                              C
7379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7380 C
7381 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7382 C           energy moment and not to the cluster cumulant.
7383 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7384       iti=itortyp(itype(i))
7385       itj=itortyp(itype(j))
7386       if (j.lt.nres-1) then
7387         itj1=itortyp(itype(j+1))
7388       else
7389         itj1=ntortyp+1
7390       endif
7391       itk=itortyp(itype(k))
7392       if (k.lt.nres-1) then
7393         itk1=itortyp(itype(k+1))
7394       else
7395         itk1=ntortyp+1
7396       endif
7397       itl=itortyp(itype(l))
7398       if (l.lt.nres-1) then
7399         itl1=itortyp(itype(l+1))
7400       else
7401         itl1=ntortyp+1
7402       endif
7403 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7404 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7405 cd     & ' itl',itl,' itl1',itl1
7406 #ifdef MOMENT
7407       if (imat.eq.1) then
7408         s1=dip(3,jj,i)*dip(3,kk,k)
7409       else
7410         s1=dip(2,jj,j)*dip(2,kk,l)
7411       endif
7412 #endif
7413       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7414       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7415       if (j.eq.l+1) then
7416         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7417         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7418       else
7419         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7420         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7421       endif
7422       call transpose2(EUg(1,1,k),auxmat(1,1))
7423       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7424       vv(1)=pizda(1,1)-pizda(2,2)
7425       vv(2)=pizda(2,1)+pizda(1,2)
7426       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7427 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7428 #ifdef MOMENT
7429       eello6_graph4=-(s1+s2+s3+s4)
7430 #else
7431       eello6_graph4=-(s2+s3+s4)
7432 #endif
7433       if (.not. calc_grad) return
7434 C Derivatives in gamma(i-1)
7435       if (i.gt.1) then
7436 #ifdef MOMENT
7437         if (imat.eq.1) then
7438           s1=dipderg(2,jj,i)*dip(3,kk,k)
7439         else
7440           s1=dipderg(4,jj,j)*dip(2,kk,l)
7441         endif
7442 #endif
7443         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7444         if (j.eq.l+1) then
7445           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7446           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7447         else
7448           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7449           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7450         endif
7451         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7452         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7453 cd          write (2,*) 'turn6 derivatives'
7454 #ifdef MOMENT
7455           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7456 #else
7457           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7458 #endif
7459         else
7460 #ifdef MOMENT
7461           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7462 #else
7463           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7464 #endif
7465         endif
7466       endif
7467 C Derivatives in gamma(k-1)
7468 #ifdef MOMENT
7469       if (imat.eq.1) then
7470         s1=dip(3,jj,i)*dipderg(2,kk,k)
7471       else
7472         s1=dip(2,jj,j)*dipderg(4,kk,l)
7473       endif
7474 #endif
7475       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7476       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7477       if (j.eq.l+1) then
7478         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7479         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7480       else
7481         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7482         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7483       endif
7484       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7485       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7486       vv(1)=pizda(1,1)-pizda(2,2)
7487       vv(2)=pizda(2,1)+pizda(1,2)
7488       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7489       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7490 #ifdef MOMENT
7491         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7492 #else
7493         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7494 #endif
7495       else
7496 #ifdef MOMENT
7497         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7498 #else
7499         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7500 #endif
7501       endif
7502 C Derivatives in gamma(j-1) or gamma(l-1)
7503       if (l.eq.j+1 .and. l.gt.1) then
7504         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7505         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7506         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7507         vv(1)=pizda(1,1)-pizda(2,2)
7508         vv(2)=pizda(2,1)+pizda(1,2)
7509         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7510         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7511       else if (j.gt.1) then
7512         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7513         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7514         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7515         vv(1)=pizda(1,1)-pizda(2,2)
7516         vv(2)=pizda(2,1)+pizda(1,2)
7517         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7518         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7519           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7520         else
7521           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7522         endif
7523       endif
7524 C Cartesian derivatives.
7525       do iii=1,2
7526         do kkk=1,5
7527           do lll=1,3
7528 #ifdef MOMENT
7529             if (iii.eq.1) then
7530               if (imat.eq.1) then
7531                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7532               else
7533                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7534               endif
7535             else
7536               if (imat.eq.1) then
7537                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7538               else
7539                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7540               endif
7541             endif
7542 #endif
7543             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7544      &        auxvec(1))
7545             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7546             if (j.eq.l+1) then
7547               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7548      &          b1(1,itj1),auxvec(1))
7549               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7550             else
7551               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7552      &          b1(1,itl1),auxvec(1))
7553               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7554             endif
7555             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7556      &        pizda(1,1))
7557             vv(1)=pizda(1,1)-pizda(2,2)
7558             vv(2)=pizda(2,1)+pizda(1,2)
7559             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7560             if (swap) then
7561               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7562 #ifdef MOMENT
7563                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7564      &             -(s1+s2+s4)
7565 #else
7566                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7567      &             -(s2+s4)
7568 #endif
7569                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7570               else
7571 #ifdef MOMENT
7572                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7573 #else
7574                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7575 #endif
7576                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7577               endif
7578             else
7579 #ifdef MOMENT
7580               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7581 #else
7582               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7583 #endif
7584               if (l.eq.j+1) then
7585                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7586               else
7587                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7588               endif
7589             endif
7590           enddo
7591         enddo
7592       enddo
7593       return
7594       end
7595 c----------------------------------------------------------------------------
7596       double precision function eello_turn6(i,jj,kk)
7597       implicit real*8 (a-h,o-z)
7598       include 'DIMENSIONS'
7599       include 'sizesclu.dat'
7600       include 'COMMON.IOUNITS'
7601       include 'COMMON.CHAIN'
7602       include 'COMMON.DERIV'
7603       include 'COMMON.INTERACT'
7604       include 'COMMON.CONTACTS'
7605       include 'COMMON.TORSION'
7606       include 'COMMON.VAR'
7607       include 'COMMON.GEO'
7608       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7609      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7610      &  ggg1(3),ggg2(3)
7611       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7612      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7613 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7614 C           the respective energy moment and not to the cluster cumulant.
7615       eello_turn6=0.0d0
7616       j=i+4
7617       k=i+1
7618       l=i+3
7619       iti=itortyp(itype(i))
7620       itk=itortyp(itype(k))
7621       itk1=itortyp(itype(k+1))
7622       itl=itortyp(itype(l))
7623       itj=itortyp(itype(j))
7624 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7625 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7626 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7627 cd        eello6=0.0d0
7628 cd        return
7629 cd      endif
7630 cd      write (iout,*)
7631 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7632 cd     &   ' and',k,l
7633 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7634       do iii=1,2
7635         do kkk=1,5
7636           do lll=1,3
7637             derx_turn(lll,kkk,iii)=0.0d0
7638           enddo
7639         enddo
7640       enddo
7641 cd      eij=1.0d0
7642 cd      ekl=1.0d0
7643 cd      ekont=1.0d0
7644       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7645 cd      eello6_5=0.0d0
7646 cd      write (2,*) 'eello6_5',eello6_5
7647 #ifdef MOMENT
7648       call transpose2(AEA(1,1,1),auxmat(1,1))
7649       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7650       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7651       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7652 #else
7653       s1 = 0.0d0
7654 #endif
7655       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7656       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7657       s2 = scalar2(b1(1,itk),vtemp1(1))
7658 #ifdef MOMENT
7659       call transpose2(AEA(1,1,2),atemp(1,1))
7660       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7661       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7662       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7663 #else
7664       s8=0.0d0
7665 #endif
7666       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7667       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7668       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7669 #ifdef MOMENT
7670       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7671       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7672       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7673       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7674       ss13 = scalar2(b1(1,itk),vtemp4(1))
7675       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7676 #else
7677       s13=0.0d0
7678 #endif
7679 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7680 c      s1=0.0d0
7681 c      s2=0.0d0
7682 c      s8=0.0d0
7683 c      s12=0.0d0
7684 c      s13=0.0d0
7685       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7686       if (calc_grad) then
7687 C Derivatives in gamma(i+2)
7688 #ifdef MOMENT
7689       call transpose2(AEA(1,1,1),auxmatd(1,1))
7690       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7691       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7692       call transpose2(AEAderg(1,1,2),atempd(1,1))
7693       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7694       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7695 #else
7696       s8d=0.0d0
7697 #endif
7698       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7699       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7700       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7701 c      s1d=0.0d0
7702 c      s2d=0.0d0
7703 c      s8d=0.0d0
7704 c      s12d=0.0d0
7705 c      s13d=0.0d0
7706       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7707 C Derivatives in gamma(i+3)
7708 #ifdef MOMENT
7709       call transpose2(AEA(1,1,1),auxmatd(1,1))
7710       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7711       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7712       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7713 #else
7714       s1d=0.0d0
7715 #endif
7716       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7717       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7718       s2d = scalar2(b1(1,itk),vtemp1d(1))
7719 #ifdef MOMENT
7720       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7721       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7722 #endif
7723       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7724 #ifdef MOMENT
7725       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7726       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7727       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7728 #else
7729       s13d=0.0d0
7730 #endif
7731 c      s1d=0.0d0
7732 c      s2d=0.0d0
7733 c      s8d=0.0d0
7734 c      s12d=0.0d0
7735 c      s13d=0.0d0
7736 #ifdef MOMENT
7737       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7738      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7739 #else
7740       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7741      &               -0.5d0*ekont*(s2d+s12d)
7742 #endif
7743 C Derivatives in gamma(i+4)
7744       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7745       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7746       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7747 #ifdef MOMENT
7748       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7749       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7750       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7751 #else
7752       s13d = 0.0d0
7753 #endif
7754 c      s1d=0.0d0
7755 c      s2d=0.0d0
7756 c      s8d=0.0d0
7757 C      s12d=0.0d0
7758 c      s13d=0.0d0
7759 #ifdef MOMENT
7760       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7761 #else
7762       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7763 #endif
7764 C Derivatives in gamma(i+5)
7765 #ifdef MOMENT
7766       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7767       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7768       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7769 #else
7770       s1d = 0.0d0
7771 #endif
7772       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7773       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7774       s2d = scalar2(b1(1,itk),vtemp1d(1))
7775 #ifdef MOMENT
7776       call transpose2(AEA(1,1,2),atempd(1,1))
7777       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7778       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7779 #else
7780       s8d = 0.0d0
7781 #endif
7782       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7783       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7784 #ifdef MOMENT
7785       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7786       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7787       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7788 #else
7789       s13d = 0.0d0
7790 #endif
7791 c      s1d=0.0d0
7792 c      s2d=0.0d0
7793 c      s8d=0.0d0
7794 c      s12d=0.0d0
7795 c      s13d=0.0d0
7796 #ifdef MOMENT
7797       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7798      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7799 #else
7800       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7801      &               -0.5d0*ekont*(s2d+s12d)
7802 #endif
7803 C Cartesian derivatives
7804       do iii=1,2
7805         do kkk=1,5
7806           do lll=1,3
7807 #ifdef MOMENT
7808             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7809             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7810             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7811 #else
7812             s1d = 0.0d0
7813 #endif
7814             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7815             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7816      &          vtemp1d(1))
7817             s2d = scalar2(b1(1,itk),vtemp1d(1))
7818 #ifdef MOMENT
7819             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7820             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7821             s8d = -(atempd(1,1)+atempd(2,2))*
7822      &           scalar2(cc(1,1,itl),vtemp2(1))
7823 #else
7824             s8d = 0.0d0
7825 #endif
7826             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7827      &           auxmatd(1,1))
7828             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7829             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7830 c      s1d=0.0d0
7831 c      s2d=0.0d0
7832 c      s8d=0.0d0
7833 c      s12d=0.0d0
7834 c      s13d=0.0d0
7835 #ifdef MOMENT
7836             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7837      &        - 0.5d0*(s1d+s2d)
7838 #else
7839             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7840      &        - 0.5d0*s2d
7841 #endif
7842 #ifdef MOMENT
7843             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7844      &        - 0.5d0*(s8d+s12d)
7845 #else
7846             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7847      &        - 0.5d0*s12d
7848 #endif
7849           enddo
7850         enddo
7851       enddo
7852 #ifdef MOMENT
7853       do kkk=1,5
7854         do lll=1,3
7855           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7856      &      achuj_tempd(1,1))
7857           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7858           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7859           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7860           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7861           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7862      &      vtemp4d(1))
7863           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7864           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7865           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7866         enddo
7867       enddo
7868 #endif
7869 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7870 cd     &  16*eel_turn6_num
7871 cd      goto 1112
7872       if (j.lt.nres-1) then
7873         j1=j+1
7874         j2=j-1
7875       else
7876         j1=j-1
7877         j2=j-2
7878       endif
7879       if (l.lt.nres-1) then
7880         l1=l+1
7881         l2=l-1
7882       else
7883         l1=l-1
7884         l2=l-2
7885       endif
7886       do ll=1,3
7887         ggg1(ll)=eel_turn6*g_contij(ll,1)
7888         ggg2(ll)=eel_turn6*g_contij(ll,2)
7889         ghalf=0.5d0*ggg1(ll)
7890 cd        ghalf=0.0d0
7891         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7892      &    +ekont*derx_turn(ll,2,1)
7893         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7894         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7895      &    +ekont*derx_turn(ll,4,1)
7896         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7897         ghalf=0.5d0*ggg2(ll)
7898 cd        ghalf=0.0d0
7899         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7900      &    +ekont*derx_turn(ll,2,2)
7901         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7902         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7903      &    +ekont*derx_turn(ll,4,2)
7904         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7905       enddo
7906 cd      goto 1112
7907       do m=i+1,j-1
7908         do ll=1,3
7909           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7910         enddo
7911       enddo
7912       do m=k+1,l-1
7913         do ll=1,3
7914           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7915         enddo
7916       enddo
7917 1112  continue
7918       do m=i+2,j2
7919         do ll=1,3
7920           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7921         enddo
7922       enddo
7923       do m=k+2,l2
7924         do ll=1,3
7925           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7926         enddo
7927       enddo
7928 cd      do iii=1,nres-3
7929 cd        write (2,*) iii,g_corr6_loc(iii)
7930 cd      enddo
7931       endif
7932       eello_turn6=ekont*eel_turn6
7933 cd      write (2,*) 'ekont',ekont
7934 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7935       return
7936       end
7937 crc-------------------------------------------------
7938       SUBROUTINE MATVEC2(A1,V1,V2)
7939       implicit real*8 (a-h,o-z)
7940       include 'DIMENSIONS'
7941       DIMENSION A1(2,2),V1(2),V2(2)
7942 c      DO 1 I=1,2
7943 c        VI=0.0
7944 c        DO 3 K=1,2
7945 c    3     VI=VI+A1(I,K)*V1(K)
7946 c        Vaux(I)=VI
7947 c    1 CONTINUE
7948
7949       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7950       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7951
7952       v2(1)=vaux1
7953       v2(2)=vaux2
7954       END
7955 C---------------------------------------
7956       SUBROUTINE MATMAT2(A1,A2,A3)
7957       implicit real*8 (a-h,o-z)
7958       include 'DIMENSIONS'
7959       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7960 c      DIMENSION AI3(2,2)
7961 c        DO  J=1,2
7962 c          A3IJ=0.0
7963 c          DO K=1,2
7964 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7965 c          enddo
7966 c          A3(I,J)=A3IJ
7967 c       enddo
7968 c      enddo
7969
7970       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7971       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7972       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7973       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7974
7975       A3(1,1)=AI3_11
7976       A3(2,1)=AI3_21
7977       A3(1,2)=AI3_12
7978       A3(2,2)=AI3_22
7979       END
7980
7981 c-------------------------------------------------------------------------
7982       double precision function scalar2(u,v)
7983       implicit none
7984       double precision u(2),v(2)
7985       double precision sc
7986       integer i
7987       scalar2=u(1)*v(1)+u(2)*v(2)
7988       return
7989       end
7990
7991 C-----------------------------------------------------------------------------
7992
7993       subroutine transpose2(a,at)
7994       implicit none
7995       double precision a(2,2),at(2,2)
7996       at(1,1)=a(1,1)
7997       at(1,2)=a(2,1)
7998       at(2,1)=a(1,2)
7999       at(2,2)=a(2,2)
8000       return
8001       end
8002 c--------------------------------------------------------------------------
8003       subroutine transpose(n,a,at)
8004       implicit none
8005       integer n,i,j
8006       double precision a(n,n),at(n,n)
8007       do i=1,n
8008         do j=1,n
8009           at(j,i)=a(i,j)
8010         enddo
8011       enddo
8012       return
8013       end
8014 C---------------------------------------------------------------------------
8015       subroutine prodmat3(a1,a2,kk,transp,prod)
8016       implicit none
8017       integer i,j
8018       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8019       logical transp
8020 crc      double precision auxmat(2,2),prod_(2,2)
8021
8022       if (transp) then
8023 crc        call transpose2(kk(1,1),auxmat(1,1))
8024 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8025 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8026
8027            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8028      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8029            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8030      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8031            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8032      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8033            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8034      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8035
8036       else
8037 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8038 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8039
8040            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8041      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8042            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8043      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8044            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8045      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8046            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8047      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8048
8049       endif
8050 c      call transpose2(a2(1,1),a2t(1,1))
8051
8052 crc      print *,transp
8053 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8054 crc      print *,((prod(i,j),i=1,2),j=1,2)
8055
8056       return
8057       end
8058 C-----------------------------------------------------------------------------
8059       double precision function scalar(u,v)
8060       implicit none
8061       double precision u(3),v(3)
8062       double precision sc
8063       integer i
8064       sc=0.0d0
8065       do i=1,3
8066         sc=sc+u(i)*v(i)
8067       enddo
8068       scalar=sc
8069       return
8070       end
8071