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