source/cluster/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 c     external proc_proc
   7 #ifdef WINPGI
   8 cMS$ATTRIBUTES C ::  proc_proc
   9 #endif
  10
  11       include 'COMMON.IOUNITS'
  12       double precision energia(0:max_ene),energia1(0:max_ene+1)
  13 #ifdef MPL
  14       include 'COMMON.INFO'
  15       external d_vadd
  16       integer ready
  17 #endif
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.CONTROL'
  24
  25       double precision fact(5)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor,fact(1))
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105
 106 c      write(iout,*) "TEST_ENE",constr_homology
 107       if (constr_homology.ge.1) then
 108         call e_modeller(ehomology_constr)
 109       else
 110         ehomology_constr=0.0d0
 111       endif
 112 c      write(iout,*) "TEST_ENE",ehomology_constr
 113
 114 C     BARTEK for dfa test!
 115       if (wdfa_dist.gt.0) call edfad(edfadis)
 116 c      print*, 'edfad is finished!', edfadis
 117       if (wdfa_tor.gt.0) call edfat(edfator)
 118 c      print*, 'edfat is finished!', edfator
 119       if (wdfa_nei.gt.0) call edfan(edfanei)
 120 c      print*, 'edfan is finished!', edfanei
 121       if (wdfa_beta.gt.0) call edfab(edfabet)
 122 c      print*, 'edfab is finished!', edfabet
 123
 124
 125 C     call multibody(ecorr)
 126 C
 127 C Sum the energies
 128 C
 129 #ifdef SPLITELE
 130       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*ees+wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*(ees+evdw1)
 141      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 142      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 143      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 144      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 145      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 146      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 147      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 148      & +wdfa_beta*edfabet
 149 #endif
 150       energia(0)=etot
 151       energia(1)=evdw
 152 #ifdef SCP14
 153       energia(2)=evdw2-evdw2_14
 154       energia(17)=evdw2_14
 155 #else
 156       energia(2)=evdw2
 157       energia(17)=0.0d0
 158 #endif
 159 #ifdef SPLITELE
 160       energia(3)=ees
 161       energia(16)=evdw1
 162 #else
 163       energia(3)=ees+evdw1
 164       energia(16)=0.0d0
 165 #endif
 166       energia(4)=ecorr
 167       energia(5)=ecorr5
 168       energia(6)=ecorr6
 169       energia(7)=eel_loc
 170       energia(8)=eello_turn3
 171       energia(9)=eello_turn4
 172       energia(10)=eturn6
 173       energia(11)=ebe
 174       energia(12)=escloc
 175       energia(13)=etors
 176       energia(14)=etors_d
 177       energia(15)=ehpb
 178       energia(18)=estr
 179       energia(19)=esccor
 180       energia(20)=edihcnstr
 181       energia(21)=ehomology_constr
 182       energia(22)=edfadis
 183       energia(23)=edfator
 184       energia(24)=edfanei
 185       energia(25)=edfabet
 186 cc      if (dyn_ss) call dyn_set_nss
 187 c detecting NaNQ
 188       i=0
 189 #ifdef WINPGI
 190       idumm=proc_proc(etot,i)
 191 #else
 192 c     call proc_proc(etot,i)
 193 #endif
 194       if(i.eq.1)energia(0)=1.0d+99
 195 #ifdef MPL
 196 c     endif
 197 #endif
 198       if (calc_grad) then
 199 C
 200 C Sum up the components of the Cartesian gradient.
 201 C
 202 #ifdef SPLITELE
 203       do i=1,nct
 204         do j=1,3
 205           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 206      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 207      &                wbond*gradb(j,i)+
 208      &                wstrain*ghpbc(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)+
 217      &                wdfa_dist*gdfad(j,i)+
 218      &                wdfa_tor*gdfat(j,i)+
 219      &                wdfa_nei*gdfan(j,i)+
 220      &                wdfa_beta*gdfab(j,i)
 221           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 222      &                  wbond*gradbx(j,i)+
 223      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 224         enddo
 225 #else
 226       do i=1,nct
 227         do j=1,3
 228           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 229      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 230      &                wbond*gradb(j,i)+
 231      &                wcorr*fact(3)*gradcorr(j,i)+
 232      &                wel_loc*fact(2)*gel_loc(j,i)+
 233      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 234      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 235      &                wcorr5*fact(4)*gradcorr5(j,i)+
 236      &                wcorr6*fact(5)*gradcorr6(j,i)+
 237      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 238      &                wsccor*fact(2)*gsccorc(j,i)+
 239      &                wdfa_dist*gdfad(j,i)+
 240      &                wdfa_tor*gdfat(j,i)+
 241      &                wdfa_nei*gdfan(j,i)+
 242      &                wdfa_beta*gdfab(j,i)
 243           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 244      &                  wbond*gradbx(j,i)+
 245      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 246         enddo
 247 #endif
 248 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 249 cd   &        (gradc(k,i),k=1,3)
 250       enddo
 251
 252
 253       do i=1,nres-3
 254 cd        write (iout,*) i,g_corr5_loc(i)
 255         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 256      &   +wcorr5*fact(4)*g_corr5_loc(i)
 257      &   +wcorr6*fact(5)*g_corr6_loc(i)
 258      &   +wturn4*fact(3)*gel_loc_turn4(i)
 259      &   +wturn3*fact(2)*gel_loc_turn3(i)
 260      &   +wturn6*fact(5)*gel_loc_turn6(i)
 261      &   +wel_loc*fact(2)*gel_loc_loc(i)
 262      &   +wsccor*fact(1)*gsccor_loc(i)
 263       enddo
 264       endif
 265 c      call enerprint(energia(0),fact)
 266 cd    call intout
 267 cd    stop
 268       return
 269       end
 270 C------------------------------------------------------------------------
 271       subroutine enerprint(energia,fact)
 272       implicit real*8 (a-h,o-z)
 273       include 'DIMENSIONS'
 274       include 'sizesclu.dat'
 275       include 'COMMON.IOUNITS'
 276       include 'COMMON.FFIELD'
 277       include 'COMMON.SBRIDGE'
 278       double precision energia(0:max_ene),fact(5)
 279       etot=energia(0)
 280       evdw=energia(1)
 281 #ifdef SCP14
 282       evdw2=energia(2)+energia(17)
 283 #else
 284       evdw2=energia(2)
 285 #endif
 286       ees=energia(3)
 287 #ifdef SPLITELE
 288       evdw1=energia(16)
 289 #endif
 290       ecorr=energia(4)
 291       ecorr5=energia(5)
 292       ecorr6=energia(6)
 293       eel_loc=energia(7)
 294       eello_turn3=energia(8)
 295       eello_turn4=energia(9)
 296       eello_turn6=energia(10)
 297       ebe=energia(11)
 298       escloc=energia(12)
 299       etors=energia(13)
 300       etors_d=energia(14)
 301       ehpb=energia(15)
 302       esccor=energia(19)
 303       edihcnstr=energia(20)
 304       estr=energia(18)
 305       ehomology_constr=energia(21)
 306       edfadis=energia(22)
 307       edfator=energia(23)
 308       edfanei=energia(24)
 309       edfabet=energia(25)
 310 #ifdef SPLITELE
 311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 312      &  wvdwpp,
 313      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 314      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 315      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 316      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 317      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 318      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 320      &  wdfa_beta,etot
 321    10 format (/'Virtual-chain energies:'//
 322      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 323      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 324      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 325      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 332      & ' (SS bridges & dist. cnstr.)'/
 333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 341      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 342      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 344      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 345      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 346      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 347      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #else
 350       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 351      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 352      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 353      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 354      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 355      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 356      &  edihcnstr,ehomology_constr,ebr*nss,
 357      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 358      &  wdfa_beta,etot
 359    10 format (/'Virtual-chain energies:'//
 360      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 361      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 362      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 363      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 364      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 365      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 366      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 367      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 368      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 369      & ' (SS bridges & dist. cnstr.)'/
 370      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 371      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 372      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 373      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 374      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 375      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 376      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 377      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 378      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 379      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 380      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 381      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 382      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 383      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 384      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 385      & 'ETOT=  ',1pE16.6,' (total)')
 386 #endif
 387       return
 388       end
 389 C-----------------------------------------------------------------------
 390       subroutine elj(evdw)
 391 C
 392 C This subroutine calculates the interaction energy of nonbonded side chains
 393 C assuming the LJ potential of interaction.
 394 C
 395       implicit real*8 (a-h,o-z)
 396       include 'DIMENSIONS'
 397       include 'sizesclu.dat'
 398 c      include "DIMENSIONS.COMPAR"
 399       parameter (accur=1.0d-10)
 400       include 'COMMON.GEO'
 401       include 'COMMON.VAR'
 402       include 'COMMON.LOCAL'
 403       include 'COMMON.CHAIN'
 404       include 'COMMON.DERIV'
 405       include 'COMMON.INTERACT'
 406       include 'COMMON.TORSION'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.NAMES'
 409       include 'COMMON.IOUNITS'
 410       include 'COMMON.CONTACTS'
 411       dimension gg(3)
 412       integer icant
 413       external icant
 414 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 415       evdw=0.0D0
 416       do i=iatsc_s,iatsc_e
 417         itypi=itype(i)
 418         itypi1=itype(i+1)
 419         xi=c(1,nres+i)
 420         yi=c(2,nres+i)
 421         zi=c(3,nres+i)
 422 C Change 12/1/95
 423         num_conti=0
 424 C
 425 C Calculate SC interaction energy.
 426 C
 427         do iint=1,nint_gr(i)
 428 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 429 cd   &                  'iend=',iend(i,iint)
 430           do j=istart(i,iint),iend(i,iint)
 431             itypj=itype(j)
 432             xj=c(1,nres+j)-xi
 433             yj=c(2,nres+j)-yi
 434             zj=c(3,nres+j)-zi
 435 C Change 12/1/95 to calculate four-body interactions
 436             rij=xj*xj+yj*yj+zj*zj
 437             rrij=1.0D0/rij
 438 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 439             eps0ij=eps(itypi,itypj)
 440             fac=rrij**expon2
 441             e1=fac*fac*aa(itypi,itypj)
 442             e2=fac*bb(itypi,itypj)
 443             evdwij=e1+e2
 444             ij=icant(itypi,itypj)
 445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 447 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 449 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 450 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 451             evdw=evdw+evdwij
 452             if (calc_grad) then
 453 C
 454 C Calculate the components of the gradient in DC and X
 455 C
 456             fac=-rrij*(e1+evdwij)
 457             gg(1)=xj*fac
 458             gg(2)=yj*fac
 459             gg(3)=zj*fac
 460             do k=1,3
 461               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 462               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 463             enddo
 464             do k=i,j-1
 465               do l=1,3
 466                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 467               enddo
 468             enddo
 469             endif
 470 C
 471 C 12/1/95, revised on 5/20/97
 472 C
 473 C Calculate the contact function. The ith column of the array JCONT will
 474 C contain the numbers of atoms that make contacts with the atom I (of numbers
 475 C greater than I). The arrays FACONT and GACONT will contain the values of
 476 C the contact function and its derivative.
 477 C
 478 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 479 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 480 C Uncomment next line, if the correlation interactions are contact function only
 481             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 482               rij=dsqrt(rij)
 483               sigij=sigma(itypi,itypj)
 484               r0ij=rs0(itypi,itypj)
 485 C
 486 C Check whether the SC's are not too far to make a contact.
 487 C
 488               rcut=1.5d0*r0ij
 489               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 490 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 491 C
 492               if (fcont.gt.0.0D0) then
 493 C If the SC-SC distance if close to sigma, apply spline.
 494 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 495 cAdam &             fcont1,fprimcont1)
 496 cAdam           fcont1=1.0d0-fcont1
 497 cAdam           if (fcont1.gt.0.0d0) then
 498 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 499 cAdam             fcont=fcont*fcont1
 500 cAdam           endif
 501 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 502 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 503 cga             do k=1,3
 504 cga               gg(k)=gg(k)*eps0ij
 505 cga             enddo
 506 cga             eps0ij=-evdwij*eps0ij
 507 C Uncomment for AL's type of SC correlation interactions.
 508 cadam           eps0ij=-evdwij
 509                 num_conti=num_conti+1
 510                 jcont(num_conti,i)=j
 511                 facont(num_conti,i)=fcont*eps0ij
 512                 fprimcont=eps0ij*fprimcont/rij
 513                 fcont=expon*fcont
 514 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 515 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 516 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 517 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 518                 gacont(1,num_conti,i)=-fprimcont*xj
 519                 gacont(2,num_conti,i)=-fprimcont*yj
 520                 gacont(3,num_conti,i)=-fprimcont*zj
 521 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 522 cd              write (iout,'(2i3,3f10.5)')
 523 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 524               endif
 525             endif
 526           enddo      ! j
 527         enddo        ! iint
 528 C Change 12/1/95
 529         num_cont(i)=num_conti
 530       enddo          ! i
 531       if (calc_grad) then
 532       do i=1,nct
 533         do j=1,3
 534           gvdwc(j,i)=expon*gvdwc(j,i)
 535           gvdwx(j,i)=expon*gvdwx(j,i)
 536         enddo
 537       enddo
 538       endif
 539 C******************************************************************************
 540 C
 541 C                              N O T E !!!
 542 C
 543 C To save time, the factor of EXPON has been extracted from ALL components
 544 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 545 C use!
 546 C
 547 C******************************************************************************
 548       return
 549       end
 550 C-----------------------------------------------------------------------------
 551       subroutine eljk(evdw)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJK potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'sizesclu.dat'
 559 c      include "DIMENSIONS.COMPAR"
 560       include 'COMMON.GEO'
 561       include 'COMMON.VAR'
 562       include 'COMMON.LOCAL'
 563       include 'COMMON.CHAIN'
 564       include 'COMMON.DERIV'
 565       include 'COMMON.INTERACT'
 566       include 'COMMON.IOUNITS'
 567       include 'COMMON.NAMES'
 568       dimension gg(3)
 569       logical scheck
 570       integer icant
 571       external icant
 572 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 573       evdw=0.0D0
 574       do i=iatsc_s,iatsc_e
 575         itypi=itype(i)
 576         itypi1=itype(i+1)
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=itype(j)
 586             xj=c(1,nres+j)-xi
 587             yj=c(2,nres+j)-yi
 588             zj=c(3,nres+j)-zi
 589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 590             fac_augm=rrij**expon
 591             e_augm=augm(itypi,itypj)*fac_augm
 592             r_inv_ij=dsqrt(rrij)
 593             rij=1.0D0/r_inv_ij
 594             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 595             fac=r_shift_inv**expon
 596             e1=fac*fac*aa(itypi,itypj)
 597             e2=fac*bb(itypi,itypj)
 598             evdwij=e_augm+e1+e2
 599             ij=icant(itypi,itypj)
 600 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 601 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 602 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 603 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 604 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 605 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 606 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 607             evdw=evdw+evdwij
 608             if (calc_grad) then
 609 C
 610 C Calculate the components of the gradient in DC and X
 611 C
 612             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 613             gg(1)=xj*fac
 614             gg(2)=yj*fac
 615             gg(3)=zj*fac
 616             do k=1,3
 617               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 618               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 619             enddo
 620             do k=i,j-1
 621               do l=1,3
 622                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 623               enddo
 624             enddo
 625             endif
 626           enddo      ! j
 627         enddo        ! iint
 628       enddo          ! i
 629       if (calc_grad) then
 630       do i=1,nct
 631         do j=1,3
 632           gvdwc(j,i)=expon*gvdwc(j,i)
 633           gvdwx(j,i)=expon*gvdwx(j,i)
 634         enddo
 635       enddo
 636       endif
 637       return
 638       end
 639 C-----------------------------------------------------------------------------
 640       subroutine ebp(evdw)
 641 C
 642 C This subroutine calculates the interaction energy of nonbonded side chains
 643 C assuming the Berne-Pechukas potential of interaction.
 644 C
 645       implicit real*8 (a-h,o-z)
 646       include 'DIMENSIONS'
 647       include 'sizesclu.dat'
 648 c      include "DIMENSIONS.COMPAR"
 649       include 'COMMON.GEO'
 650       include 'COMMON.VAR'
 651       include 'COMMON.LOCAL'
 652       include 'COMMON.CHAIN'
 653       include 'COMMON.DERIV'
 654       include 'COMMON.NAMES'
 655       include 'COMMON.INTERACT'
 656       include 'COMMON.IOUNITS'
 657       include 'COMMON.CALC'
 658       common /srutu/ icall
 659 c     double precision rrsave(maxdim)
 660       logical lprn
 661       integer icant
 662       external icant
 663       evdw=0.0D0
 664 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 665       evdw=0.0D0
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=itype(i)
 674         itypi1=itype(i+1)
 675         xi=c(1,nres+i)
 676         yi=c(2,nres+i)
 677         zi=c(3,nres+i)
 678         dxi=dc_norm(1,nres+i)
 679         dyi=dc_norm(2,nres+i)
 680         dzi=dc_norm(3,nres+i)
 681         dsci_inv=vbld_inv(i+nres)
 682 C
 683 C Calculate SC interaction energy.
 684 C
 685         do iint=1,nint_gr(i)
 686           do j=istart(i,iint),iend(i,iint)
 687             ind=ind+1
 688             itypj=itype(j)
 689             dscj_inv=vbld_inv(j+nres)
 690             chi1=chi(itypi,itypj)
 691             chi2=chi(itypj,itypi)
 692             chi12=chi1*chi2
 693             chip1=chip(itypi)
 694             chip2=chip(itypj)
 695             chip12=chip1*chip2
 696             alf1=alp(itypi)
 697             alf2=alp(itypj)
 698             alf12=0.5D0*(alf1+alf2)
 699 C For diagnostics only!!!
 700 c           chi1=0.0D0
 701 c           chi2=0.0D0
 702 c           chi12=0.0D0
 703 c           chip1=0.0D0
 704 c           chip2=0.0D0
 705 c           chip12=0.0D0
 706 c           alf1=0.0D0
 707 c           alf2=0.0D0
 708 c           alf12=0.0D0
 709             xj=c(1,nres+j)-xi
 710             yj=c(2,nres+j)-yi
 711             zj=c(3,nres+j)-zi
 712             dxj=dc_norm(1,nres+j)
 713             dyj=dc_norm(2,nres+j)
 714             dzj=dc_norm(3,nres+j)
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716 cd          if (icall.eq.0) then
 717 cd            rrsave(ind)=rrij
 718 cd          else
 719 cd            rrij=rrsave(ind)
 720 cd          endif
 721             rij=dsqrt(rrij)
 722 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 723             call sc_angular
 724 C Calculate whole angle-dependent part of epsilon and contributions
 725 C to its derivatives
 726             fac=(rrij*sigsq)**expon2
 727             e1=fac*fac*aa(itypi,itypj)
 728             e2=fac*bb(itypi,itypj)
 729             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 730             eps2der=evdwij*eps3rt
 731             eps3der=evdwij*eps2rt
 732             evdwij=evdwij*eps2rt*eps3rt
 733             ij=icant(itypi,itypj)
 734             aux=eps1*eps2rt**2*eps3rt**2
 735             evdw=evdw+evdwij
 736             if (calc_grad) then
 737             if (lprn) then
 738             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 741 cd     &        restyp(itypi),i,restyp(itypj),j,
 742 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 743 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 744 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 745 cd     &        evdwij
 746             endif
 747 C Calculate gradient components.
 748             e1=e1*eps1*eps2rt**2*eps3rt**2
 749             fac=-expon*(e1+evdwij)
 750             sigder=fac/sigsq
 751             fac=rrij*fac
 752 C Calculate radial part of the gradient
 753             gg(1)=xj*fac
 754             gg(2)=yj*fac
 755             gg(3)=zj*fac
 756 C Calculate the angular part of the gradient and sum add the contributions
 757 C to the appropriate components of the Cartesian gradient.
 758             call sc_grad
 759             endif
 760           enddo      ! j
 761         enddo        ! iint
 762       enddo          ! i
 763 c     stop
 764       return
 765       end
 766 C-----------------------------------------------------------------------------
 767       subroutine egb(evdw)
 768 C
 769 C This subroutine calculates the interaction energy of nonbonded side chains
 770 C assuming the Gay-Berne potential of interaction.
 771 C
 772       implicit real*8 (a-h,o-z)
 773       include 'DIMENSIONS'
 774       include 'sizesclu.dat'
 775 c      include "DIMENSIONS.COMPAR"
 776       include 'COMMON.GEO'
 777       include 'COMMON.VAR'
 778       include 'COMMON.LOCAL'
 779       include 'COMMON.CHAIN'
 780       include 'COMMON.DERIV'
 781       include 'COMMON.NAMES'
 782       include 'COMMON.INTERACT'
 783       include 'COMMON.IOUNITS'
 784       include 'COMMON.CALC'
 785       include 'COMMON.SBRIDGE'
 786       logical lprn
 787       common /srutu/icall
 788       integer icant
 789       external icant
 790       evdw=0.0D0
 791 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 792       evdw=0.0D0
 793       lprn=.false.
 794 c      if (icall.gt.0) lprn=.true.
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=itype(i)
 798         itypi1=itype(i+1)
 799         xi=c(1,nres+i)
 800         yi=c(2,nres+i)
 801         zi=c(3,nres+i)
 802         dxi=dc_norm(1,nres+i)
 803         dyi=dc_norm(2,nres+i)
 804         dzi=dc_norm(3,nres+i)
 805         dsci_inv=vbld_inv(i+nres)
 806 C
 807 C Calculate SC interaction energy.
 808 C
 809         do iint=1,nint_gr(i)
 810           do j=istart(i,iint),iend(i,iint)
 811             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 812               call dyn_ssbond_ene(i,j,evdwij)
 813               evdw=evdw+evdwij
 814 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 815 c     &                        'evdw',i,j,evdwij,' ss'
 816             ELSE
 817             ind=ind+1
 818             itypj=itype(j)
 819             dscj_inv=vbld_inv(j+nres)
 820             sig0ij=sigma(itypi,itypj)
 821             chi1=chi(itypi,itypj)
 822             chi2=chi(itypj,itypi)
 823             chi12=chi1*chi2
 824             chip1=chip(itypi)
 825             chip2=chip(itypj)
 826             chip12=chip1*chip2
 827             alf1=alp(itypi)
 828             alf2=alp(itypj)
 829             alf12=0.5D0*(alf1+alf2)
 830 C For diagnostics only!!!
 831 c           chi1=0.0D0
 832 c           chi2=0.0D0
 833 c           chi12=0.0D0
 834 c           chip1=0.0D0
 835 c           chip2=0.0D0
 836 c           chip12=0.0D0
 837 c           alf1=0.0D0
 838 c           alf2=0.0D0
 839 c           alf12=0.0D0
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843             dxj=dc_norm(1,nres+j)
 844             dyj=dc_norm(2,nres+j)
 845             dzj=dc_norm(3,nres+j)
 846 c            write (iout,*) i,j,xj,yj,zj
 847             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 848             rij=dsqrt(rrij)
 849 C Calculate angle-dependent terms of energy and contributions to their
 850 C derivatives.
 851             call sc_angular
 852             sigsq=1.0D0/sigsq
 853             sig=sig0ij*dsqrt(sigsq)
 854             rij_shift=1.0D0/rij-sig+sig0ij
 855 C I hate to put IF's in the loops, but here don't have another choice!!!!
 856             if (rij_shift.le.0.0D0) then
 857               evdw=1.0D20
 858               return
 859             endif
 860             sigder=-sig*sigsq
 861 c---------------------------------------------------------------
 862             rij_shift=1.0D0/rij_shift
 863             fac=rij_shift**expon
 864             e1=fac*fac*aa(itypi,itypj)
 865             e2=fac*bb(itypi,itypj)
 866             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 867             eps2der=evdwij*eps3rt
 868             eps3der=evdwij*eps2rt
 869             evdwij=evdwij*eps2rt*eps3rt
 870             evdw=evdw+evdwij
 871             ij=icant(itypi,itypj)
 872             aux=eps1*eps2rt**2*eps3rt**2
 873 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 874 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 875 c     &         aux*e2/eps(itypi,itypj)
 876             if (lprn) then
 877             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 878             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 879             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 880      &        restyp(itypi),i,restyp(itypj),j,
 881      &        epsi,sigm,chi1,chi2,chip1,chip2,
 882      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 883      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 884      &        evdwij
 885             endif
 886             if (calc_grad) then
 887 C Calculate gradient components.
 888             e1=e1*eps1*eps2rt**2*eps3rt**2
 889             fac=-expon*(e1+evdwij)*rij_shift
 890             sigder=fac*sigder
 891             fac=rij*fac
 892 C Calculate the radial part of the gradient
 893             gg(1)=xj*fac
 894             gg(2)=yj*fac
 895             gg(3)=zj*fac
 896 C Calculate angular part of the gradient.
 897             call sc_grad
 898             endif
 899             ENDIF    ! SSBOND
 900           enddo      ! j
 901         enddo        ! iint
 902       enddo          ! i
 903       return
 904       end
 905 C-----------------------------------------------------------------------------
 906       subroutine egbv(evdw)
 907 C
 908 C This subroutine calculates the interaction energy of nonbonded side chains
 909 C assuming the Gay-Berne-Vorobjev potential of interaction.
 910 C
 911       implicit real*8 (a-h,o-z)
 912       include 'DIMENSIONS'
 913       include 'sizesclu.dat'
 914 c      include "DIMENSIONS.COMPAR"
 915       include 'COMMON.GEO'
 916       include 'COMMON.VAR'
 917       include 'COMMON.LOCAL'
 918       include 'COMMON.CHAIN'
 919       include 'COMMON.DERIV'
 920       include 'COMMON.NAMES'
 921       include 'COMMON.INTERACT'
 922       include 'COMMON.IOUNITS'
 923       include 'COMMON.CALC'
 924       include 'COMMON.SBRIDGE'
 925       common /srutu/ icall
 926       logical lprn
 927       integer icant
 928       external icant
 929       evdw=0.0D0
 930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 931       evdw=0.0D0
 932       lprn=.false.
 933 c      if (icall.gt.0) lprn=.true.
 934       ind=0
 935       do i=iatsc_s,iatsc_e
 936         itypi=itype(i)
 937         itypi1=itype(i+1)
 938         xi=c(1,nres+i)
 939         yi=c(2,nres+i)
 940         zi=c(3,nres+i)
 941         dxi=dc_norm(1,nres+i)
 942         dyi=dc_norm(2,nres+i)
 943         dzi=dc_norm(3,nres+i)
 944         dsci_inv=vbld_inv(i+nres)
 945 C
 946 C Calculate SC interaction energy.
 947 C
 948         do iint=1,nint_gr(i)
 949           do j=istart(i,iint),iend(i,iint)
 950 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 951             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 952               call dyn_ssbond_ene(i,j,evdwij)
 953               evdw=evdw+evdwij
 954 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 955 c     &                        'evdw',i,j,evdwij,' ss'
 956             ELSE
 957             ind=ind+1
 958             itypj=itype(j)
 959             dscj_inv=vbld_inv(j+nres)
 960             sig0ij=sigma(itypi,itypj)
 961             r0ij=r0(itypi,itypj)
 962             chi1=chi(itypi,itypj)
 963             chi2=chi(itypj,itypi)
 964             chi12=chi1*chi2
 965             chip1=chip(itypi)
 966             chip2=chip(itypj)
 967             chip12=chip1*chip2
 968             alf1=alp(itypi)
 969             alf2=alp(itypj)
 970             alf12=0.5D0*(alf1+alf2)
 971 C For diagnostics only!!!
 972 c           chi1=0.0D0
 973 c           chi2=0.0D0
 974 c           chi12=0.0D0
 975 c           chip1=0.0D0
 976 c           chip2=0.0D0
 977 c           chip12=0.0D0
 978 c           alf1=0.0D0
 979 c           alf2=0.0D0
 980 c           alf12=0.0D0
 981             xj=c(1,nres+j)-xi
 982             yj=c(2,nres+j)-yi
 983             zj=c(3,nres+j)-zi
 984             dxj=dc_norm(1,nres+j)
 985             dyj=dc_norm(2,nres+j)
 986             dzj=dc_norm(3,nres+j)
 987             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 988             rij=dsqrt(rrij)
 989 C Calculate angle-dependent terms of energy and contributions to their
 990 C derivatives.
 991             call sc_angular
 992             sigsq=1.0D0/sigsq
 993             sig=sig0ij*dsqrt(sigsq)
 994             rij_shift=1.0D0/rij-sig+r0ij
 995 C I hate to put IF's in the loops, but here don't have another choice!!!!
 996             if (rij_shift.le.0.0D0) then
 997               evdw=1.0D20
 998               return
 999             endif
1000             sigder=-sig*sigsq
1001 c---------------------------------------------------------------
1002             rij_shift=1.0D0/rij_shift
1003             fac=rij_shift**expon
1004             e1=fac*fac*aa(itypi,itypj)
1005             e2=fac*bb(itypi,itypj)
1006             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1007             eps2der=evdwij*eps3rt
1008             eps3der=evdwij*eps2rt
1009             fac_augm=rrij**expon
1010             e_augm=augm(itypi,itypj)*fac_augm
1011             evdwij=evdwij*eps2rt*eps3rt
1012             evdw=evdw+evdwij+e_augm
1013             ij=icant(itypi,itypj)
1014             aux=eps1*eps2rt**2*eps3rt**2
1015 c            if (lprn) then
1016 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1017 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1018 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1019 c     &        restyp(itypi),i,restyp(itypj),j,
1020 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1021 c     &        chi1,chi2,chip1,chip2,
1022 c     &        eps1,eps2rt**2,eps3rt**2,
1023 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1024 c     &        evdwij+e_augm
1025 c            endif
1026             if (calc_grad) then
1027 C Calculate gradient components.
1028             e1=e1*eps1*eps2rt**2*eps3rt**2
1029             fac=-expon*(e1+evdwij)*rij_shift
1030             sigder=fac*sigder
1031             fac=rij*fac-2*expon*rrij*e_augm
1032 C Calculate the radial part of the gradient
1033             gg(1)=xj*fac
1034             gg(2)=yj*fac
1035             gg(3)=zj*fac
1036 C Calculate angular part of the gradient.
1037             call sc_grad
1038             endif
1039             ENDIF    ! dyn_ss
1040           enddo      ! j
1041         enddo        ! iint
1042       enddo          ! i
1043       return
1044       end
1045 C-----------------------------------------------------------------------------
1046       subroutine sc_angular
1047 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1048 C om12. Called by ebp, egb, and egbv.
1049       implicit none
1050       include 'COMMON.CALC'
1051       erij(1)=xj*rij
1052       erij(2)=yj*rij
1053       erij(3)=zj*rij
1054       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1055       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1056       om12=dxi*dxj+dyi*dyj+dzi*dzj
1057       chiom12=chi12*om12
1058 C Calculate eps1(om12) and its derivative in om12
1059       faceps1=1.0D0-om12*chiom12
1060       faceps1_inv=1.0D0/faceps1
1061       eps1=dsqrt(faceps1_inv)
1062 C Following variable is eps1*deps1/dom12
1063       eps1_om12=faceps1_inv*chiom12
1064 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1065 C and om12.
1066       om1om2=om1*om2
1067       chiom1=chi1*om1
1068       chiom2=chi2*om2
1069       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1070       sigsq=1.0D0-facsig*faceps1_inv
1071       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1072       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1073       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1074 C Calculate eps2 and its derivatives in om1, om2, and om12.
1075       chipom1=chip1*om1
1076       chipom2=chip2*om2
1077       chipom12=chip12*om12
1078       facp=1.0D0-om12*chipom12
1079       facp_inv=1.0D0/facp
1080       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1081 C Following variable is the square root of eps2
1082       eps2rt=1.0D0-facp1*facp_inv
1083 C Following three variables are the derivatives of the square root of eps
1084 C in om1, om2, and om12.
1085       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1086       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1087       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1088 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1089       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1090 C Calculate whole angle-dependent part of epsilon and contributions
1091 C to its derivatives
1092       return
1093       end
1094 C----------------------------------------------------------------------------
1095       subroutine sc_grad
1096       implicit real*8 (a-h,o-z)
1097       include 'DIMENSIONS'
1098       include 'sizesclu.dat'
1099       include 'COMMON.CHAIN'
1100       include 'COMMON.DERIV'
1101       include 'COMMON.CALC'
1102       double precision dcosom1(3),dcosom2(3)
1103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1104       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1105       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1106      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1107       do k=1,3
1108         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1109         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1110       enddo
1111       do k=1,3
1112         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1113       enddo
1114       do k=1,3
1115         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1116      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1117      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1118         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1119      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1120      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1121       enddo
1122 C
1123 C Calculate the components of the gradient in DC and X
1124 C
1125       do k=i,j-1
1126         do l=1,3
1127           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1128         enddo
1129       enddo
1130       return
1131       end
1132 c------------------------------------------------------------------------------
1133       subroutine vec_and_deriv
1134       implicit real*8 (a-h,o-z)
1135       include 'DIMENSIONS'
1136       include 'sizesclu.dat'
1137       include 'COMMON.IOUNITS'
1138       include 'COMMON.GEO'
1139       include 'COMMON.VAR'
1140       include 'COMMON.LOCAL'
1141       include 'COMMON.CHAIN'
1142       include 'COMMON.VECTORS'
1143       include 'COMMON.DERIV'
1144       include 'COMMON.INTERACT'
1145       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1146 C Compute the local reference systems. For reference system (i), the
1147 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1148 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1149       do i=1,nres-1
1150 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1151           if (i.eq.nres-1) then
1152 C Case of the last full residue
1153 C Compute the Z-axis
1154             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1155             costh=dcos(pi-theta(nres))
1156             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1157             do k=1,3
1158               uz(k,i)=fac*uz(k,i)
1159             enddo
1160             if (calc_grad) then
1161 C Compute the derivatives of uz
1162             uzder(1,1,1)= 0.0d0
1163             uzder(2,1,1)=-dc_norm(3,i-1)
1164             uzder(3,1,1)= dc_norm(2,i-1)
1165             uzder(1,2,1)= dc_norm(3,i-1)
1166             uzder(2,2,1)= 0.0d0
1167             uzder(3,2,1)=-dc_norm(1,i-1)
1168             uzder(1,3,1)=-dc_norm(2,i-1)
1169             uzder(2,3,1)= dc_norm(1,i-1)
1170             uzder(3,3,1)= 0.0d0
1171             uzder(1,1,2)= 0.0d0
1172             uzder(2,1,2)= dc_norm(3,i)
1173             uzder(3,1,2)=-dc_norm(2,i)
1174             uzder(1,2,2)=-dc_norm(3,i)
1175             uzder(2,2,2)= 0.0d0
1176             uzder(3,2,2)= dc_norm(1,i)
1177             uzder(1,3,2)= dc_norm(2,i)
1178             uzder(2,3,2)=-dc_norm(1,i)
1179             uzder(3,3,2)= 0.0d0
1180             endif
1181 C Compute the Y-axis
1182             facy=fac
1183             do k=1,3
1184               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1185             enddo
1186             if (calc_grad) then
1187 C Compute the derivatives of uy
1188             do j=1,3
1189               do k=1,3
1190                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1191      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1192                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1193               enddo
1194               uyder(j,j,1)=uyder(j,j,1)-costh
1195               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1196             enddo
1197             do j=1,2
1198               do k=1,3
1199                 do l=1,3
1200                   uygrad(l,k,j,i)=uyder(l,k,j)
1201                   uzgrad(l,k,j,i)=uzder(l,k,j)
1202                 enddo
1203               enddo
1204             enddo
1205             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1206             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1207             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1208             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1209             endif
1210           else
1211 C Other residues
1212 C Compute the Z-axis
1213             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1214             costh=dcos(pi-theta(i+2))
1215             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1216             do k=1,3
1217               uz(k,i)=fac*uz(k,i)
1218             enddo
1219             if (calc_grad) then
1220 C Compute the derivatives of uz
1221             uzder(1,1,1)= 0.0d0
1222             uzder(2,1,1)=-dc_norm(3,i+1)
1223             uzder(3,1,1)= dc_norm(2,i+1)
1224             uzder(1,2,1)= dc_norm(3,i+1)
1225             uzder(2,2,1)= 0.0d0
1226             uzder(3,2,1)=-dc_norm(1,i+1)
1227             uzder(1,3,1)=-dc_norm(2,i+1)
1228             uzder(2,3,1)= dc_norm(1,i+1)
1229             uzder(3,3,1)= 0.0d0
1230             uzder(1,1,2)= 0.0d0
1231             uzder(2,1,2)= dc_norm(3,i)
1232             uzder(3,1,2)=-dc_norm(2,i)
1233             uzder(1,2,2)=-dc_norm(3,i)
1234             uzder(2,2,2)= 0.0d0
1235             uzder(3,2,2)= dc_norm(1,i)
1236             uzder(1,3,2)= dc_norm(2,i)
1237             uzder(2,3,2)=-dc_norm(1,i)
1238             uzder(3,3,2)= 0.0d0
1239             endif
1240 C Compute the Y-axis
1241             facy=fac
1242             do k=1,3
1243               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1244             enddo
1245             if (calc_grad) then
1246 C Compute the derivatives of uy
1247             do j=1,3
1248               do k=1,3
1249                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1250      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1251                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1252               enddo
1253               uyder(j,j,1)=uyder(j,j,1)-costh
1254               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1255             enddo
1256             do j=1,2
1257               do k=1,3
1258                 do l=1,3
1259                   uygrad(l,k,j,i)=uyder(l,k,j)
1260                   uzgrad(l,k,j,i)=uzder(l,k,j)
1261                 enddo
1262               enddo
1263             enddo
1264             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1265             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1266             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1267             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1268           endif
1269           endif
1270       enddo
1271       if (calc_grad) then
1272       do i=1,nres-1
1273         vbld_inv_temp(1)=vbld_inv(i+1)
1274         if (i.lt.nres-1) then
1275           vbld_inv_temp(2)=vbld_inv(i+2)
1276         else
1277           vbld_inv_temp(2)=vbld_inv(i)
1278         endif
1279         do j=1,2
1280           do k=1,3
1281             do l=1,3
1282               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1283               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1284             enddo
1285           enddo
1286         enddo
1287       enddo
1288       endif
1289       return
1290       end
1291 C-----------------------------------------------------------------------------
1292       subroutine vec_and_deriv_test
1293       implicit real*8 (a-h,o-z)
1294       include 'DIMENSIONS'
1295       include 'sizesclu.dat'
1296       include 'COMMON.IOUNITS'
1297       include 'COMMON.GEO'
1298       include 'COMMON.VAR'
1299       include 'COMMON.LOCAL'
1300       include 'COMMON.CHAIN'
1301       include 'COMMON.VECTORS'
1302       dimension uyder(3,3,2),uzder(3,3,2)
1303 C Compute the local reference systems. For reference system (i), the
1304 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1305 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1306       do i=1,nres-1
1307           if (i.eq.nres-1) then
1308 C Case of the last full residue
1309 C Compute the Z-axis
1310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1311             costh=dcos(pi-theta(nres))
1312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1313 c            write (iout,*) 'fac',fac,
1314 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1315             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1316             do k=1,3
1317               uz(k,i)=fac*uz(k,i)
1318             enddo
1319 C Compute the derivatives of uz
1320             uzder(1,1,1)= 0.0d0
1321             uzder(2,1,1)=-dc_norm(3,i-1)
1322             uzder(3,1,1)= dc_norm(2,i-1)
1323             uzder(1,2,1)= dc_norm(3,i-1)
1324             uzder(2,2,1)= 0.0d0
1325             uzder(3,2,1)=-dc_norm(1,i-1)
1326             uzder(1,3,1)=-dc_norm(2,i-1)
1327             uzder(2,3,1)= dc_norm(1,i-1)
1328             uzder(3,3,1)= 0.0d0
1329             uzder(1,1,2)= 0.0d0
1330             uzder(2,1,2)= dc_norm(3,i)
1331             uzder(3,1,2)=-dc_norm(2,i)
1332             uzder(1,2,2)=-dc_norm(3,i)
1333             uzder(2,2,2)= 0.0d0
1334             uzder(3,2,2)= dc_norm(1,i)
1335             uzder(1,3,2)= dc_norm(2,i)
1336             uzder(2,3,2)=-dc_norm(1,i)
1337             uzder(3,3,2)= 0.0d0
1338 C Compute the Y-axis
1339             do k=1,3
1340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1341             enddo
1342             facy=fac
1343             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1344      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1345      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1346             do k=1,3
1347 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1348               uy(k,i)=
1349 c     &        facy*(
1350      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1351      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1352 c     &        )
1353             enddo
1354 c            write (iout,*) 'facy',facy,
1355 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1356             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1357             do k=1,3
1358               uy(k,i)=facy*uy(k,i)
1359             enddo
1360 C Compute the derivatives of uy
1361             do j=1,3
1362               do k=1,3
1363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1366               enddo
1367 c              uyder(j,j,1)=uyder(j,j,1)-costh
1368 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1369               uyder(j,j,1)=uyder(j,j,1)
1370      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1371               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1372      &          +uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386           else
1387 C Other residues
1388 C Compute the Z-axis
1389             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1390             costh=dcos(pi-theta(i+2))
1391             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i+1)
1399             uzder(3,1,1)= dc_norm(2,i+1)
1400             uzder(1,2,1)= dc_norm(3,i+1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i+1)
1403             uzder(1,3,1)=-dc_norm(2,i+1)
1404             uzder(2,3,1)= dc_norm(1,i+1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             facy=fac
1417             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1418      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1419      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1420             do k=1,3
1421 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1422               uy(k,i)=
1423 c     &        facy*(
1424      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1425      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1426 c     &        )
1427             enddo
1428 c            write (iout,*) 'facy',facy,
1429 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1430             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1431             do k=1,3
1432               uy(k,i)=facy*uy(k,i)
1433             enddo
1434 C Compute the derivatives of uy
1435             do j=1,3
1436               do k=1,3
1437                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1438      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1439                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1440               enddo
1441 c              uyder(j,j,1)=uyder(j,j,1)-costh
1442 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1443               uyder(j,j,1)=uyder(j,j,1)
1444      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1445               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1446      &          +uyder(j,j,2)
1447             enddo
1448             do j=1,2
1449               do k=1,3
1450                 do l=1,3
1451                   uygrad(l,k,j,i)=uyder(l,k,j)
1452                   uzgrad(l,k,j,i)=uzder(l,k,j)
1453                 enddo
1454               enddo
1455             enddo
1456             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1457             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1458             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1459             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1460           endif
1461       enddo
1462       do i=1,nres-1
1463         do j=1,2
1464           do k=1,3
1465             do l=1,3
1466               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1467               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1468             enddo
1469           enddo
1470         enddo
1471       enddo
1472       return
1473       end
1474 C-----------------------------------------------------------------------------
1475       subroutine check_vecgrad
1476       implicit real*8 (a-h,o-z)
1477       include 'DIMENSIONS'
1478       include 'sizesclu.dat'
1479       include 'COMMON.IOUNITS'
1480       include 'COMMON.GEO'
1481       include 'COMMON.VAR'
1482       include 'COMMON.LOCAL'
1483       include 'COMMON.CHAIN'
1484       include 'COMMON.VECTORS'
1485       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1486       dimension uyt(3,maxres),uzt(3,maxres)
1487       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1488       double precision delta /1.0d-7/
1489       call vec_and_deriv
1490 cd      do i=1,nres
1491 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1492 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1493 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1494 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1495 cd     &     (dc_norm(if90,i),if90=1,3)
1496 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1497 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1498 cd          write(iout,'(a)')
1499 cd      enddo
1500       do i=1,nres
1501         do j=1,2
1502           do k=1,3
1503             do l=1,3
1504               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1505               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1506             enddo
1507           enddo
1508         enddo
1509       enddo
1510       call vec_and_deriv
1511       do i=1,nres
1512         do j=1,3
1513           uyt(j,i)=uy(j,i)
1514           uzt(j,i)=uz(j,i)
1515         enddo
1516       enddo
1517       do i=1,nres
1518 cd        write (iout,*) 'i=',i
1519         do k=1,3
1520           erij(k)=dc_norm(k,i)
1521         enddo
1522         do j=1,3
1523           do k=1,3
1524             dc_norm(k,i)=erij(k)
1525           enddo
1526           dc_norm(j,i)=dc_norm(j,i)+delta
1527 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1528 c          do k=1,3
1529 c            dc_norm(k,i)=dc_norm(k,i)/fac
1530 c          enddo
1531 c          write (iout,*) (dc_norm(k,i),k=1,3)
1532 c          write (iout,*) (erij(k),k=1,3)
1533           call vec_and_deriv
1534           do k=1,3
1535             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1536             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1537             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1538             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1539           enddo
1540 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1541 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1542 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1543         enddo
1544         do k=1,3
1545           dc_norm(k,i)=erij(k)
1546         enddo
1547 cd        do k=1,3
1548 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1549 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1550 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1551 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1552 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1553 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1554 cd          write (iout,'(a)')
1555 cd        enddo
1556       enddo
1557       return
1558       end
1559 C--------------------------------------------------------------------------
1560       subroutine set_matrices
1561       implicit real*8 (a-h,o-z)
1562       include 'DIMENSIONS'
1563       include 'sizesclu.dat'
1564       include 'COMMON.IOUNITS'
1565       include 'COMMON.GEO'
1566       include 'COMMON.VAR'
1567       include 'COMMON.LOCAL'
1568       include 'COMMON.CHAIN'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.CONTACTS'
1572       include 'COMMON.TORSION'
1573       include 'COMMON.VECTORS'
1574       include 'COMMON.FFIELD'
1575       double precision auxvec(2),auxmat(2,2)
1576 C
1577 C Compute the virtual-bond-torsional-angle dependent quantities needed
1578 C to calculate the el-loc multibody terms of various order.
1579 C
1580       do i=3,nres+1
1581         if (i .lt. nres+1) then
1582           sin1=dsin(phi(i))
1583           cos1=dcos(phi(i))
1584           sintab(i-2)=sin1
1585           costab(i-2)=cos1
1586           obrot(1,i-2)=cos1
1587           obrot(2,i-2)=sin1
1588           sin2=dsin(2*phi(i))
1589           cos2=dcos(2*phi(i))
1590           sintab2(i-2)=sin2
1591           costab2(i-2)=cos2
1592           obrot2(1,i-2)=cos2
1593           obrot2(2,i-2)=sin2
1594           Ug(1,1,i-2)=-cos1
1595           Ug(1,2,i-2)=-sin1
1596           Ug(2,1,i-2)=-sin1
1597           Ug(2,2,i-2)= cos1
1598           Ug2(1,1,i-2)=-cos2
1599           Ug2(1,2,i-2)=-sin2
1600           Ug2(2,1,i-2)=-sin2
1601           Ug2(2,2,i-2)= cos2
1602         else
1603           costab(i-2)=1.0d0
1604           sintab(i-2)=0.0d0
1605           obrot(1,i-2)=1.0d0
1606           obrot(2,i-2)=0.0d0
1607           obrot2(1,i-2)=0.0d0
1608           obrot2(2,i-2)=0.0d0
1609           Ug(1,1,i-2)=1.0d0
1610           Ug(1,2,i-2)=0.0d0
1611           Ug(2,1,i-2)=0.0d0
1612           Ug(2,2,i-2)=1.0d0
1613           Ug2(1,1,i-2)=0.0d0
1614           Ug2(1,2,i-2)=0.0d0
1615           Ug2(2,1,i-2)=0.0d0
1616           Ug2(2,2,i-2)=0.0d0
1617         endif
1618         if (i .gt. 3 .and. i .lt. nres+1) then
1619           obrot_der(1,i-2)=-sin1
1620           obrot_der(2,i-2)= cos1
1621           Ugder(1,1,i-2)= sin1
1622           Ugder(1,2,i-2)=-cos1
1623           Ugder(2,1,i-2)=-cos1
1624           Ugder(2,2,i-2)=-sin1
1625           dwacos2=cos2+cos2
1626           dwasin2=sin2+sin2
1627           obrot2_der(1,i-2)=-dwasin2
1628           obrot2_der(2,i-2)= dwacos2
1629           Ug2der(1,1,i-2)= dwasin2
1630           Ug2der(1,2,i-2)=-dwacos2
1631           Ug2der(2,1,i-2)=-dwacos2
1632           Ug2der(2,2,i-2)=-dwasin2
1633         else
1634           obrot_der(1,i-2)=0.0d0
1635           obrot_der(2,i-2)=0.0d0
1636           Ugder(1,1,i-2)=0.0d0
1637           Ugder(1,2,i-2)=0.0d0
1638           Ugder(2,1,i-2)=0.0d0
1639           Ugder(2,2,i-2)=0.0d0
1640           obrot2_der(1,i-2)=0.0d0
1641           obrot2_der(2,i-2)=0.0d0
1642           Ug2der(1,1,i-2)=0.0d0
1643           Ug2der(1,2,i-2)=0.0d0
1644           Ug2der(2,1,i-2)=0.0d0
1645           Ug2der(2,2,i-2)=0.0d0
1646         endif
1647         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1648           iti = itortyp(itype(i-2))
1649         else
1650           iti=ntortyp+1
1651         endif
1652         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1653           iti1 = itortyp(itype(i-1))
1654         else
1655           iti1=ntortyp+1
1656         endif
1657 cd        write (iout,*) '*******i',i,' iti1',iti
1658 cd        write (iout,*) 'b1',b1(:,iti)
1659 cd        write (iout,*) 'b2',b2(:,iti)
1660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1661         if (i .gt. iatel_s+2) then
1662           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1663           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1664           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1665           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1666           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1667           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1668           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1669         else
1670           do k=1,2
1671             Ub2(k,i-2)=0.0d0
1672             Ctobr(k,i-2)=0.0d0
1673             Dtobr2(k,i-2)=0.0d0
1674             do l=1,2
1675               EUg(l,k,i-2)=0.0d0
1676               CUg(l,k,i-2)=0.0d0
1677               DUg(l,k,i-2)=0.0d0
1678               DtUg2(l,k,i-2)=0.0d0
1679             enddo
1680           enddo
1681         endif
1682         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1683         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1684         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1685         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1686         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1687         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1688         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1689         do k=1,2
1690           muder(k,i-2)=Ub2der(k,i-2)
1691         enddo
1692         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1693           iti1 = itortyp(itype(i-1))
1694         else
1695           iti1=ntortyp+1
1696         endif
1697         do k=1,2
1698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1699         enddo
1700 C Vectors and matrices dependent on a single virtual-bond dihedral.
1701         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1702         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1703         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1704         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1705         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1706         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1707         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1708         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1709         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1710 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1711 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1712       enddo
1713 C Matrices dependent on two consecutive virtual-bond dihedrals.
1714 C The order of matrices is from left to right.
1715       do i=2,nres-1
1716         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1717         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1718         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1719         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1720         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1721         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1722         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1723         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1724       enddo
1725 cd      do i=1,nres
1726 cd        iti = itortyp(itype(i))
1727 cd        write (iout,*) i
1728 cd        do j=1,2
1729 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1730 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1731 cd        enddo
1732 cd      enddo
1733       return
1734       end
1735 C--------------------------------------------------------------------------
1736       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1737 C
1738 C This subroutine calculates the average interaction energy and its gradient
1739 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1740 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1741 C The potential depends both on the distance of peptide-group centers and on
1742 C the orientation of the CA-CA virtual bonds.
1743 C
1744       implicit real*8 (a-h,o-z)
1745       include 'DIMENSIONS'
1746       include 'sizesclu.dat'
1747       include 'COMMON.CONTROL'
1748       include 'COMMON.IOUNITS'
1749       include 'COMMON.GEO'
1750       include 'COMMON.VAR'
1751       include 'COMMON.LOCAL'
1752       include 'COMMON.CHAIN'
1753       include 'COMMON.DERIV'
1754       include 'COMMON.INTERACT'
1755       include 'COMMON.CONTACTS'
1756       include 'COMMON.TORSION'
1757       include 'COMMON.VECTORS'
1758       include 'COMMON.FFIELD'
1759       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1760      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1761       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1762      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1763       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1765       double precision scal_el /0.5d0/
1766 C 12/13/98
1767 C 13-go grudnia roku pamietnego...
1768       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1769      &                   0.0d0,1.0d0,0.0d0,
1770      &                   0.0d0,0.0d0,1.0d0/
1771 cd      write(iout,*) 'In EELEC'
1772 cd      do i=1,nloctyp
1773 cd        write(iout,*) 'Type',i
1774 cd        write(iout,*) 'B1',B1(:,i)
1775 cd        write(iout,*) 'B2',B2(:,i)
1776 cd        write(iout,*) 'CC',CC(:,:,i)
1777 cd        write(iout,*) 'DD',DD(:,:,i)
1778 cd        write(iout,*) 'EE',EE(:,:,i)
1779 cd      enddo
1780 cd      call check_vecgrad
1781 cd      stop
1782       if (icheckgrad.eq.1) then
1783         do i=1,nres-1
1784           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1785           do k=1,3
1786             dc_norm(k,i)=dc(k,i)*fac
1787           enddo
1788 c          write (iout,*) 'i',i,' fac',fac
1789         enddo
1790       endif
1791       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1792      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1793      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1794 cd      if (wel_loc.gt.0.0d0) then
1795         if (icheckgrad.eq.1) then
1796         call vec_and_deriv_test
1797         else
1798         call vec_and_deriv
1799         endif
1800         call set_matrices
1801       endif
1802 cd      do i=1,nres-1
1803 cd        write (iout,*) 'i=',i
1804 cd        do k=1,3
1805 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1806 cd        enddo
1807 cd        do k=1,3
1808 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1809 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1810 cd        enddo
1811 cd      enddo
1812       num_conti_hb=0
1813       ees=0.0D0
1814       evdw1=0.0D0
1815       eel_loc=0.0d0
1816       eello_turn3=0.0d0
1817       eello_turn4=0.0d0
1818       ind=0
1819       do i=1,nres
1820         num_cont_hb(i)=0
1821       enddo
1822 cd      print '(a)','Enter EELEC'
1823 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1824       do i=1,nres
1825         gel_loc_loc(i)=0.0d0
1826         gcorr_loc(i)=0.0d0
1827       enddo
1828       do i=iatel_s,iatel_e
1829         if (itel(i).eq.0) goto 1215
1830         dxi=dc(1,i)
1831         dyi=dc(2,i)
1832         dzi=dc(3,i)
1833         dx_normi=dc_norm(1,i)
1834         dy_normi=dc_norm(2,i)
1835         dz_normi=dc_norm(3,i)
1836         xmedi=c(1,i)+0.5d0*dxi
1837         ymedi=c(2,i)+0.5d0*dyi
1838         zmedi=c(3,i)+0.5d0*dzi
1839         num_conti=0
1840 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1841         do j=ielstart(i),ielend(i)
1842           if (itel(j).eq.0) goto 1216
1843           ind=ind+1
1844           iteli=itel(i)
1845           itelj=itel(j)
1846           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1847           aaa=app(iteli,itelj)
1848           bbb=bpp(iteli,itelj)
1849 C Diagnostics only!!!
1850 c         aaa=0.0D0
1851 c         bbb=0.0D0
1852 c         ael6i=0.0D0
1853 c         ael3i=0.0D0
1854 C End diagnostics
1855           ael6i=ael6(iteli,itelj)
1856           ael3i=ael3(iteli,itelj)
1857           dxj=dc(1,j)
1858           dyj=dc(2,j)
1859           dzj=dc(3,j)
1860           dx_normj=dc_norm(1,j)
1861           dy_normj=dc_norm(2,j)
1862           dz_normj=dc_norm(3,j)
1863           xj=c(1,j)+0.5D0*dxj-xmedi
1864           yj=c(2,j)+0.5D0*dyj-ymedi
1865           zj=c(3,j)+0.5D0*dzj-zmedi
1866           rij=xj*xj+yj*yj+zj*zj
1867           rrmij=1.0D0/rij
1868           rij=dsqrt(rij)
1869           rmij=1.0D0/rij
1870           r3ij=rrmij*rmij
1871           r6ij=r3ij*r3ij
1872           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1873           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1874           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1875           fac=cosa-3.0D0*cosb*cosg
1876           ev1=aaa*r6ij*r6ij
1877 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1878           if (j.eq.i+2) ev1=scal_el*ev1
1879           ev2=bbb*r6ij
1880           fac3=ael6i*r6ij
1881           fac4=ael3i*r3ij
1882           evdwij=ev1+ev2
1883           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1884           el2=fac4*fac
1885           eesij=el1+el2
1886 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1887 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1888           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1889           ees=ees+eesij
1890           evdw1=evdw1+evdwij
1891 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1892 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1893 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1894 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1895 C
1896 C Calculate contributions to the Cartesian gradient.
1897 C
1898 #ifdef SPLITELE
1899           facvdw=-6*rrmij*(ev1+evdwij)
1900           facel=-3*rrmij*(el1+eesij)
1901           fac1=fac
1902           erij(1)=xj*rmij
1903           erij(2)=yj*rmij
1904           erij(3)=zj*rmij
1905           if (calc_grad) then
1906 *
1907 * Radial derivatives. First process both termini of the fragment (i,j)
1908 *
1909           ggg(1)=facel*xj
1910           ggg(2)=facel*yj
1911           ggg(3)=facel*zj
1912           do k=1,3
1913             ghalf=0.5D0*ggg(k)
1914             gelc(k,i)=gelc(k,i)+ghalf
1915             gelc(k,j)=gelc(k,j)+ghalf
1916           enddo
1917 *
1918 * Loop over residues i+1 thru j-1.
1919 *
1920           do k=i+1,j-1
1921             do l=1,3
1922               gelc(l,k)=gelc(l,k)+ggg(l)
1923             enddo
1924           enddo
1925           ggg(1)=facvdw*xj
1926           ggg(2)=facvdw*yj
1927           ggg(3)=facvdw*zj
1928           do k=1,3
1929             ghalf=0.5D0*ggg(k)
1930             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1931             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1932           enddo
1933 *
1934 * Loop over residues i+1 thru j-1.
1935 *
1936           do k=i+1,j-1
1937             do l=1,3
1938               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1939             enddo
1940           enddo
1941 #else
1942           facvdw=ev1+evdwij
1943           facel=el1+eesij
1944           fac1=fac
1945           fac=-3*rrmij*(facvdw+facvdw+facel)
1946           erij(1)=xj*rmij
1947           erij(2)=yj*rmij
1948           erij(3)=zj*rmij
1949           if (calc_grad) then
1950 *
1951 * Radial derivatives. First process both termini of the fragment (i,j)
1952 *
1953           ggg(1)=fac*xj
1954           ggg(2)=fac*yj
1955           ggg(3)=fac*zj
1956           do k=1,3
1957             ghalf=0.5D0*ggg(k)
1958             gelc(k,i)=gelc(k,i)+ghalf
1959             gelc(k,j)=gelc(k,j)+ghalf
1960           enddo
1961 *
1962 * Loop over residues i+1 thru j-1.
1963 *
1964           do k=i+1,j-1
1965             do l=1,3
1966               gelc(l,k)=gelc(l,k)+ggg(l)
1967             enddo
1968           enddo
1969 #endif
1970 *
1971 * Angular part
1972 *
1973           ecosa=2.0D0*fac3*fac1+fac4
1974           fac4=-3.0D0*fac4
1975           fac3=-6.0D0*fac3
1976           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1977           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1978           do k=1,3
1979             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1980             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1981           enddo
1982 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1983 cd   &          (dcosg(k),k=1,3)
1984           do k=1,3
1985             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1986           enddo
1987           do k=1,3
1988             ghalf=0.5D0*ggg(k)
1989             gelc(k,i)=gelc(k,i)+ghalf
1990      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1991      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1992             gelc(k,j)=gelc(k,j)+ghalf
1993      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1994      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1995           enddo
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           endif
2002
2003           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2004      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2005      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2006 C
2007 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2008 C   energy of a peptide unit is assumed in the form of a second-order
2009 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2010 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2011 C   are computed for EVERY pair of non-contiguous peptide groups.
2012 C
2013           if (j.lt.nres-1) then
2014             j1=j+1
2015             j2=j-1
2016           else
2017             j1=j-1
2018             j2=j-2
2019           endif
2020           kkk=0
2021           do k=1,2
2022             do l=1,2
2023               kkk=kkk+1
2024               muij(kkk)=mu(k,i)*mu(l,j)
2025             enddo
2026           enddo
2027 cd         write (iout,*) 'EELEC: i',i,' j',j
2028 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2029 cd          write(iout,*) 'muij',muij
2030           ury=scalar(uy(1,i),erij)
2031           urz=scalar(uz(1,i),erij)
2032           vry=scalar(uy(1,j),erij)
2033           vrz=scalar(uz(1,j),erij)
2034           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2035           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2036           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2037           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2038 C For diagnostics only
2039 cd          a22=1.0d0
2040 cd          a23=1.0d0
2041 cd          a32=1.0d0
2042 cd          a33=1.0d0
2043           fac=dsqrt(-ael6i)*r3ij
2044 cd          write (2,*) 'fac=',fac
2045 C For diagnostics only
2046 cd          fac=1.0d0
2047           a22=a22*fac
2048           a23=a23*fac
2049           a32=a32*fac
2050           a33=a33*fac
2051 cd          write (iout,'(4i5,4f10.5)')
2052 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2053 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2054 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2055 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2056 cd          write (iout,'(4f10.5)')
2057 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2058 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2059 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2060 cd           write (iout,'(2i3,9f10.5/)') i,j,
2061 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2062           if (calc_grad) then
2063 C Derivatives of the elements of A in virtual-bond vectors
2064           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2065 cd          do k=1,3
2066 cd            do l=1,3
2067 cd              erder(k,l)=0.0d0
2068 cd            enddo
2069 cd          enddo
2070           do k=1,3
2071             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2072             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2073             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2074             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2075             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2076             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2077             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2078             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2079             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2080             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2081             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2082             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2083           enddo
2084 cd          do k=1,3
2085 cd            do l=1,3
2086 cd              uryg(k,l)=0.0d0
2087 cd              urzg(k,l)=0.0d0
2088 cd              vryg(k,l)=0.0d0
2089 cd              vrzg(k,l)=0.0d0
2090 cd            enddo
2091 cd          enddo
2092 C Compute radial contributions to the gradient
2093           facr=-3.0d0*rrmij
2094           a22der=a22*facr
2095           a23der=a23*facr
2096           a32der=a32*facr
2097           a33der=a33*facr
2098 cd          a22der=0.0d0
2099 cd          a23der=0.0d0
2100 cd          a32der=0.0d0
2101 cd          a33der=0.0d0
2102           agg(1,1)=a22der*xj
2103           agg(2,1)=a22der*yj
2104           agg(3,1)=a22der*zj
2105           agg(1,2)=a23der*xj
2106           agg(2,2)=a23der*yj
2107           agg(3,2)=a23der*zj
2108           agg(1,3)=a32der*xj
2109           agg(2,3)=a32der*yj
2110           agg(3,3)=a32der*zj
2111           agg(1,4)=a33der*xj
2112           agg(2,4)=a33der*yj
2113           agg(3,4)=a33der*zj
2114 C Add the contributions coming from er
2115           fac3=-3.0d0*fac
2116           do k=1,3
2117             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2118             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2119             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2120             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2121           enddo
2122           do k=1,3
2123 C Derivatives in DC(i)
2124             ghalf1=0.5d0*agg(k,1)
2125             ghalf2=0.5d0*agg(k,2)
2126             ghalf3=0.5d0*agg(k,3)
2127             ghalf4=0.5d0*agg(k,4)
2128             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2129      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2130             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2131      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2132             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2133      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2134             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2135      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2136 C Derivatives in DC(i+1)
2137             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2138      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2139             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2140      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2141             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2142      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2143             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2144      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2145 C Derivatives in DC(j)
2146             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2147      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2148             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2149      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2150             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2151      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2152             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2153      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2154 C Derivatives in DC(j+1) or DC(nres-1)
2155             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2156      &      -3.0d0*vryg(k,3)*ury)
2157             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2158      &      -3.0d0*vrzg(k,3)*ury)
2159             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2160      &      -3.0d0*vryg(k,3)*urz)
2161             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2162      &      -3.0d0*vrzg(k,3)*urz)
2163 cd            aggi(k,1)=ghalf1
2164 cd            aggi(k,2)=ghalf2
2165 cd            aggi(k,3)=ghalf3
2166 cd            aggi(k,4)=ghalf4
2167 C Derivatives in DC(i+1)
2168 cd            aggi1(k,1)=agg(k,1)
2169 cd            aggi1(k,2)=agg(k,2)
2170 cd            aggi1(k,3)=agg(k,3)
2171 cd            aggi1(k,4)=agg(k,4)
2172 C Derivatives in DC(j)
2173 cd            aggj(k,1)=ghalf1
2174 cd            aggj(k,2)=ghalf2
2175 cd            aggj(k,3)=ghalf3
2176 cd            aggj(k,4)=ghalf4
2177 C Derivatives in DC(j+1)
2178 cd            aggj1(k,1)=0.0d0
2179 cd            aggj1(k,2)=0.0d0
2180 cd            aggj1(k,3)=0.0d0
2181 cd            aggj1(k,4)=0.0d0
2182             if (j.eq.nres-1 .and. i.lt.j-2) then
2183               do l=1,4
2184                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2185 cd                aggj1(k,l)=agg(k,l)
2186               enddo
2187             endif
2188           enddo
2189           endif
2190 c          goto 11111
2191 C Check the loc-el terms by numerical integration
2192           acipa(1,1)=a22
2193           acipa(1,2)=a23
2194           acipa(2,1)=a32
2195           acipa(2,2)=a33
2196           a22=-a22
2197           a23=-a23
2198           do l=1,2
2199             do k=1,3
2200               agg(k,l)=-agg(k,l)
2201               aggi(k,l)=-aggi(k,l)
2202               aggi1(k,l)=-aggi1(k,l)
2203               aggj(k,l)=-aggj(k,l)
2204               aggj1(k,l)=-aggj1(k,l)
2205             enddo
2206           enddo
2207           if (j.lt.nres-1) then
2208             a22=-a22
2209             a32=-a32
2210             do l=1,3,2
2211               do k=1,3
2212                 agg(k,l)=-agg(k,l)
2213                 aggi(k,l)=-aggi(k,l)
2214                 aggi1(k,l)=-aggi1(k,l)
2215                 aggj(k,l)=-aggj(k,l)
2216                 aggj1(k,l)=-aggj1(k,l)
2217               enddo
2218             enddo
2219           else
2220             a22=-a22
2221             a23=-a23
2222             a32=-a32
2223             a33=-a33
2224             do l=1,4
2225               do k=1,3
2226                 agg(k,l)=-agg(k,l)
2227                 aggi(k,l)=-aggi(k,l)
2228                 aggi1(k,l)=-aggi1(k,l)
2229                 aggj(k,l)=-aggj(k,l)
2230                 aggj1(k,l)=-aggj1(k,l)
2231               enddo
2232             enddo
2233           endif
2234           ENDIF ! WCORR
2235 11111     continue
2236           IF (wel_loc.gt.0.0d0) THEN
2237 C Contribution to the local-electrostatic energy coming from the i-j pair
2238           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2239      &     +a33*muij(4)
2240 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2241 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2242           eel_loc=eel_loc+eel_loc_ij
2243 C Partial derivatives in virtual-bond dihedral angles gamma
2244           if (calc_grad) then
2245           if (i.gt.1)
2246      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2247      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2248      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2249           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2250      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2251      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2252 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2253 cd          write(iout,*) 'agg  ',agg
2254 cd          write(iout,*) 'aggi ',aggi
2255 cd          write(iout,*) 'aggi1',aggi1
2256 cd          write(iout,*) 'aggj ',aggj
2257 cd          write(iout,*) 'aggj1',aggj1
2258
2259 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2260           do l=1,3
2261             ggg(l)=agg(l,1)*muij(1)+
2262      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2263           enddo
2264           do k=i+2,j2
2265             do l=1,3
2266               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2267             enddo
2268           enddo
2269 C Remaining derivatives of eello
2270           do l=1,3
2271             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2272      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2273             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2274      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2275             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2276      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2277             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2278      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2279           enddo
2280           endif
2281           ENDIF
2282           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2283 C Contributions from turns
2284             a_temp(1,1)=a22
2285             a_temp(1,2)=a23
2286             a_temp(2,1)=a32
2287             a_temp(2,2)=a33
2288             call eturn34(i,j,eello_turn3,eello_turn4)
2289           endif
2290 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2291           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2292 C
2293 C Calculate the contact function. The ith column of the array JCONT will
2294 C contain the numbers of atoms that make contacts with the atom I (of numbers
2295 C greater than I). The arrays FACONT and GACONT will contain the values of
2296 C the contact function and its derivative.
2297 c           r0ij=1.02D0*rpp(iteli,itelj)
2298 c           r0ij=1.11D0*rpp(iteli,itelj)
2299             r0ij=2.20D0*rpp(iteli,itelj)
2300 c           r0ij=1.55D0*rpp(iteli,itelj)
2301             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2302             if (fcont.gt.0.0D0) then
2303               num_conti=num_conti+1
2304               if (num_conti.gt.maxconts) then
2305                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2306      &                         ' will skip next contacts for this conf.'
2307               else
2308                 jcont_hb(num_conti,i)=j
2309                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2310      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2311 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2312 C  terms.
2313                 d_cont(num_conti,i)=rij
2314 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2315 C     --- Electrostatic-interaction matrix ---
2316                 a_chuj(1,1,num_conti,i)=a22
2317                 a_chuj(1,2,num_conti,i)=a23
2318                 a_chuj(2,1,num_conti,i)=a32
2319                 a_chuj(2,2,num_conti,i)=a33
2320 C     --- Gradient of rij
2321                 do kkk=1,3
2322                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2323                 enddo
2324 c             if (i.eq.1) then
2325 c                a_chuj(1,1,num_conti,i)=-0.61d0
2326 c                a_chuj(1,2,num_conti,i)= 0.4d0
2327 c                a_chuj(2,1,num_conti,i)= 0.65d0
2328 c                a_chuj(2,2,num_conti,i)= 0.50d0
2329 c             else if (i.eq.2) then
2330 c                a_chuj(1,1,num_conti,i)= 0.0d0
2331 c                a_chuj(1,2,num_conti,i)= 0.0d0
2332 c                a_chuj(2,1,num_conti,i)= 0.0d0
2333 c                a_chuj(2,2,num_conti,i)= 0.0d0
2334 c             endif
2335 C     --- and its gradients
2336 cd                write (iout,*) 'i',i,' j',j
2337 cd                do kkk=1,3
2338 cd                write (iout,*) 'iii 1 kkk',kkk
2339 cd                write (iout,*) agg(kkk,:)
2340 cd                enddo
2341 cd                do kkk=1,3
2342 cd                write (iout,*) 'iii 2 kkk',kkk
2343 cd                write (iout,*) aggi(kkk,:)
2344 cd                enddo
2345 cd                do kkk=1,3
2346 cd                write (iout,*) 'iii 3 kkk',kkk
2347 cd                write (iout,*) aggi1(kkk,:)
2348 cd                enddo
2349 cd                do kkk=1,3
2350 cd                write (iout,*) 'iii 4 kkk',kkk
2351 cd                write (iout,*) aggj(kkk,:)
2352 cd                enddo
2353 cd                do kkk=1,3
2354 cd                write (iout,*) 'iii 5 kkk',kkk
2355 cd                write (iout,*) aggj1(kkk,:)
2356 cd                enddo
2357                 kkll=0
2358                 do k=1,2
2359                   do l=1,2
2360                     kkll=kkll+1
2361                     do m=1,3
2362                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2363                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2364                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2365                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2366                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2367 c                      do mm=1,5
2368 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2369 c                      enddo
2370                     enddo
2371                   enddo
2372                 enddo
2373                 ENDIF
2374                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2375 C Calculate contact energies
2376                 cosa4=4.0D0*cosa
2377                 wij=cosa-3.0D0*cosb*cosg
2378                 cosbg1=cosb+cosg
2379                 cosbg2=cosb-cosg
2380 c               fac3=dsqrt(-ael6i)/r0ij**3
2381                 fac3=dsqrt(-ael6i)*r3ij
2382                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2383                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2384 c               ees0mij=0.0D0
2385                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2386                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2387 C Diagnostics. Comment out or remove after debugging!
2388 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2389 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2390 c               ees0m(num_conti,i)=0.0D0
2391 C End diagnostics.
2392 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2393 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2394                 facont_hb(num_conti,i)=fcont
2395                 if (calc_grad) then
2396 C Angular derivatives of the contact function
2397                 ees0pij1=fac3/ees0pij
2398                 ees0mij1=fac3/ees0mij
2399                 fac3p=-3.0D0*fac3*rrmij
2400                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2401                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2402 c               ees0mij1=0.0D0
2403                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2404                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2405                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2406                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2407                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2408                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2409                 ecosap=ecosa1+ecosa2
2410                 ecosbp=ecosb1+ecosb2
2411                 ecosgp=ecosg1+ecosg2
2412                 ecosam=ecosa1-ecosa2
2413                 ecosbm=ecosb1-ecosb2
2414                 ecosgm=ecosg1-ecosg2
2415 C Diagnostics
2416 c               ecosap=ecosa1
2417 c               ecosbp=ecosb1
2418 c               ecosgp=ecosg1
2419 c               ecosam=0.0D0
2420 c               ecosbm=0.0D0
2421 c               ecosgm=0.0D0
2422 C End diagnostics
2423                 fprimcont=fprimcont/rij
2424 cd              facont_hb(num_conti,i)=1.0D0
2425 C Following line is for diagnostics.
2426 cd              fprimcont=0.0D0
2427                 do k=1,3
2428                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2429                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2430                 enddo
2431                 do k=1,3
2432                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2433                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2434                 enddo
2435                 gggp(1)=gggp(1)+ees0pijp*xj
2436                 gggp(2)=gggp(2)+ees0pijp*yj
2437                 gggp(3)=gggp(3)+ees0pijp*zj
2438                 gggm(1)=gggm(1)+ees0mijp*xj
2439                 gggm(2)=gggm(2)+ees0mijp*yj
2440                 gggm(3)=gggm(3)+ees0mijp*zj
2441 C Derivatives due to the contact function
2442                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2443                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2444                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2445                 do k=1,3
2446                   ghalfp=0.5D0*gggp(k)
2447                   ghalfm=0.5D0*gggm(k)
2448                   gacontp_hb1(k,num_conti,i)=ghalfp
2449      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2450      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2451                   gacontp_hb2(k,num_conti,i)=ghalfp
2452      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2453      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2454                   gacontp_hb3(k,num_conti,i)=gggp(k)
2455                   gacontm_hb1(k,num_conti,i)=ghalfm
2456      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2457      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2458                   gacontm_hb2(k,num_conti,i)=ghalfm
2459      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2460      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2461                   gacontm_hb3(k,num_conti,i)=gggm(k)
2462                 enddo
2463                 endif
2464 C Diagnostics. Comment out or remove after debugging!
2465 cdiag           do k=1,3
2466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2472 cdiag           enddo
2473               ENDIF ! wcorr
2474               endif  ! num_conti.le.maxconts
2475             endif  ! fcont.gt.0
2476           endif    ! j.gt.i+1
2477  1216     continue
2478         enddo ! j
2479         num_cont_hb(i)=num_conti
2480  1215   continue
2481       enddo   ! i
2482 cd      do i=1,nres
2483 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2484 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2485 cd      enddo
2486 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2487 ccc      eel_loc=eel_loc+eello_turn3
2488       return
2489       end
2490 C-----------------------------------------------------------------------------
2491       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2492 C Third- and fourth-order contributions from turns
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'sizesclu.dat'
2496       include 'COMMON.IOUNITS'
2497       include 'COMMON.GEO'
2498       include 'COMMON.VAR'
2499       include 'COMMON.LOCAL'
2500       include 'COMMON.CHAIN'
2501       include 'COMMON.DERIV'
2502       include 'COMMON.INTERACT'
2503       include 'COMMON.CONTACTS'
2504       include 'COMMON.TORSION'
2505       include 'COMMON.VECTORS'
2506       include 'COMMON.FFIELD'
2507       dimension ggg(3)
2508       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2509      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2510      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2511       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2512      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2513       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2514       if (j.eq.i+2) then
2515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2516 C
2517 C               Third-order contributions
2518 C
2519 C                 (i+2)o----(i+3)
2520 C                      | |
2521 C                      | |
2522 C                 (i+1)o----i
2523 C
2524 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2525 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2526         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2527         call transpose2(auxmat(1,1),auxmat1(1,1))
2528         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2529         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2530 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2531 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2532 cd     &    ' eello_turn3_num',4*eello_turn3_num
2533         if (calc_grad) then
2534 C Derivatives in gamma(i)
2535         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2536         call transpose2(auxmat2(1,1),pizda(1,1))
2537         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2538         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2539 C Derivatives in gamma(i+1)
2540         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2541         call transpose2(auxmat2(1,1),pizda(1,1))
2542         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2543         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2544      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2545 C Cartesian derivatives
2546         do l=1,3
2547           a_temp(1,1)=aggi(l,1)
2548           a_temp(1,2)=aggi(l,2)
2549           a_temp(2,1)=aggi(l,3)
2550           a_temp(2,2)=aggi(l,4)
2551           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2552           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2553      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2554           a_temp(1,1)=aggi1(l,1)
2555           a_temp(1,2)=aggi1(l,2)
2556           a_temp(2,1)=aggi1(l,3)
2557           a_temp(2,2)=aggi1(l,4)
2558           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2559           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2560      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2561           a_temp(1,1)=aggj(l,1)
2562           a_temp(1,2)=aggj(l,2)
2563           a_temp(2,1)=aggj(l,3)
2564           a_temp(2,2)=aggj(l,4)
2565           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2566           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2567      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2568           a_temp(1,1)=aggj1(l,1)
2569           a_temp(1,2)=aggj1(l,2)
2570           a_temp(2,1)=aggj1(l,3)
2571           a_temp(2,2)=aggj1(l,4)
2572           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2573           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2574      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2575         enddo
2576         endif
2577       else if (j.eq.i+3) then
2578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2579 C
2580 C               Fourth-order contributions
2581 C
2582 C                 (i+3)o----(i+4)
2583 C                     /  |
2584 C               (i+2)o   |
2585 C                     \  |
2586 C                 (i+1)o----i
2587 C
2588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2589 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2590         iti1=itortyp(itype(i+1))
2591         iti2=itortyp(itype(i+2))
2592         iti3=itortyp(itype(i+3))
2593         call transpose2(EUg(1,1,i+1),e1t(1,1))
2594         call transpose2(Eug(1,1,i+2),e2t(1,1))
2595         call transpose2(Eug(1,1,i+3),e3t(1,1))
2596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2597         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2598         s1=scalar2(b1(1,iti2),auxvec(1))
2599         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2600         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2601         s2=scalar2(b1(1,iti1),auxvec(1))
2602         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2603         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2604         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2605         eello_turn4=eello_turn4-(s1+s2+s3)
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2607 cd     &    ' eello_turn4_num',8*eello_turn4_num
2608 C Derivatives in gamma(i)
2609         if (calc_grad) then
2610         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2611         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2613         s1=scalar2(b1(1,iti2),auxvec(1))
2614         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2615         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2617 C Derivatives in gamma(i+1)
2618         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2619         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2620         s2=scalar2(b1(1,iti1),auxvec(1))
2621         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2622         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2623         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2624         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2625 C Derivatives in gamma(i+2)
2626         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2627         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2628         s1=scalar2(b1(1,iti2),auxvec(1))
2629         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2631         s2=scalar2(b1(1,iti1),auxvec(1))
2632         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2633         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2634         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2636 C Cartesian derivatives
2637 C Derivatives of this turn contributions in DC(i+2)
2638         if (j.lt.nres-1) then
2639           do l=1,3
2640             a_temp(1,1)=agg(l,1)
2641             a_temp(1,2)=agg(l,2)
2642             a_temp(2,1)=agg(l,3)
2643             a_temp(2,2)=agg(l,4)
2644             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2645             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2646             s1=scalar2(b1(1,iti2),auxvec(1))
2647             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2648             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2649             s2=scalar2(b1(1,iti1),auxvec(1))
2650             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2651             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2652             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653             ggg(l)=-(s1+s2+s3)
2654             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2655           enddo
2656         endif
2657 C Remaining derivatives of this turn contribution
2658         do l=1,3
2659           a_temp(1,1)=aggi(l,1)
2660           a_temp(1,2)=aggi(l,2)
2661           a_temp(2,1)=aggi(l,3)
2662           a_temp(2,2)=aggi(l,4)
2663           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2664           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2665           s1=scalar2(b1(1,iti2),auxvec(1))
2666           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2667           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2668           s2=scalar2(b1(1,iti1),auxvec(1))
2669           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2670           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2671           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2672           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2673           a_temp(1,1)=aggi1(l,1)
2674           a_temp(1,2)=aggi1(l,2)
2675           a_temp(2,1)=aggi1(l,3)
2676           a_temp(2,2)=aggi1(l,4)
2677           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2678           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2679           s1=scalar2(b1(1,iti2),auxvec(1))
2680           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2681           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2682           s2=scalar2(b1(1,iti1),auxvec(1))
2683           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2684           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2685           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2686           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2687           a_temp(1,1)=aggj(l,1)
2688           a_temp(1,2)=aggj(l,2)
2689           a_temp(2,1)=aggj(l,3)
2690           a_temp(2,2)=aggj(l,4)
2691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2693           s1=scalar2(b1(1,iti2),auxvec(1))
2694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2696           s2=scalar2(b1(1,iti1),auxvec(1))
2697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2701           a_temp(1,1)=aggj1(l,1)
2702           a_temp(1,2)=aggj1(l,2)
2703           a_temp(2,1)=aggj1(l,3)
2704           a_temp(2,2)=aggj1(l,4)
2705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2707           s1=scalar2(b1(1,iti2),auxvec(1))
2708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2710           s2=scalar2(b1(1,iti1),auxvec(1))
2711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2714           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2715         enddo
2716         endif
2717       endif
2718       return
2719       end
2720 C-----------------------------------------------------------------------------
2721       subroutine vecpr(u,v,w)
2722       implicit real*8(a-h,o-z)
2723       dimension u(3),v(3),w(3)
2724       w(1)=u(2)*v(3)-u(3)*v(2)
2725       w(2)=-u(1)*v(3)+u(3)*v(1)
2726       w(3)=u(1)*v(2)-u(2)*v(1)
2727       return
2728       end
2729 C-----------------------------------------------------------------------------
2730       subroutine unormderiv(u,ugrad,unorm,ungrad)
2731 C This subroutine computes the derivatives of a normalized vector u, given
2732 C the derivatives computed without normalization conditions, ugrad. Returns
2733 C ungrad.
2734       implicit none
2735       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2736       double precision vec(3)
2737       double precision scalar
2738       integer i,j
2739 c      write (2,*) 'ugrad',ugrad
2740 c      write (2,*) 'u',u
2741       do i=1,3
2742         vec(i)=scalar(ugrad(1,i),u(1))
2743       enddo
2744 c      write (2,*) 'vec',vec
2745       do i=1,3
2746         do j=1,3
2747           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2748         enddo
2749       enddo
2750 c      write (2,*) 'ungrad',ungrad
2751       return
2752       end
2753 C-----------------------------------------------------------------------------
2754       subroutine escp(evdw2,evdw2_14)
2755 C
2756 C This subroutine calculates the excluded-volume interaction energy between
2757 C peptide-group centers and side chains and its gradient in virtual-bond and
2758 C side-chain vectors.
2759 C
2760       implicit real*8 (a-h,o-z)
2761       include 'DIMENSIONS'
2762       include 'sizesclu.dat'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.FFIELD'
2770       include 'COMMON.IOUNITS'
2771       dimension ggg(3)
2772       evdw2=0.0D0
2773       evdw2_14=0.0d0
2774 cd    print '(a)','Enter ESCP'
2775 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2776 c     &  ' scal14',scal14
2777       do i=iatscp_s,iatscp_e
2778         iteli=itel(i)
2779 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2780 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2781         if (iteli.eq.0) goto 1225
2782         xi=0.5D0*(c(1,i)+c(1,i+1))
2783         yi=0.5D0*(c(2,i)+c(2,i+1))
2784         zi=0.5D0*(c(3,i)+c(3,i+1))
2785
2786         do iint=1,nscp_gr(i)
2787
2788         do j=iscpstart(i,iint),iscpend(i,iint)
2789           itypj=itype(j)
2790 C Uncomment following three lines for SC-p interactions
2791 c         xj=c(1,nres+j)-xi
2792 c         yj=c(2,nres+j)-yi
2793 c         zj=c(3,nres+j)-zi
2794 C Uncomment following three lines for Ca-p interactions
2795           xj=c(1,j)-xi
2796           yj=c(2,j)-yi
2797           zj=c(3,j)-zi
2798           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2799           fac=rrij**expon2
2800           e1=fac*fac*aad(itypj,iteli)
2801           e2=fac*bad(itypj,iteli)
2802           if (iabs(j-i) .le. 2) then
2803             e1=scal14*e1
2804             e2=scal14*e2
2805             evdw2_14=evdw2_14+e1+e2
2806           endif
2807           evdwij=e1+e2
2808 c          write (iout,*) i,j,evdwij
2809           evdw2=evdw2+evdwij
2810           if (calc_grad) then
2811 C
2812 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2813 C
2814           fac=-(evdwij+e1)*rrij
2815           ggg(1)=xj*fac
2816           ggg(2)=yj*fac
2817           ggg(3)=zj*fac
2818           if (j.lt.i) then
2819 cd          write (iout,*) 'j<i'
2820 C Uncomment following three lines for SC-p interactions
2821 c           do k=1,3
2822 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2823 c           enddo
2824           else
2825 cd          write (iout,*) 'j>i'
2826             do k=1,3
2827               ggg(k)=-ggg(k)
2828 C Uncomment following line for SC-p interactions
2829 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2830             enddo
2831           endif
2832           do k=1,3
2833             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2834           enddo
2835           kstart=min0(i+1,j)
2836           kend=max0(i-1,j-1)
2837 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2838 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2839           do k=kstart,kend
2840             do l=1,3
2841               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2842             enddo
2843           enddo
2844           endif
2845         enddo
2846         enddo ! iint
2847  1225   continue
2848       enddo ! i
2849       do i=1,nct
2850         do j=1,3
2851           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2852           gradx_scp(j,i)=expon*gradx_scp(j,i)
2853         enddo
2854       enddo
2855 C******************************************************************************
2856 C
2857 C                              N O T E !!!
2858 C
2859 C To save time the factor EXPON has been extracted from ALL components
2860 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2861 C use!
2862 C
2863 C******************************************************************************
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine edis(ehpb)
2868 C
2869 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2870 C
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873       include 'COMMON.SBRIDGE'
2874       include 'COMMON.CHAIN'
2875       include 'COMMON.DERIV'
2876       include 'COMMON.VAR'
2877       include 'COMMON.INTERACT'
2878       include 'COMMON.IOUNITS'
2879       include 'COMMON.CONTROL'
2880       dimension ggg(3)
2881       ehpb=0.0D0
2882 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2883 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2884       if (link_end.eq.0) return
2885       do i=link_start,link_end
2886 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2887 C CA-CA distance used in regularization of structure.
2888         ii=ihpb(i)
2889         jj=jhpb(i)
2890 C iii and jjj point to the residues for which the distance is assigned.
2891         if (ii.gt.nres) then
2892           iii=ii-nres
2893           jjj=jj-nres
2894         else
2895           iii=ii
2896           jjj=jj
2897         endif
2898 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2899 c     &    dhpb(i),dhpb1(i),forcon(i)
2900 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2901 C    distance and angle dependent SS bond potential.
2902         if (.not.dyn_ss .and. i.le.nss) then
2903 C 15/02/13 CC dynamic SSbond - additional check
2904         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2905           call ssbond_ene(iii,jjj,eij)
2906           ehpb=ehpb+2*eij
2907 cd          write (iout,*) "eij",eij
2908         endif
2909         else if (ii.gt.nres .and. jj.gt.nres) then
2910 c Restraints from contact prediction
2911           dd=dist(ii,jj)
2912          if (constr_dist.eq.11) then
2913             ehpb=ehpb+fordepth(i)**4.0d0
2914      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2915             fac=fordepth(i)**4.0d0
2916      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2917          else
2918           if (dhpb1(i).gt.0.0d0) then
2919             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2920             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2921 c            write (iout,*) "beta nmr",
2922 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2923           else
2924             dd=dist(ii,jj)
2925             rdis=dd-dhpb(i)
2926 C Get the force constant corresponding to this distance.
2927             waga=forcon(i)
2928 C Calculate the contribution to energy.
2929             ehpb=ehpb+waga*rdis*rdis
2930 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2931 C
2932 C Evaluate gradient.
2933 C
2934             fac=waga*rdis/dd
2935           endif !end dhpb1(i).gt.0
2936          endif !end const_dist=11
2937           do j=1,3
2938             ggg(j)=fac*(c(j,jj)-c(j,ii))
2939           enddo
2940           do j=1,3
2941             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2942             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2943           enddo
2944           do k=1,3
2945             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2946             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2947           enddo
2948         else
2949 C Calculate the distance between the two points and its difference from the
2950 C target distance.
2951           dd=dist(ii,jj)
2952 C          write(iout,*) "after",dd
2953           if (constr_dist.eq.11) then
2954             ehpb=ehpb+fordepth(i)**4.0d0
2955      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2956             fac=fordepth(i)**4.0d0
2957      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2958 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
2959 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
2960 C            print *,ehpb,"tu?"
2961 C            write(iout,*) ehpb,"btu?",
2962 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
2963 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
2964 C     &    ehpb,fordepth(i),dd
2965            else
2966           if (dhpb1(i).gt.0.0d0) then
2967             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2968             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2969 c            write (iout,*) "alph nmr",
2970 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2971           else
2972             rdis=dd-dhpb(i)
2973 C Get the force constant corresponding to this distance.
2974             waga=forcon(i)
2975 C Calculate the contribution to energy.
2976             ehpb=ehpb+waga*rdis*rdis
2977 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2978 C
2979 C Evaluate gradient.
2980 C
2981             fac=waga*rdis/dd
2982           endif
2983           endif
2984 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2985 cd   &   ' waga=',waga,' fac=',fac
2986             do j=1,3
2987               ggg(j)=fac*(c(j,jj)-c(j,ii))
2988             enddo
2989 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2990 C If this is a SC-SC distance, we need to calculate the contributions to the
2991 C Cartesian gradient in the SC vectors (ghpbx).
2992           if (iii.lt.ii) then
2993           do j=1,3
2994             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2995             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2996           enddo
2997           endif
2998           do k=1,3
2999             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3000             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3001           enddo
3002         endif
3003       enddo
3004       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3005       return
3006       end
3007 C--------------------------------------------------------------------------
3008       subroutine ssbond_ene(i,j,eij)
3009 C
3010 C Calculate the distance and angle dependent SS-bond potential energy
3011 C using a free-energy function derived based on RHF/6-31G** ab initio
3012 C calculations of diethyl disulfide.
3013 C
3014 C A. Liwo and U. Kozlowska, 11/24/03
3015 C
3016       implicit real*8 (a-h,o-z)
3017       include 'DIMENSIONS'
3018       include 'sizesclu.dat'
3019       include 'COMMON.SBRIDGE'
3020       include 'COMMON.CHAIN'
3021       include 'COMMON.DERIV'
3022       include 'COMMON.LOCAL'
3023       include 'COMMON.INTERACT'
3024       include 'COMMON.VAR'
3025       include 'COMMON.IOUNITS'
3026       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3027       itypi=itype(i)
3028       xi=c(1,nres+i)
3029       yi=c(2,nres+i)
3030       zi=c(3,nres+i)
3031       dxi=dc_norm(1,nres+i)
3032       dyi=dc_norm(2,nres+i)
3033       dzi=dc_norm(3,nres+i)
3034       dsci_inv=dsc_inv(itypi)
3035       itypj=itype(j)
3036       dscj_inv=dsc_inv(itypj)
3037       xj=c(1,nres+j)-xi
3038       yj=c(2,nres+j)-yi
3039       zj=c(3,nres+j)-zi
3040       dxj=dc_norm(1,nres+j)
3041       dyj=dc_norm(2,nres+j)
3042       dzj=dc_norm(3,nres+j)
3043       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3044       rij=dsqrt(rrij)
3045       erij(1)=xj*rij
3046       erij(2)=yj*rij
3047       erij(3)=zj*rij
3048       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3049       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3050       om12=dxi*dxj+dyi*dyj+dzi*dzj
3051       do k=1,3
3052         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3053         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3054       enddo
3055       rij=1.0d0/rij
3056       deltad=rij-d0cm
3057       deltat1=1.0d0-om1
3058       deltat2=1.0d0+om2
3059       deltat12=om2-om1+2.0d0
3060       cosphi=om12-om1*om2
3061       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3062      &  +akct*deltad*deltat12+ebr
3063      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3064 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3065 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3066 c     &  " deltat12",deltat12," eij",eij
3067       ed=2*akcm*deltad+akct*deltat12
3068       pom1=akct*deltad
3069       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3070       eom1=-2*akth*deltat1-pom1-om2*pom2
3071       eom2= 2*akth*deltat2+pom1-om1*pom2
3072       eom12=pom2
3073       do k=1,3
3074         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3075       enddo
3076       do k=1,3
3077         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3078      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3079         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3080      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3081       enddo
3082 C
3083 C Calculate the components of the gradient in DC and X
3084 C
3085       do k=i,j-1
3086         do l=1,3
3087           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3088         enddo
3089       enddo
3090       return
3091       end
3092
3093 C--------------------------------------------------------------------------
3094
3095
3096 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3097       subroutine e_modeller(ehomology_constr)
3098       implicit real*8 (a-h,o-z)
3099
3100       include 'DIMENSIONS'
3101
3102       integer nnn, i, j, k, ki, irec, l
3103       integer katy, odleglosci, test7
3104       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3105       real*8 distance(max_template),distancek(max_template),
3106      &    min_odl,godl(max_template),dih_diff(max_template)
3107
3108 c
3109 c     FP - 30/10/2014 Temporary specifications for homology restraints
3110 c
3111       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3112      &                 sgtheta
3113       double precision, dimension (maxres) :: guscdiff,usc_diff
3114       double precision, dimension (max_template) ::
3115      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3116      &           theta_diff
3117
3118       include 'COMMON.SBRIDGE'
3119       include 'COMMON.CHAIN'
3120       include 'COMMON.GEO'
3121       include 'COMMON.DERIV'
3122       include 'COMMON.LOCAL'
3123       include 'COMMON.INTERACT'
3124       include 'COMMON.VAR'
3125       include 'COMMON.IOUNITS'
3126       include 'COMMON.CONTROL'
3127       include 'COMMON.HOMRESTR'
3128 c
3129       include 'COMMON.SETUP'
3130       include 'COMMON.NAMES'
3131
3132       do i=1,max_template
3133         distancek(i)=9999999.9
3134       enddo
3135
3136       odleg=0.0d0
3137
3138 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3139 c function)
3140 C AL 5/2/14 - Introduce list of restraints
3141 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3142 #ifdef DEBUG
3143       write(iout,*) "------- dist restrs start -------"
3144       write (iout,*) "link_start_homo",link_start_homo,
3145      &    " link_end_homo",link_end_homo
3146 #endif
3147       do ii = link_start_homo,link_end_homo
3148          i = ires_homo(ii)
3149          j = jres_homo(ii)
3150          dij=dist(i,j)
3151 c        write (iout,*) "dij(",i,j,") =",dij
3152          nexl=0
3153          do k=1,constr_homology
3154            if(.not.l_homo(k,ii)) then
3155               nexl=nexl+1
3156               cycle
3157            endif
3158            distance(k)=odl(k,ii)-dij
3159 c          write (iout,*) "distance(",k,") =",distance(k)
3160 c
3161 c          For Gaussian-type Urestr
3162 c
3163            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3164 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3165 c          write (iout,*) "distancek(",k,") =",distancek(k)
3166 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3167 c
3168 c          For Lorentzian-type Urestr
3169 c
3170            if (waga_dist.lt.0.0d0) then
3171               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3172               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3173      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3174            endif
3175          enddo
3176
3177 c         min_odl=minval(distancek)
3178          do kk=1,constr_homology
3179           if(l_homo(kk,ii)) then
3180             min_odl=distancek(kk)
3181             exit
3182           endif
3183          enddo
3184          do kk=1,constr_homology
3185           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3186      &              min_odl=distancek(kk)
3187          enddo
3188 c        write (iout,* )"min_odl",min_odl
3189 #ifdef DEBUG
3190          write (iout,*) "ij dij",i,j,dij
3191          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3192          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3193          write (iout,* )"min_odl",min_odl
3194 #endif
3195 #ifdef OLDRESTR
3196          odleg2=0.0d0
3197 #else
3198          if (waga_dist.ge.0.0d0) then
3199            odleg2=nexl
3200          else
3201            odleg2=0.0d0
3202          endif
3203 #endif
3204          do k=1,constr_homology
3205 c Nie wiem po co to liczycie jeszcze raz!
3206 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3207 c     &              (2*(sigma_odl(i,j,k))**2))
3208            if(.not.l_homo(k,ii)) cycle
3209            if (waga_dist.ge.0.0d0) then
3210 c
3211 c          For Gaussian-type Urestr
3212 c
3213             godl(k)=dexp(-distancek(k)+min_odl)
3214             odleg2=odleg2+godl(k)
3215 c
3216 c          For Lorentzian-type Urestr
3217 c
3218            else
3219             odleg2=odleg2+distancek(k)
3220            endif
3221
3222 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3223 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3224 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3225 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3226
3227          enddo
3228 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3229 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3230 #ifdef DEBUG
3231          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3232          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3233 #endif
3234            if (waga_dist.ge.0.0d0) then
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3239 c
3240 c          For Lorentzian-type Urestr
3241 c
3242            else
3243               odleg=odleg+odleg2/constr_homology
3244            endif
3245 c
3246 #ifdef GRAD
3247 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3248 c Gradient
3249 c
3250 c          For Gaussian-type Urestr
3251 c
3252          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3253          sum_sgodl=0.0d0
3254          do k=1,constr_homology
3255 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3256 c     &           *waga_dist)+min_odl
3257 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3258 c
3259          if(.not.l_homo(k,ii)) cycle
3260          if (waga_dist.ge.0.0d0) then
3261 c          For Gaussian-type Urestr
3262 c
3263            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3264 c
3265 c          For Lorentzian-type Urestr
3266 c
3267          else
3268            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3269      &           sigma_odlir(k,ii)**2)**2)
3270          endif
3271            sum_sgodl=sum_sgodl+sgodl
3272
3273 c            sgodl2=sgodl2+sgodl
3274 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3275 c      write(iout,*) "constr_homology=",constr_homology
3276 c      write(iout,*) i, j, k, "TEST K"
3277          enddo
3278          if (waga_dist.ge.0.0d0) then
3279 c
3280 c          For Gaussian-type Urestr
3281 c
3282             grad_odl3=waga_homology(iset)*waga_dist
3283      &                *sum_sgodl/(sum_godl*dij)
3284 c
3285 c          For Lorentzian-type Urestr
3286 c
3287          else
3288 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3289 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3290             grad_odl3=-waga_homology(iset)*waga_dist*
3291      &                sum_sgodl/(constr_homology*dij)
3292          endif
3293 c
3294 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3295
3296
3297 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3298 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3299 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3300
3301 ccc      write(iout,*) godl, sgodl, grad_odl3
3302
3303 c          grad_odl=grad_odl+grad_odl3
3304
3305          do jik=1,3
3306             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3307 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3308 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3309 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3310             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3311             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3312 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3313 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3314 c         if (i.eq.25.and.j.eq.27) then
3315 c         write(iout,*) "jik",jik,"i",i,"j",j
3316 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3317 c         write(iout,*) "grad_odl3",grad_odl3
3318 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3319 c         write(iout,*) "ggodl",ggodl
3320 c         write(iout,*) "ghpbc(",jik,i,")",
3321 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3322 c     &                 ghpbc(jik,j)
3323 c         endif
3324          enddo
3325 #endif
3326 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3327 ccc     & dLOG(odleg2),"-odleg=", -odleg
3328
3329       enddo ! ii-loop for dist
3330 #ifdef DEBUG
3331       write(iout,*) "------- dist restrs end -------"
3332 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3333 c    &     waga_d.eq.1.0d0) call sum_gradient
3334 #endif
3335 c Pseudo-energy and gradient from dihedral-angle restraints from
3336 c homology templates
3337 c      write (iout,*) "End of distance loop"
3338 c      call flush(iout)
3339       kat=0.0d0
3340 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3341 #ifdef DEBUG
3342       write(iout,*) "------- dih restrs start -------"
3343       do i=idihconstr_start_homo,idihconstr_end_homo
3344         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3345       enddo
3346 #endif
3347       do i=idihconstr_start_homo,idihconstr_end_homo
3348         kat2=0.0d0
3349 c        betai=beta(i,i+1,i+2,i+3)
3350         betai = phi(i)
3351 c       write (iout,*) "betai =",betai
3352         do k=1,constr_homology
3353           dih_diff(k)=pinorm(dih(k,i)-betai)
3354 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3355 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3356 c     &                                   -(6.28318-dih_diff(i,k))
3357 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3358 c     &                                   6.28318+dih_diff(i,k)
3359 #ifdef OLD_DIHED
3360           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3361 #else
3362           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3363 #endif
3364 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3365           gdih(k)=dexp(kat3)
3366           kat2=kat2+gdih(k)
3367 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3368 c          write(*,*)""
3369         enddo
3370 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3371 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3372 #ifdef DEBUG
3373         write (iout,*) "i",i," betai",betai," kat2",kat2
3374         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3375 #endif
3376         if (kat2.le.1.0d-14) cycle
3377         kat=kat-dLOG(kat2/constr_homology)
3378 c       write (iout,*) "kat",kat ! sum of -ln-s
3379
3380 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3381 ccc     & dLOG(kat2), "-kat=", -kat
3382
3383 #ifdef GRAD
3384 c ----------------------------------------------------------------------
3385 c Gradient
3386 c ----------------------------------------------------------------------
3387
3388         sum_gdih=kat2
3389         sum_sgdih=0.0d0
3390         do k=1,constr_homology
3391 #ifdef OLD_DIHED
3392           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3393 #else
3394           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3395 #endif
3396 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3397           sum_sgdih=sum_sgdih+sgdih
3398         enddo
3399 c       grad_dih3=sum_sgdih/sum_gdih
3400         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3401
3402 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3403 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3404 ccc     & gloc(nphi+i-3,icg)
3405         gloc(i,icg)=gloc(i,icg)+grad_dih3
3406 c        if (i.eq.25) then
3407 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3408 c        endif
3409 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3410 ccc     & gloc(nphi+i-3,icg)
3411 #endif
3412       enddo ! i-loop for dih
3413 #ifdef DEBUG
3414       write(iout,*) "------- dih restrs end -------"
3415 #endif
3416
3417 c Pseudo-energy and gradient for theta angle restraints from
3418 c homology templates
3419 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3420 c adapted
3421
3422 c
3423 c     For constr_homology reference structures (FP)
3424 c
3425 c     Uconst_back_tot=0.0d0
3426       Eval=0.0d0
3427       Erot=0.0d0
3428 c     Econstr_back legacy
3429 #ifdef GRAD
3430       do i=1,nres
3431 c     do i=ithet_start,ithet_end
3432        dutheta(i)=0.0d0
3433 c     enddo
3434 c     do i=loc_start,loc_end
3435         do j=1,3
3436           duscdiff(j,i)=0.0d0
3437           duscdiffx(j,i)=0.0d0
3438         enddo
3439       enddo
3440 #endif
3441 c
3442 c     do iref=1,nref
3443 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3444 c     write (iout,*) "waga_theta",waga_theta
3445       if (waga_theta.gt.0.0d0) then
3446 #ifdef DEBUG
3447       write (iout,*) "usampl",usampl
3448       write(iout,*) "------- theta restrs start -------"
3449 c     do i=ithet_start,ithet_end
3450 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3451 c     enddo
3452 #endif
3453 c     write (iout,*) "maxres",maxres,"nres",nres
3454
3455       do i=ithet_start,ithet_end
3456 c
3457 c     do i=1,nfrag_back
3458 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3459 c
3460 c Deviation of theta angles wrt constr_homology ref structures
3461 c
3462         utheta_i=0.0d0 ! argument of Gaussian for single k
3463         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3464 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3465 c       over residues in a fragment
3466 c       write (iout,*) "theta(",i,")=",theta(i)
3467         do k=1,constr_homology
3468 c
3469 c         dtheta_i=theta(j)-thetaref(j,iref)
3470 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3471           theta_diff(k)=thetatpl(k,i)-theta(i)
3472 c
3473           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3474 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3475           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3476           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3477 c         Gradient for single Gaussian restraint in subr Econstr_back
3478 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3479 c
3480         enddo
3481 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3482 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3483
3484 c
3485 #ifdef GRAD
3486 c         Gradient for multiple Gaussian restraint
3487         sum_gtheta=gutheta_i
3488         sum_sgtheta=0.0d0
3489         do k=1,constr_homology
3490 c        New generalized expr for multiple Gaussian from Econstr_back
3491          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3492 c
3493 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3494           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3495         enddo
3496 c
3497 c       Final value of gradient using same var as in Econstr_back
3498         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3499      &               *waga_homology(iset)
3500 c       dutheta(i)=sum_sgtheta/sum_gtheta
3501 c
3502 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3503 #endif
3504         Eval=Eval-dLOG(gutheta_i/constr_homology)
3505 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3506 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3507 c       Uconst_back=Uconst_back+utheta(i)
3508       enddo ! (i-loop for theta)
3509 #ifdef DEBUG
3510       write(iout,*) "------- theta restrs end -------"
3511 #endif
3512       endif
3513 c
3514 c Deviation of local SC geometry
3515 c
3516 c Separation of two i-loops (instructed by AL - 11/3/2014)
3517 c
3518 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3519 c     write (iout,*) "waga_d",waga_d
3520
3521 #ifdef DEBUG
3522       write(iout,*) "------- SC restrs start -------"
3523       write (iout,*) "Initial duscdiff,duscdiffx"
3524       do i=loc_start,loc_end
3525         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3526      &                 (duscdiffx(jik,i),jik=1,3)
3527       enddo
3528 #endif
3529       do i=loc_start,loc_end
3530         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3531         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3532 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3533 c       write(iout,*) "xxtab, yytab, zztab"
3534 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3535         do k=1,constr_homology
3536 c
3537           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3538 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3539           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3540           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3541 c         write(iout,*) "dxx, dyy, dzz"
3542 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3543 c
3544           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3545 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3546 c         uscdiffk(k)=usc_diff(i)
3547           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3548           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3549 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3550 c     &      xxref(j),yyref(j),zzref(j)
3551         enddo
3552 c
3553 c       Gradient
3554 c
3555 c       Generalized expression for multiple Gaussian acc to that for a single
3556 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3557 c
3558 c       Original implementation
3559 c       sum_guscdiff=guscdiff(i)
3560 c
3561 c       sum_sguscdiff=0.0d0
3562 c       do k=1,constr_homology
3563 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3564 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3565 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3566 c       enddo
3567 c
3568 c       Implementation of new expressions for gradient (Jan. 2015)
3569 c
3570 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3571 #ifdef GRAD
3572         do k=1,constr_homology
3573 c
3574 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3575 c       before. Now the drivatives should be correct
3576 c
3577           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3578 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3579           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3580           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3581 c
3582 c         New implementation
3583 c
3584           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3585      &                 sigma_d(k,i) ! for the grad wrt r'
3586 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3587 c
3588 c
3589 c        New implementation
3590          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3591          do jik=1,3
3592             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3593      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3594      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3595             duscdiff(jik,i)=duscdiff(jik,i)+
3596      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3597      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3598             duscdiffx(jik,i)=duscdiffx(jik,i)+
3599      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3600      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3601 c
3602 #ifdef DEBUG
3603              write(iout,*) "jik",jik,"i",i
3604              write(iout,*) "dxx, dyy, dzz"
3605              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3606              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3607 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3608 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3609 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3610 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3611 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3612 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3613 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3614 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3615 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3616 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3617 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3618 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3619 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3620 c            endif
3621 #endif
3622          enddo
3623         enddo
3624 #endif
3625 c
3626 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3627 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3628 c
3629 c        write (iout,*) i," uscdiff",uscdiff(i)
3630 c
3631 c Put together deviations from local geometry
3632
3633 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3634 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3635         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3636 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3637 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3638 c       Uconst_back=Uconst_back+usc_diff(i)
3639 c
3640 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3641 c
3642 c     New implment: multiplied by sum_sguscdiff
3643 c
3644
3645       enddo ! (i-loop for dscdiff)
3646
3647 c      endif
3648
3649 #ifdef DEBUG
3650       write(iout,*) "------- SC restrs end -------"
3651         write (iout,*) "------ After SC loop in e_modeller ------"
3652         do i=loc_start,loc_end
3653          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3654          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3655         enddo
3656       if (waga_theta.eq.1.0d0) then
3657       write (iout,*) "in e_modeller after SC restr end: dutheta"
3658       do i=ithet_start,ithet_end
3659         write (iout,*) i,dutheta(i)
3660       enddo
3661       endif
3662       if (waga_d.eq.1.0d0) then
3663       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3664       do i=1,nres
3665         write (iout,*) i,(duscdiff(j,i),j=1,3)
3666         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3667       enddo
3668       endif
3669 #endif
3670
3671 c Total energy from homology restraints
3672 #ifdef DEBUG
3673       write (iout,*) "odleg",odleg," kat",kat
3674       write (iout,*) "odleg",odleg," kat",kat
3675       write (iout,*) "Eval",Eval," Erot",Erot
3676       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3677       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3678       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3679       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3680 #endif
3681 c
3682 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3683 c
3684 c     ehomology_constr=odleg+kat
3685 c
3686 c     For Lorentzian-type Urestr
3687 c
3688
3689       if (waga_dist.ge.0.0d0) then
3690 c
3691 c          For Gaussian-type Urestr
3692 c
3693         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3694      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3695 c     write (iout,*) "ehomology_constr=",ehomology_constr
3696       else
3697 c
3698 c          For Lorentzian-type Urestr
3699 c
3700         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3701      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3702 c     write (iout,*) "ehomology_constr=",ehomology_constr
3703       endif
3704 #ifdef DEBUG
3705       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
3706       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3707      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
3708       write (iout,*) "ehomology_constr",ehomology_constr
3709 #endif
3710       return
3711
3712   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3713   747 format(a12,i4,i4,i4,f8.3,f8.3)
3714   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3715   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3716   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3717      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3718       end
3719 C--------------------------------------------------------------------------
3720       subroutine ebond(estr)
3721 c
3722 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3723 c
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.LOCAL'
3727       include 'COMMON.GEO'
3728       include 'COMMON.INTERACT'
3729       include 'COMMON.DERIV'
3730       include 'COMMON.VAR'
3731       include 'COMMON.CHAIN'
3732       include 'COMMON.IOUNITS'
3733       include 'COMMON.NAMES'
3734       include 'COMMON.FFIELD'
3735       include 'COMMON.CONTROL'
3736       double precision u(3),ud(3)
3737       estr=0.0d0
3738       do i=nnt+1,nct
3739         diff = vbld(i)-vbldp0
3740 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3741         estr=estr+diff*diff
3742         do j=1,3
3743           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3744         enddo
3745       enddo
3746       estr=0.5d0*AKP*estr
3747 c
3748 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3749 c
3750       do i=nnt,nct
3751         iti=itype(i)
3752         if (iti.ne.10) then
3753           nbi=nbondterm(iti)
3754           if (nbi.eq.1) then
3755             diff=vbld(i+nres)-vbldsc0(1,iti)
3756 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3757 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3758             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3759             do j=1,3
3760               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3761             enddo
3762           else
3763             do j=1,nbi
3764               diff=vbld(i+nres)-vbldsc0(j,iti)
3765               ud(j)=aksc(j,iti)*diff
3766               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3767             enddo
3768             uprod=u(1)
3769             do j=2,nbi
3770               uprod=uprod*u(j)
3771             enddo
3772             usum=0.0d0
3773             usumsqder=0.0d0
3774             do j=1,nbi
3775               uprod1=1.0d0
3776               uprod2=1.0d0
3777               do k=1,nbi
3778                 if (k.ne.j) then
3779                   uprod1=uprod1*u(k)
3780                   uprod2=uprod2*u(k)*u(k)
3781                 endif
3782               enddo
3783               usum=usum+uprod1
3784               usumsqder=usumsqder+ud(j)*uprod2
3785             enddo
3786 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3787 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3788             estr=estr+uprod/usum
3789             do j=1,3
3790              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3791             enddo
3792           endif
3793         endif
3794       enddo
3795       return
3796       end
3797 #ifdef CRYST_THETA
3798 C--------------------------------------------------------------------------
3799       subroutine ebend(etheta)
3800 C
3801 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3802 C angles gamma and its derivatives in consecutive thetas and gammas.
3803 C
3804       implicit real*8 (a-h,o-z)
3805       include 'DIMENSIONS'
3806       include 'sizesclu.dat'
3807       include 'COMMON.LOCAL'
3808       include 'COMMON.GEO'
3809       include 'COMMON.INTERACT'
3810       include 'COMMON.DERIV'
3811       include 'COMMON.VAR'
3812       include 'COMMON.CHAIN'
3813       include 'COMMON.IOUNITS'
3814       include 'COMMON.NAMES'
3815       include 'COMMON.FFIELD'
3816       common /calcthet/ term1,term2,termm,diffak,ratak,
3817      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3818      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3819       double precision y(2),z(2)
3820       delta=0.02d0*pi
3821       time11=dexp(-2*time)
3822       time12=1.0d0
3823       etheta=0.0D0
3824 c      write (iout,*) "nres",nres
3825 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3826 c      write (iout,*) ithet_start,ithet_end
3827       do i=ithet_start,ithet_end
3828 C Zero the energy function and its derivative at 0 or pi.
3829         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3830         it=itype(i-1)
3831 c        if (i.gt.ithet_start .and.
3832 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3833 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3834 c          phii=phi(i)
3835 c          y(1)=dcos(phii)
3836 c          y(2)=dsin(phii)
3837 c        else
3838 c          y(1)=0.0D0
3839 c          y(2)=0.0D0
3840 c        endif
3841 c        if (i.lt.nres .and. itel(i).ne.0) then
3842 c          phii1=phi(i+1)
3843 c          z(1)=dcos(phii1)
3844 c          z(2)=dsin(phii1)
3845 c        else
3846 c          z(1)=0.0D0
3847 c          z(2)=0.0D0
3848 c        endif
3849         if (i.gt.3) then
3850 #ifdef OSF
3851           phii=phi(i)
3852           icrc=0
3853           call proc_proc(phii,icrc)
3854           if (icrc.eq.1) phii=150.0
3855 #else
3856           phii=phi(i)
3857 #endif
3858           y(1)=dcos(phii)
3859           y(2)=dsin(phii)
3860         else
3861           y(1)=0.0D0
3862           y(2)=0.0D0
3863         endif
3864         if (i.lt.nres) then
3865 #ifdef OSF
3866           phii1=phi(i+1)
3867           icrc=0
3868           call proc_proc(phii1,icrc)
3869           if (icrc.eq.1) phii1=150.0
3870           phii1=pinorm(phii1)
3871           z(1)=cos(phii1)
3872 #else
3873           phii1=phi(i+1)
3874           z(1)=dcos(phii1)
3875 #endif
3876           z(2)=dsin(phii1)
3877         else
3878           z(1)=0.0D0
3879           z(2)=0.0D0
3880         endif
3881 C Calculate the "mean" value of theta from the part of the distribution
3882 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3883 C In following comments this theta will be referred to as t_c.
3884         thet_pred_mean=0.0d0
3885         do k=1,2
3886           athetk=athet(k,it)
3887           bthetk=bthet(k,it)
3888           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3889         enddo
3890 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3891         dthett=thet_pred_mean*ssd
3892         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3893 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3894 C Derivatives of the "mean" values in gamma1 and gamma2.
3895         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3896         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3897         if (theta(i).gt.pi-delta) then
3898           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3899      &         E_tc0)
3900           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3901           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3902           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3903      &        E_theta)
3904           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3905      &        E_tc)
3906         else if (theta(i).lt.delta) then
3907           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3908           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3909           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3910      &        E_theta)
3911           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3912           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3913      &        E_tc)
3914         else
3915           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3916      &        E_theta,E_tc)
3917         endif
3918         etheta=etheta+ethetai
3919 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3920 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3921         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3922         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3923         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3924  1215   continue
3925       enddo
3926 C Ufff.... We've done all this!!!
3927       return
3928       end
3929 C---------------------------------------------------------------------------
3930       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3931      &     E_tc)
3932       implicit real*8 (a-h,o-z)
3933       include 'DIMENSIONS'
3934       include 'COMMON.LOCAL'
3935       include 'COMMON.IOUNITS'
3936       common /calcthet/ term1,term2,termm,diffak,ratak,
3937      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3938      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3939 C Calculate the contributions to both Gaussian lobes.
3940 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3941 C The "polynomial part" of the "standard deviation" of this part of
3942 C the distribution.
3943         sig=polthet(3,it)
3944         do j=2,0,-1
3945           sig=sig*thet_pred_mean+polthet(j,it)
3946         enddo
3947 C Derivative of the "interior part" of the "standard deviation of the"
3948 C gamma-dependent Gaussian lobe in t_c.
3949         sigtc=3*polthet(3,it)
3950         do j=2,1,-1
3951           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3952         enddo
3953         sigtc=sig*sigtc
3954 C Set the parameters of both Gaussian lobes of the distribution.
3955 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3956         fac=sig*sig+sigc0(it)
3957         sigcsq=fac+fac
3958         sigc=1.0D0/sigcsq
3959 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3960         sigsqtc=-4.0D0*sigcsq*sigtc
3961 c       print *,i,sig,sigtc,sigsqtc
3962 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3963         sigtc=-sigtc/(fac*fac)
3964 C Following variable is sigma(t_c)**(-2)
3965         sigcsq=sigcsq*sigcsq
3966         sig0i=sig0(it)
3967         sig0inv=1.0D0/sig0i**2
3968         delthec=thetai-thet_pred_mean
3969         delthe0=thetai-theta0i
3970         term1=-0.5D0*sigcsq*delthec*delthec
3971         term2=-0.5D0*sig0inv*delthe0*delthe0
3972 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3973 C NaNs in taking the logarithm. We extract the largest exponent which is added
3974 C to the energy (this being the log of the distribution) at the end of energy
3975 C term evaluation for this virtual-bond angle.
3976         if (term1.gt.term2) then
3977           termm=term1
3978           term2=dexp(term2-termm)
3979           term1=1.0d0
3980         else
3981           termm=term2
3982           term1=dexp(term1-termm)
3983           term2=1.0d0
3984         endif
3985 C The ratio between the gamma-independent and gamma-dependent lobes of
3986 C the distribution is a Gaussian function of thet_pred_mean too.
3987         diffak=gthet(2,it)-thet_pred_mean
3988         ratak=diffak/gthet(3,it)**2
3989         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3990 C Let's differentiate it in thet_pred_mean NOW.
3991         aktc=ak*ratak
3992 C Now put together the distribution terms to make complete distribution.
3993         termexp=term1+ak*term2
3994         termpre=sigc+ak*sig0i
3995 C Contribution of the bending energy from this theta is just the -log of
3996 C the sum of the contributions from the two lobes and the pre-exponential
3997 C factor. Simple enough, isn't it?
3998         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3999 C NOW the derivatives!!!
4000 C 6/6/97 Take into account the deformation.
4001         E_theta=(delthec*sigcsq*term1
4002      &       +ak*delthe0*sig0inv*term2)/termexp
4003         E_tc=((sigtc+aktc*sig0i)/termpre
4004      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4005      &       aktc*term2)/termexp)
4006       return
4007       end
4008 c-----------------------------------------------------------------------------
4009       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4010       implicit real*8 (a-h,o-z)
4011       include 'DIMENSIONS'
4012       include 'COMMON.LOCAL'
4013       include 'COMMON.IOUNITS'
4014       common /calcthet/ term1,term2,termm,diffak,ratak,
4015      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4016      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4017       delthec=thetai-thet_pred_mean
4018       delthe0=thetai-theta0i
4019 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4020       t3 = thetai-thet_pred_mean
4021       t6 = t3**2
4022       t9 = term1
4023       t12 = t3*sigcsq
4024       t14 = t12+t6*sigsqtc
4025       t16 = 1.0d0
4026       t21 = thetai-theta0i
4027       t23 = t21**2
4028       t26 = term2
4029       t27 = t21*t26
4030       t32 = termexp
4031       t40 = t32**2
4032       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4033      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4034      & *(-t12*t9-ak*sig0inv*t27)
4035       return
4036       end
4037 #else
4038 C--------------------------------------------------------------------------
4039       subroutine ebend(etheta)
4040 C
4041 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4042 C angles gamma and its derivatives in consecutive thetas and gammas.
4043 C ab initio-derived potentials from
4044 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4045 C
4046       implicit real*8 (a-h,o-z)
4047       include 'DIMENSIONS'
4048       include 'COMMON.LOCAL'
4049       include 'COMMON.GEO'
4050       include 'COMMON.INTERACT'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.VAR'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.IOUNITS'
4055       include 'COMMON.NAMES'
4056       include 'COMMON.FFIELD'
4057       include 'COMMON.CONTROL'
4058       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4059      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4060      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4061      & sinph1ph2(maxdouble,maxdouble)
4062       logical lprn /.false./, lprn1 /.false./
4063       etheta=0.0D0
4064       do i=ithet_start,ithet_end
4065         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4066      &    (itype(i).eq.ntyp1)) cycle
4067         dethetai=0.0d0
4068         dephii=0.0d0
4069         dephii1=0.0d0
4070         theti2=0.5d0*theta(i)
4071         ityp2=ithetyp(itype(i-1))
4072         do k=1,nntheterm
4073           coskt(k)=dcos(k*theti2)
4074           sinkt(k)=dsin(k*theti2)
4075         enddo
4076         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4077 #ifdef OSF
4078           phii=phi(i)
4079           if (phii.ne.phii) phii=150.0
4080 #else
4081           phii=phi(i)
4082 #endif
4083           ityp1=ithetyp(itype(i-2))
4084           do k=1,nsingle
4085             cosph1(k)=dcos(k*phii)
4086             sinph1(k)=dsin(k*phii)
4087           enddo
4088         else
4089           phii=0.0d0
4090           ityp1=ithetyp(itype(i-2))
4091           do k=1,nsingle
4092             cosph1(k)=0.0d0
4093             sinph1(k)=0.0d0
4094           enddo
4095         endif
4096         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4097 #ifdef OSF
4098           phii1=phi(i+1)
4099           if (phii1.ne.phii1) phii1=150.0
4100           phii1=pinorm(phii1)
4101 #else
4102           phii1=phi(i+1)
4103 #endif
4104           ityp3=ithetyp(itype(i))
4105           do k=1,nsingle
4106             cosph2(k)=dcos(k*phii1)
4107             sinph2(k)=dsin(k*phii1)
4108           enddo
4109         else
4110           phii1=0.0d0
4111           ityp3=ithetyp(itype(i))
4112           do k=1,nsingle
4113             cosph2(k)=0.0d0
4114             sinph2(k)=0.0d0
4115           enddo
4116         endif
4117 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4118 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4119 c        call flush(iout)
4120         ethetai=aa0thet(ityp1,ityp2,ityp3)
4121         do k=1,ndouble
4122           do l=1,k-1
4123             ccl=cosph1(l)*cosph2(k-l)
4124             ssl=sinph1(l)*sinph2(k-l)
4125             scl=sinph1(l)*cosph2(k-l)
4126             csl=cosph1(l)*sinph2(k-l)
4127             cosph1ph2(l,k)=ccl-ssl
4128             cosph1ph2(k,l)=ccl+ssl
4129             sinph1ph2(l,k)=scl+csl
4130             sinph1ph2(k,l)=scl-csl
4131           enddo
4132         enddo
4133         if (lprn) then
4134         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4135      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4136         write (iout,*) "coskt and sinkt"
4137         do k=1,nntheterm
4138           write (iout,*) k,coskt(k),sinkt(k)
4139         enddo
4140         endif
4141         do k=1,ntheterm
4142           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4143           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4144      &      *coskt(k)
4145           if (lprn)
4146      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4147      &     " ethetai",ethetai
4148         enddo
4149         if (lprn) then
4150         write (iout,*) "cosph and sinph"
4151         do k=1,nsingle
4152           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4153         enddo
4154         write (iout,*) "cosph1ph2 and sinph2ph2"
4155         do k=2,ndouble
4156           do l=1,k-1
4157             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4158      &         sinph1ph2(l,k),sinph1ph2(k,l)
4159           enddo
4160         enddo
4161         write(iout,*) "ethetai",ethetai
4162         endif
4163         do m=1,ntheterm2
4164           do k=1,nsingle
4165             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4166      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4167      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4168      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4169             ethetai=ethetai+sinkt(m)*aux
4170             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4171             dephii=dephii+k*sinkt(m)*(
4172      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4173      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4174             dephii1=dephii1+k*sinkt(m)*(
4175      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4176      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4177             if (lprn)
4178      &      write (iout,*) "m",m," k",k," bbthet",
4179      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4180      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4181      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4182      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4183           enddo
4184         enddo
4185         if (lprn)
4186      &  write(iout,*) "ethetai",ethetai
4187         do m=1,ntheterm3
4188           do k=2,ndouble
4189             do l=1,k-1
4190               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4191      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4192      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4193      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4194               ethetai=ethetai+sinkt(m)*aux
4195               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4196               dephii=dephii+l*sinkt(m)*(
4197      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4198      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4199      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4200      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4201               dephii1=dephii1+(k-l)*sinkt(m)*(
4202      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4203      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4204      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4205      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4206               if (lprn) then
4207               write (iout,*) "m",m," k",k," l",l," ffthet",
4208      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4209      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4210      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4211      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4212               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4213      &            cosph1ph2(k,l)*sinkt(m),
4214      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4215               endif
4216             enddo
4217           enddo
4218         enddo
4219 10      continue
4220 c        lprn1=.true.
4221         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4222      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4223      &   phii1*rad2deg,ethetai
4224 c        lprn1=.false.
4225         etheta=etheta+ethetai
4226
4227         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4228         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4229         gloc(nphi+i-2,icg)=wang*dethetai
4230       enddo
4231       return
4232       end
4233 #endif
4234 #ifdef CRYST_SC
4235 c-----------------------------------------------------------------------------
4236       subroutine esc(escloc)
4237 C Calculate the local energy of a side chain and its derivatives in the
4238 C corresponding virtual-bond valence angles THETA and the spherical angles
4239 C ALPHA and OMEGA.
4240       implicit real*8 (a-h,o-z)
4241       include 'DIMENSIONS'
4242       include 'sizesclu.dat'
4243       include 'COMMON.GEO'
4244       include 'COMMON.LOCAL'
4245       include 'COMMON.VAR'
4246       include 'COMMON.INTERACT'
4247       include 'COMMON.DERIV'
4248       include 'COMMON.CHAIN'
4249       include 'COMMON.IOUNITS'
4250       include 'COMMON.NAMES'
4251       include 'COMMON.FFIELD'
4252       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4253      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4254       common /sccalc/ time11,time12,time112,theti,it,nlobit
4255       delta=0.02d0*pi
4256       escloc=0.0D0
4257 c     write (iout,'(a)') 'ESC'
4258       do i=loc_start,loc_end
4259         it=itype(i)
4260         if (it.eq.10) goto 1
4261         nlobit=nlob(it)
4262 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4263 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4264         theti=theta(i+1)-pipol
4265         x(1)=dtan(theti)
4266         x(2)=alph(i)
4267         x(3)=omeg(i)
4268 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4269
4270         if (x(2).gt.pi-delta) then
4271           xtemp(1)=x(1)
4272           xtemp(2)=pi-delta
4273           xtemp(3)=x(3)
4274           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4275           xtemp(2)=pi
4276           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4277           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4278      &        escloci,dersc(2))
4279           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4280      &        ddersc0(1),dersc(1))
4281           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4282      &        ddersc0(3),dersc(3))
4283           xtemp(2)=pi-delta
4284           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4285           xtemp(2)=pi
4286           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4287           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4288      &            dersc0(2),esclocbi,dersc02)
4289           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4290      &            dersc12,dersc01)
4291           call splinthet(x(2),0.5d0*delta,ss,ssd)
4292           dersc0(1)=dersc01
4293           dersc0(2)=dersc02
4294           dersc0(3)=0.0d0
4295           do k=1,3
4296             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4297           enddo
4298           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4299 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4300 c    &             esclocbi,ss,ssd
4301           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4302 c         escloci=esclocbi
4303 c         write (iout,*) escloci
4304         else if (x(2).lt.delta) then
4305           xtemp(1)=x(1)
4306           xtemp(2)=delta
4307           xtemp(3)=x(3)
4308           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4309           xtemp(2)=0.0d0
4310           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4311           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4312      &        escloci,dersc(2))
4313           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4314      &        ddersc0(1),dersc(1))
4315           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4316      &        ddersc0(3),dersc(3))
4317           xtemp(2)=delta
4318           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4319           xtemp(2)=0.0d0
4320           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4321           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4322      &            dersc0(2),esclocbi,dersc02)
4323           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4324      &            dersc12,dersc01)
4325           dersc0(1)=dersc01
4326           dersc0(2)=dersc02
4327           dersc0(3)=0.0d0
4328           call splinthet(x(2),0.5d0*delta,ss,ssd)
4329           do k=1,3
4330             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4331           enddo
4332           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4333 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4334 c    &             esclocbi,ss,ssd
4335           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4336 c         write (iout,*) escloci
4337         else
4338           call enesc(x,escloci,dersc,ddummy,.false.)
4339         endif
4340
4341         escloc=escloc+escloci
4342 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4343
4344         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4345      &   wscloc*dersc(1)
4346         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4347         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4348     1   continue
4349       enddo
4350       return
4351       end
4352 C---------------------------------------------------------------------------
4353       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4354       implicit real*8 (a-h,o-z)
4355       include 'DIMENSIONS'
4356       include 'COMMON.GEO'
4357       include 'COMMON.LOCAL'
4358       include 'COMMON.IOUNITS'
4359       common /sccalc/ time11,time12,time112,theti,it,nlobit
4360       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4361       double precision contr(maxlob,-1:1)
4362       logical mixed
4363 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4364         escloc_i=0.0D0
4365         do j=1,3
4366           dersc(j)=0.0D0
4367           if (mixed) ddersc(j)=0.0d0
4368         enddo
4369         x3=x(3)
4370
4371 C Because of periodicity of the dependence of the SC energy in omega we have
4372 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4373 C To avoid underflows, first compute & store the exponents.
4374
4375         do iii=-1,1
4376
4377           x(3)=x3+iii*dwapi
4378
4379           do j=1,nlobit
4380             do k=1,3
4381               z(k)=x(k)-censc(k,j,it)
4382             enddo
4383             do k=1,3
4384               Axk=0.0D0
4385               do l=1,3
4386                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4387               enddo
4388               Ax(k,j,iii)=Axk
4389             enddo
4390             expfac=0.0D0
4391             do k=1,3
4392               expfac=expfac+Ax(k,j,iii)*z(k)
4393             enddo
4394             contr(j,iii)=expfac
4395           enddo ! j
4396
4397         enddo ! iii
4398
4399         x(3)=x3
4400 C As in the case of ebend, we want to avoid underflows in exponentiation and
4401 C subsequent NaNs and INFs in energy calculation.
4402 C Find the largest exponent
4403         emin=contr(1,-1)
4404         do iii=-1,1
4405           do j=1,nlobit
4406             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4407           enddo
4408         enddo
4409         emin=0.5D0*emin
4410 cd      print *,'it=',it,' emin=',emin
4411
4412 C Compute the contribution to SC energy and derivatives
4413         do iii=-1,1
4414
4415           do j=1,nlobit
4416             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4417 cd          print *,'j=',j,' expfac=',expfac
4418             escloc_i=escloc_i+expfac
4419             do k=1,3
4420               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4421             enddo
4422             if (mixed) then
4423               do k=1,3,2
4424                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4425      &            +gaussc(k,2,j,it))*expfac
4426               enddo
4427             endif
4428           enddo
4429
4430         enddo ! iii
4431
4432         dersc(1)=dersc(1)/cos(theti)**2
4433         ddersc(1)=ddersc(1)/cos(theti)**2
4434         ddersc(3)=ddersc(3)
4435
4436         escloci=-(dlog(escloc_i)-emin)
4437         do j=1,3
4438           dersc(j)=dersc(j)/escloc_i
4439         enddo
4440         if (mixed) then
4441           do j=1,3,2
4442             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4443           enddo
4444         endif
4445       return
4446       end
4447 C------------------------------------------------------------------------------
4448       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4449       implicit real*8 (a-h,o-z)
4450       include 'DIMENSIONS'
4451       include 'COMMON.GEO'
4452       include 'COMMON.LOCAL'
4453       include 'COMMON.IOUNITS'
4454       common /sccalc/ time11,time12,time112,theti,it,nlobit
4455       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4456       double precision contr(maxlob)
4457       logical mixed
4458
4459       escloc_i=0.0D0
4460
4461       do j=1,3
4462         dersc(j)=0.0D0
4463       enddo
4464
4465       do j=1,nlobit
4466         do k=1,2
4467           z(k)=x(k)-censc(k,j,it)
4468         enddo
4469         z(3)=dwapi
4470         do k=1,3
4471           Axk=0.0D0
4472           do l=1,3
4473             Axk=Axk+gaussc(l,k,j,it)*z(l)
4474           enddo
4475           Ax(k,j)=Axk
4476         enddo
4477         expfac=0.0D0
4478         do k=1,3
4479           expfac=expfac+Ax(k,j)*z(k)
4480         enddo
4481         contr(j)=expfac
4482       enddo ! j
4483
4484 C As in the case of ebend, we want to avoid underflows in exponentiation and
4485 C subsequent NaNs and INFs in energy calculation.
4486 C Find the largest exponent
4487       emin=contr(1)
4488       do j=1,nlobit
4489         if (emin.gt.contr(j)) emin=contr(j)
4490       enddo
4491       emin=0.5D0*emin
4492
4493 C Compute the contribution to SC energy and derivatives
4494
4495       dersc12=0.0d0
4496       do j=1,nlobit
4497         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4498         escloc_i=escloc_i+expfac
4499         do k=1,2
4500           dersc(k)=dersc(k)+Ax(k,j)*expfac
4501         enddo
4502         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4503      &            +gaussc(1,2,j,it))*expfac
4504         dersc(3)=0.0d0
4505       enddo
4506
4507       dersc(1)=dersc(1)/cos(theti)**2
4508       dersc12=dersc12/cos(theti)**2
4509       escloci=-(dlog(escloc_i)-emin)
4510       do j=1,2
4511         dersc(j)=dersc(j)/escloc_i
4512       enddo
4513       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4514       return
4515       end
4516 #else
4517 c----------------------------------------------------------------------------------
4518       subroutine esc(escloc)
4519 C Calculate the local energy of a side chain and its derivatives in the
4520 C corresponding virtual-bond valence angles THETA and the spherical angles
4521 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4522 C added by Urszula Kozlowska. 07/11/2007
4523 C
4524       implicit real*8 (a-h,o-z)
4525       include 'DIMENSIONS'
4526       include 'COMMON.GEO'
4527       include 'COMMON.LOCAL'
4528       include 'COMMON.VAR'
4529       include 'COMMON.SCROT'
4530       include 'COMMON.INTERACT'
4531       include 'COMMON.DERIV'
4532       include 'COMMON.CHAIN'
4533       include 'COMMON.IOUNITS'
4534       include 'COMMON.NAMES'
4535       include 'COMMON.FFIELD'
4536       include 'COMMON.CONTROL'
4537       include 'COMMON.VECTORS'
4538       double precision x_prime(3),y_prime(3),z_prime(3)
4539      &    , sumene,dsc_i,dp2_i,x(65),
4540      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4541      &    de_dxx,de_dyy,de_dzz,de_dt
4542       double precision s1_t,s1_6_t,s2_t,s2_6_t
4543       double precision
4544      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4545      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4546      & dt_dCi(3),dt_dCi1(3)
4547       common /sccalc/ time11,time12,time112,theti,it,nlobit
4548       delta=0.02d0*pi
4549       escloc=0.0D0
4550       do i=loc_start,loc_end
4551         costtab(i+1) =dcos(theta(i+1))
4552         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4553         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4554         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4555         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4556         cosfac=dsqrt(cosfac2)
4557         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4558         sinfac=dsqrt(sinfac2)
4559         it=itype(i)
4560         if (it.eq.10) goto 1
4561 c
4562 C  Compute the axes of tghe local cartesian coordinates system; store in
4563 c   x_prime, y_prime and z_prime
4564 c
4565         do j=1,3
4566           x_prime(j) = 0.00
4567           y_prime(j) = 0.00
4568           z_prime(j) = 0.00
4569         enddo
4570 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4571 C     &   dc_norm(3,i+nres)
4572         do j = 1,3
4573           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4574           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4575         enddo
4576         do j = 1,3
4577           z_prime(j) = -uz(j,i-1)
4578         enddo
4579 c       write (2,*) "i",i
4580 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4581 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4582 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4583 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4584 c      & " xy",scalar(x_prime(1),y_prime(1)),
4585 c      & " xz",scalar(x_prime(1),z_prime(1)),
4586 c      & " yy",scalar(y_prime(1),y_prime(1)),
4587 c      & " yz",scalar(y_prime(1),z_prime(1)),
4588 c      & " zz",scalar(z_prime(1),z_prime(1))
4589 c
4590 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4591 C to local coordinate system. Store in xx, yy, zz.
4592 c
4593         xx=0.0d0
4594         yy=0.0d0
4595         zz=0.0d0
4596         do j = 1,3
4597           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4598           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4599           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4600         enddo
4601
4602         xxtab(i)=xx
4603         yytab(i)=yy
4604         zztab(i)=zz
4605 C
4606 C Compute the energy of the ith side cbain
4607 C
4608 c        write (2,*) "xx",xx," yy",yy," zz",zz
4609         it=itype(i)
4610         do j = 1,65
4611           x(j) = sc_parmin(j,it)
4612         enddo
4613 #ifdef CHECK_COORD
4614 Cc diagnostics - remove later
4615         xx1 = dcos(alph(2))
4616         yy1 = dsin(alph(2))*dcos(omeg(2))
4617         zz1 = -dsin(alph(2))*dsin(omeg(2))
4618         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4619      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4620      &    xx1,yy1,zz1
4621 C,"  --- ", xx_w,yy_w,zz_w
4622 c end diagnostics
4623 #endif
4624         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4625      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4626      &   + x(10)*yy*zz
4627         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4628      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4629      & + x(20)*yy*zz
4630         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4631      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4632      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4633      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4634      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4635      &  +x(40)*xx*yy*zz
4636         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4637      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4638      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4639      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4640      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4641      &  +x(60)*xx*yy*zz
4642         dsc_i   = 0.743d0+x(61)
4643         dp2_i   = 1.9d0+x(62)
4644         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4645      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4646         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4647      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4648         s1=(1+x(63))/(0.1d0 + dscp1)
4649         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4650         s2=(1+x(65))/(0.1d0 + dscp2)
4651         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4652         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4653      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4654 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4655 c     &   sumene4,
4656 c     &   dscp1,dscp2,sumene
4657 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4658         escloc = escloc + sumene
4659 c        write (2,*) "escloc",escloc
4660         if (.not. calc_grad) goto 1
4661 #ifdef DEBUG
4662 C
4663 C This section to check the numerical derivatives of the energy of ith side
4664 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4665 C #define DEBUG in the code to turn it on.
4666 C
4667         write (2,*) "sumene               =",sumene
4668         aincr=1.0d-7
4669         xxsave=xx
4670         xx=xx+aincr
4671         write (2,*) xx,yy,zz
4672         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4673         de_dxx_num=(sumenep-sumene)/aincr
4674         xx=xxsave
4675         write (2,*) "xx+ sumene from enesc=",sumenep
4676         yysave=yy
4677         yy=yy+aincr
4678         write (2,*) xx,yy,zz
4679         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4680         de_dyy_num=(sumenep-sumene)/aincr
4681         yy=yysave
4682         write (2,*) "yy+ sumene from enesc=",sumenep
4683         zzsave=zz
4684         zz=zz+aincr
4685         write (2,*) xx,yy,zz
4686         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4687         de_dzz_num=(sumenep-sumene)/aincr
4688         zz=zzsave
4689         write (2,*) "zz+ sumene from enesc=",sumenep
4690         costsave=cost2tab(i+1)
4691         sintsave=sint2tab(i+1)
4692         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4693         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4694         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4695         de_dt_num=(sumenep-sumene)/aincr
4696         write (2,*) " t+ sumene from enesc=",sumenep
4697         cost2tab(i+1)=costsave
4698         sint2tab(i+1)=sintsave
4699 C End of diagnostics section.
4700 #endif
4701 C
4702 C Compute the gradient of esc
4703 C
4704         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4705         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4706         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4707         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4708         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4709         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4710         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4711         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4712         pom1=(sumene3*sint2tab(i+1)+sumene1)
4713      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4714         pom2=(sumene4*cost2tab(i+1)+sumene2)
4715      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4716         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4717         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4718      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4719      &  +x(40)*yy*zz
4720         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4721         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4722      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4723      &  +x(60)*yy*zz
4724         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4725      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4726      &        +(pom1+pom2)*pom_dx
4727 #ifdef DEBUG
4728         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4729 #endif
4730 C
4731         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4732         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4733      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4734      &  +x(40)*xx*zz
4735         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4736         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4737      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4738      &  +x(59)*zz**2 +x(60)*xx*zz
4739         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4740      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4741      &        +(pom1-pom2)*pom_dy
4742 #ifdef DEBUG
4743         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4744 #endif
4745 C
4746         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4747      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4748      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4749      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4750      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4751      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4752      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4753      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4754 #ifdef DEBUG
4755         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4756 #endif
4757 C
4758         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4759      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4760      &  +pom1*pom_dt1+pom2*pom_dt2
4761 #ifdef DEBUG
4762         write(2,*), "de_dt = ", de_dt,de_dt_num
4763 #endif
4764 c
4765 C
4766        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4767        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4768        cosfac2xx=cosfac2*xx
4769        sinfac2yy=sinfac2*yy
4770        do k = 1,3
4771          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4772      &      vbld_inv(i+1)
4773          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4774      &      vbld_inv(i)
4775          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4776          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4777 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4778 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4779 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4780 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4781          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4782          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4783          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4784          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4785          dZZ_Ci1(k)=0.0d0
4786          dZZ_Ci(k)=0.0d0
4787          do j=1,3
4788            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4789            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4790          enddo
4791
4792          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4793          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4794          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4795 c
4796          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4797          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4798        enddo
4799
4800        do k=1,3
4801          dXX_Ctab(k,i)=dXX_Ci(k)
4802          dXX_C1tab(k,i)=dXX_Ci1(k)
4803          dYY_Ctab(k,i)=dYY_Ci(k)
4804          dYY_C1tab(k,i)=dYY_Ci1(k)
4805          dZZ_Ctab(k,i)=dZZ_Ci(k)
4806          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4807          dXX_XYZtab(k,i)=dXX_XYZ(k)
4808          dYY_XYZtab(k,i)=dYY_XYZ(k)
4809          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4810        enddo
4811
4812        do k = 1,3
4813 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4814 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4815 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4816 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4817 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4818 c     &    dt_dci(k)
4819 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4820 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4821          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4822      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4823          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4824      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4825          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4826      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4827        enddo
4828 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4829 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4830
4831 C to check gradient call subroutine check_grad
4832
4833     1 continue
4834       enddo
4835       return
4836       end
4837 #endif
4838 c------------------------------------------------------------------------------
4839       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4840 C
4841 C This procedure calculates two-body contact function g(rij) and its derivative:
4842 C
4843 C           eps0ij                                     !       x < -1
4844 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4845 C            0                                         !       x > 1
4846 C
4847 C where x=(rij-r0ij)/delta
4848 C
4849 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4850 C
4851       implicit none
4852       double precision rij,r0ij,eps0ij,fcont,fprimcont
4853       double precision x,x2,x4,delta
4854 c     delta=0.02D0*r0ij
4855 c      delta=0.2D0*r0ij
4856       x=(rij-r0ij)/delta
4857       if (x.lt.-1.0D0) then
4858         fcont=eps0ij
4859         fprimcont=0.0D0
4860       else if (x.le.1.0D0) then
4861         x2=x*x
4862         x4=x2*x2
4863         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4864         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4865       else
4866         fcont=0.0D0
4867         fprimcont=0.0D0
4868       endif
4869       return
4870       end
4871 c------------------------------------------------------------------------------
4872       subroutine splinthet(theti,delta,ss,ssder)
4873       implicit real*8 (a-h,o-z)
4874       include 'DIMENSIONS'
4875       include 'sizesclu.dat'
4876       include 'COMMON.VAR'
4877       include 'COMMON.GEO'
4878       thetup=pi-delta
4879       thetlow=delta
4880       if (theti.gt.pipol) then
4881         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4882       else
4883         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4884         ssder=-ssder
4885       endif
4886       return
4887       end
4888 c------------------------------------------------------------------------------
4889       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4890       implicit none
4891       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4892       double precision ksi,ksi2,ksi3,a1,a2,a3
4893       a1=fprim0*delta/(f1-f0)
4894       a2=3.0d0-2.0d0*a1
4895       a3=a1-2.0d0
4896       ksi=(x-x0)/delta
4897       ksi2=ksi*ksi
4898       ksi3=ksi2*ksi
4899       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4900       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4901       return
4902       end
4903 c------------------------------------------------------------------------------
4904       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4905       implicit none
4906       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4907       double precision ksi,ksi2,ksi3,a1,a2,a3
4908       ksi=(x-x0)/delta
4909       ksi2=ksi*ksi
4910       ksi3=ksi2*ksi
4911       a1=fprim0x*delta
4912       a2=3*(f1x-f0x)-2*fprim0x*delta
4913       a3=fprim0x*delta-2*(f1x-f0x)
4914       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4915       return
4916       end
4917 C-----------------------------------------------------------------------------
4918 #ifdef CRYST_TOR
4919 C-----------------------------------------------------------------------------
4920       subroutine etor(etors,edihcnstr,fact)
4921       implicit real*8 (a-h,o-z)
4922       include 'DIMENSIONS'
4923       include 'sizesclu.dat'
4924       include 'COMMON.VAR'
4925       include 'COMMON.GEO'
4926       include 'COMMON.LOCAL'
4927       include 'COMMON.TORSION'
4928       include 'COMMON.INTERACT'
4929       include 'COMMON.DERIV'
4930       include 'COMMON.CHAIN'
4931       include 'COMMON.NAMES'
4932       include 'COMMON.IOUNITS'
4933       include 'COMMON.FFIELD'
4934       include 'COMMON.TORCNSTR'
4935       logical lprn
4936 C Set lprn=.true. for debugging
4937       lprn=.false.
4938 c      lprn=.true.
4939       etors=0.0D0
4940       do i=iphi_start,iphi_end
4941         itori=itortyp(itype(i-2))
4942         itori1=itortyp(itype(i-1))
4943         phii=phi(i)
4944         gloci=0.0D0
4945 C Proline-Proline pair is a special case...
4946         if (itori.eq.3 .and. itori1.eq.3) then
4947           if (phii.gt.-dwapi3) then
4948             cosphi=dcos(3*phii)
4949             fac=1.0D0/(1.0D0-cosphi)
4950             etorsi=v1(1,3,3)*fac
4951             etorsi=etorsi+etorsi
4952             etors=etors+etorsi-v1(1,3,3)
4953             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4954           endif
4955           do j=1,3
4956             v1ij=v1(j+1,itori,itori1)
4957             v2ij=v2(j+1,itori,itori1)
4958             cosphi=dcos(j*phii)
4959             sinphi=dsin(j*phii)
4960             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4961             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4962           enddo
4963         else
4964           do j=1,nterm_old
4965             v1ij=v1(j,itori,itori1)
4966             v2ij=v2(j,itori,itori1)
4967             cosphi=dcos(j*phii)
4968             sinphi=dsin(j*phii)
4969             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4970             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4971           enddo
4972         endif
4973         if (lprn)
4974      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4975      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4976      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4977         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4978 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4979       enddo
4980 ! 6/20/98 - dihedral angle constraints
4981       edihcnstr=0.0d0
4982       do i=1,ndih_constr
4983         itori=idih_constr(i)
4984         phii=phi(itori)
4985         difi=pinorm(phii-phi0(i))
4986         if (difi.gt.drange(i)) then
4987           difi=difi-drange(i)
4988           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4989           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4990         else if (difi.lt.-drange(i)) then
4991           difi=difi+drange(i)
4992           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4993           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4994         endif
4995 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4996 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4997       enddo
4998       write (iout,*) 'edihcnstr',edihcnstr
4999       return
5000       end
5001 c------------------------------------------------------------------------------
5002 #else
5003       subroutine etor(etors,edihcnstr,fact)
5004       implicit real*8 (a-h,o-z)
5005       include 'DIMENSIONS'
5006       include 'sizesclu.dat'
5007       include 'COMMON.VAR'
5008       include 'COMMON.GEO'
5009       include 'COMMON.LOCAL'
5010       include 'COMMON.TORSION'
5011       include 'COMMON.INTERACT'
5012       include 'COMMON.DERIV'
5013       include 'COMMON.CHAIN'
5014       include 'COMMON.NAMES'
5015       include 'COMMON.IOUNITS'
5016       include 'COMMON.FFIELD'
5017       include 'COMMON.TORCNSTR'
5018       logical lprn
5019 C Set lprn=.true. for debugging
5020       lprn=.false.
5021 c      lprn=.true.
5022       etors=0.0D0
5023       do i=iphi_start,iphi_end
5024         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5025         itori=itortyp(itype(i-2))
5026         itori1=itortyp(itype(i-1))
5027         phii=phi(i)
5028         gloci=0.0D0
5029 C Regular cosine and sine terms
5030         do j=1,nterm(itori,itori1)
5031           v1ij=v1(j,itori,itori1)
5032           v2ij=v2(j,itori,itori1)
5033           cosphi=dcos(j*phii)
5034           sinphi=dsin(j*phii)
5035           etors=etors+v1ij*cosphi+v2ij*sinphi
5036           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5037         enddo
5038 C Lorentz terms
5039 C                         v1
5040 C  E = SUM ----------------------------------- - v1
5041 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5042 C
5043         cosphi=dcos(0.5d0*phii)
5044         sinphi=dsin(0.5d0*phii)
5045         do j=1,nlor(itori,itori1)
5046           vl1ij=vlor1(j,itori,itori1)
5047           vl2ij=vlor2(j,itori,itori1)
5048           vl3ij=vlor3(j,itori,itori1)
5049           pom=vl2ij*cosphi+vl3ij*sinphi
5050           pom1=1.0d0/(pom*pom+1.0d0)
5051           etors=etors+vl1ij*pom1
5052           pom=-pom*pom1*pom1
5053           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5054         enddo
5055 C Subtract the constant term
5056         etors=etors-v0(itori,itori1)
5057         if (lprn)
5058      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5059      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5060      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5061         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5062 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5063  1215   continue
5064       enddo
5065 ! 6/20/98 - dihedral angle constraints
5066       edihcnstr=0.0d0
5067 c      write (iout,*) "Dihedral angle restraint energy"
5068       do i=1,ndih_constr
5069         itori=idih_constr(i)
5070         phii=phi(itori)
5071         difi=pinorm(phii-phi0(i))
5072 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5073 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5074         if (difi.gt.drange(i)) then
5075           difi=difi-drange(i)
5076           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5077           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5078 c          write (iout,*) 0.25d0*ftors*difi**4
5079         else if (difi.lt.-drange(i)) then
5080           difi=difi+drange(i)
5081           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5082           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5083 c          write (iout,*) 0.25d0*ftors*difi**4
5084         endif
5085       enddo
5086 c      write (iout,*) 'edihcnstr',edihcnstr
5087       return
5088       end
5089 c----------------------------------------------------------------------------
5090       subroutine etor_d(etors_d,fact2)
5091 C 6/23/01 Compute double torsional energy
5092       implicit real*8 (a-h,o-z)
5093       include 'DIMENSIONS'
5094       include 'sizesclu.dat'
5095       include 'COMMON.VAR'
5096       include 'COMMON.GEO'
5097       include 'COMMON.LOCAL'
5098       include 'COMMON.TORSION'
5099       include 'COMMON.INTERACT'
5100       include 'COMMON.DERIV'
5101       include 'COMMON.CHAIN'
5102       include 'COMMON.NAMES'
5103       include 'COMMON.IOUNITS'
5104       include 'COMMON.FFIELD'
5105       include 'COMMON.TORCNSTR'
5106       logical lprn
5107 C Set lprn=.true. for debugging
5108       lprn=.false.
5109 c     lprn=.true.
5110       etors_d=0.0D0
5111       do i=iphi_start,iphi_end-1
5112         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5113      &     goto 1215
5114         itori=itortyp(itype(i-2))
5115         itori1=itortyp(itype(i-1))
5116         itori2=itortyp(itype(i))
5117         phii=phi(i)
5118         phii1=phi(i+1)
5119         gloci1=0.0D0
5120         gloci2=0.0D0
5121 C Regular cosine and sine terms
5122         do j=1,ntermd_1(itori,itori1,itori2)
5123           v1cij=v1c(1,j,itori,itori1,itori2)
5124           v1sij=v1s(1,j,itori,itori1,itori2)
5125           v2cij=v1c(2,j,itori,itori1,itori2)
5126           v2sij=v1s(2,j,itori,itori1,itori2)
5127           cosphi1=dcos(j*phii)
5128           sinphi1=dsin(j*phii)
5129           cosphi2=dcos(j*phii1)
5130           sinphi2=dsin(j*phii1)
5131           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5132      &     v2cij*cosphi2+v2sij*sinphi2
5133           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5134           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5135         enddo
5136         do k=2,ntermd_2(itori,itori1,itori2)
5137           do l=1,k-1
5138             v1cdij = v2c(k,l,itori,itori1,itori2)
5139             v2cdij = v2c(l,k,itori,itori1,itori2)
5140             v1sdij = v2s(k,l,itori,itori1,itori2)
5141             v2sdij = v2s(l,k,itori,itori1,itori2)
5142             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5143             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5144             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5145             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5146             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5147      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5148             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5149      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5150             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5151      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5152           enddo
5153         enddo
5154         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5155         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5156  1215   continue
5157       enddo
5158       return
5159       end
5160 #endif
5161 c------------------------------------------------------------------------------
5162       subroutine eback_sc_corr(esccor,fact)
5163 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5164 c        conformational states; temporarily implemented as differences
5165 c        between UNRES torsional potentials (dependent on three types of
5166 c        residues) and the torsional potentials dependent on all 20 types
5167 c        of residues computed from AM1 energy surfaces of terminally-blocked
5168 c        amino-acid residues.
5169       implicit real*8 (a-h,o-z)
5170       include 'DIMENSIONS'
5171       include 'COMMON.VAR'
5172       include 'COMMON.GEO'
5173       include 'COMMON.LOCAL'
5174       include 'COMMON.TORSION'
5175       include 'COMMON.SCCOR'
5176       include 'COMMON.INTERACT'
5177       include 'COMMON.DERIV'
5178       include 'COMMON.CHAIN'
5179       include 'COMMON.NAMES'
5180       include 'COMMON.IOUNITS'
5181       include 'COMMON.FFIELD'
5182       include 'COMMON.CONTROL'
5183       logical lprn
5184 C Set lprn=.true. for debugging
5185       lprn=.false.
5186 c      lprn=.true.
5187 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5188       esccor=0.0D0
5189       do i=itau_start,itau_end
5190         esccor_ii=0.0D0
5191         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5192         isccori=isccortyp(itype(i-2))
5193         isccori1=isccortyp(itype(i-1))
5194         phii=phi(i)
5195 cccc  Added 9 May 2012
5196 cc Tauangle is torsional engle depending on the value of first digit
5197 c(see comment below)
5198 cc Omicron is flat angle depending on the value of first digit
5199 c(see comment below)
5200
5201
5202         do intertyp=1,3 !intertyp
5203 cc Added 09 May 2012 (Adasko)
5204 cc  Intertyp means interaction type of backbone mainchain correlation:
5205 c   1 = SC...Ca...Ca...Ca
5206 c   2 = Ca...Ca...Ca...SC
5207 c   3 = SC...Ca...Ca...SCi
5208         gloci=0.0D0
5209         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5210      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5211      &      (itype(i-1).eq.21)))
5212      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5213      &     .or.(itype(i-2).eq.21)))
5214      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5215      &      (itype(i-1).eq.21)))) cycle
5216         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5217         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5218      & cycle
5219         do j=1,nterm_sccor(isccori,isccori1)
5220           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5221           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5222           cosphi=dcos(j*tauangle(intertyp,i))
5223           sinphi=dsin(j*tauangle(intertyp,i))
5224           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5225 #ifdef DEBUG
5226           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5227 #endif
5228           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5229         enddo
5230         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5231 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5232 c     &gloc_sc(intertyp,i-3,icg)
5233         if (lprn)
5234      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5235      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5236      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5237      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5238         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5239        enddo !intertyp
5240 #ifdef DEBUG
5241        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5242 #endif
5243       enddo
5244
5245       return
5246       end
5247 c------------------------------------------------------------------------------
5248       subroutine multibody(ecorr)
5249 C This subroutine calculates multi-body contributions to energy following
5250 C the idea of Skolnick et al. If side chains I and J make a contact and
5251 C at the same time side chains I+1 and J+1 make a contact, an extra
5252 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5253       implicit real*8 (a-h,o-z)
5254       include 'DIMENSIONS'
5255       include 'COMMON.IOUNITS'
5256       include 'COMMON.DERIV'
5257       include 'COMMON.INTERACT'
5258       include 'COMMON.CONTACTS'
5259       double precision gx(3),gx1(3)
5260       logical lprn
5261
5262 C Set lprn=.true. for debugging
5263       lprn=.false.
5264
5265       if (lprn) then
5266         write (iout,'(a)') 'Contact function values:'
5267         do i=nnt,nct-2
5268           write (iout,'(i2,20(1x,i2,f10.5))')
5269      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5270         enddo
5271       endif
5272       ecorr=0.0D0
5273       do i=nnt,nct
5274         do j=1,3
5275           gradcorr(j,i)=0.0D0
5276           gradxorr(j,i)=0.0D0
5277         enddo
5278       enddo
5279       do i=nnt,nct-2
5280
5281         DO ISHIFT = 3,4
5282
5283         i1=i+ishift
5284         num_conti=num_cont(i)
5285         num_conti1=num_cont(i1)
5286         do jj=1,num_conti
5287           j=jcont(jj,i)
5288           do kk=1,num_conti1
5289             j1=jcont(kk,i1)
5290             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5291 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5292 cd   &                   ' ishift=',ishift
5293 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5294 C The system gains extra energy.
5295               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5296             endif   ! j1==j+-ishift
5297           enddo     ! kk
5298         enddo       ! jj
5299
5300         ENDDO ! ISHIFT
5301
5302       enddo         ! i
5303       return
5304       end
5305 c------------------------------------------------------------------------------
5306       double precision function esccorr(i,j,k,l,jj,kk)
5307       implicit real*8 (a-h,o-z)
5308       include 'DIMENSIONS'
5309       include 'COMMON.IOUNITS'
5310       include 'COMMON.DERIV'
5311       include 'COMMON.INTERACT'
5312       include 'COMMON.CONTACTS'
5313       double precision gx(3),gx1(3)
5314       logical lprn
5315       lprn=.false.
5316       eij=facont(jj,i)
5317       ekl=facont(kk,k)
5318 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5319 C Calculate the multi-body contribution to energy.
5320 C Calculate multi-body contributions to the gradient.
5321 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5322 cd   & k,l,(gacont(m,kk,k),m=1,3)
5323       do m=1,3
5324         gx(m) =ekl*gacont(m,jj,i)
5325         gx1(m)=eij*gacont(m,kk,k)
5326         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5327         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5328         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5329         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5330       enddo
5331       do m=i,j-1
5332         do ll=1,3
5333           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5334         enddo
5335       enddo
5336       do m=k,l-1
5337         do ll=1,3
5338           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5339         enddo
5340       enddo
5341       esccorr=-eij*ekl
5342       return
5343       end
5344 c------------------------------------------------------------------------------
5345 #ifdef MPL
5346       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5347       implicit real*8 (a-h,o-z)
5348       include 'DIMENSIONS'
5349       integer dimen1,dimen2,atom,indx
5350       double precision buffer(dimen1,dimen2)
5351       double precision zapas
5352       common /contacts_hb/ zapas(3,20,maxres,7),
5353      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5354      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5355       num_kont=num_cont_hb(atom)
5356       do i=1,num_kont
5357         do k=1,7
5358           do j=1,3
5359             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5360           enddo ! j
5361         enddo ! k
5362         buffer(i,indx+22)=facont_hb(i,atom)
5363         buffer(i,indx+23)=ees0p(i,atom)
5364         buffer(i,indx+24)=ees0m(i,atom)
5365         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5366       enddo ! i
5367       buffer(1,indx+26)=dfloat(num_kont)
5368       return
5369       end
5370 c------------------------------------------------------------------------------
5371       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5372       implicit real*8 (a-h,o-z)
5373       include 'DIMENSIONS'
5374       integer dimen1,dimen2,atom,indx
5375       double precision buffer(dimen1,dimen2)
5376       double precision zapas
5377       common /contacts_hb/ zapas(3,20,maxres,7),
5378      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5379      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5380       num_kont=buffer(1,indx+26)
5381       num_kont_old=num_cont_hb(atom)
5382       num_cont_hb(atom)=num_kont+num_kont_old
5383       do i=1,num_kont
5384         ii=i+num_kont_old
5385         do k=1,7
5386           do j=1,3
5387             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5388           enddo ! j
5389         enddo ! k
5390         facont_hb(ii,atom)=buffer(i,indx+22)
5391         ees0p(ii,atom)=buffer(i,indx+23)
5392         ees0m(ii,atom)=buffer(i,indx+24)
5393         jcont_hb(ii,atom)=buffer(i,indx+25)
5394       enddo ! i
5395       return
5396       end
5397 c------------------------------------------------------------------------------
5398 #endif
5399       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5400 C This subroutine calculates multi-body contributions to hydrogen-bonding
5401       implicit real*8 (a-h,o-z)
5402       include 'DIMENSIONS'
5403       include 'sizesclu.dat'
5404       include 'COMMON.IOUNITS'
5405 #ifdef MPL
5406       include 'COMMON.INFO'
5407 #endif
5408       include 'COMMON.FFIELD'
5409       include 'COMMON.DERIV'
5410       include 'COMMON.INTERACT'
5411       include 'COMMON.CONTACTS'
5412 #ifdef MPL
5413       parameter (max_cont=maxconts)
5414       parameter (max_dim=2*(8*3+2))
5415       parameter (msglen1=max_cont*max_dim*4)
5416       parameter (msglen2=2*msglen1)
5417       integer source,CorrelType,CorrelID,Error
5418       double precision buffer(max_cont,max_dim)
5419 #endif
5420       double precision gx(3),gx1(3)
5421       logical lprn,ldone
5422
5423 C Set lprn=.true. for debugging
5424       lprn=.false.
5425 #ifdef MPL
5426       n_corr=0
5427       n_corr1=0
5428       if (fgProcs.le.1) goto 30
5429       if (lprn) then
5430         write (iout,'(a)') 'Contact function values:'
5431         do i=nnt,nct-2
5432           write (iout,'(2i3,50(1x,i2,f5.2))')
5433      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5434      &    j=1,num_cont_hb(i))
5435         enddo
5436       endif
5437 C Caution! Following code assumes that electrostatic interactions concerning
5438 C a given atom are split among at most two processors!
5439       CorrelType=477
5440       CorrelID=MyID+1
5441       ldone=.false.
5442       do i=1,max_cont
5443         do j=1,max_dim
5444           buffer(i,j)=0.0D0
5445         enddo
5446       enddo
5447       mm=mod(MyRank,2)
5448 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5449       if (mm) 20,20,10
5450    10 continue
5451 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5452       if (MyRank.gt.0) then
5453 C Send correlation contributions to the preceding processor
5454         msglen=msglen1
5455         nn=num_cont_hb(iatel_s)
5456         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5457 cd      write (iout,*) 'The BUFFER array:'
5458 cd      do i=1,nn
5459 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5460 cd      enddo
5461         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5462           msglen=msglen2
5463             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5464 C Clear the contacts of the atom passed to the neighboring processor
5465         nn=num_cont_hb(iatel_s+1)
5466 cd      do i=1,nn
5467 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5468 cd      enddo
5469             num_cont_hb(iatel_s)=0
5470         endif
5471 cd      write (iout,*) 'Processor ',MyID,MyRank,
5472 cd   & ' is sending correlation contribution to processor',MyID-1,
5473 cd   & ' msglen=',msglen
5474 cd      write (*,*) 'Processor ',MyID,MyRank,
5475 cd   & ' is sending correlation contribution to processor',MyID-1,
5476 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5477         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5478 cd      write (iout,*) 'Processor ',MyID,
5479 cd   & ' has sent correlation contribution to processor',MyID-1,
5480 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5481 cd      write (*,*) 'Processor ',MyID,
5482 cd   & ' has sent correlation contribution to processor',MyID-1,
5483 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5484         msglen=msglen1
5485       endif ! (MyRank.gt.0)
5486       if (ldone) goto 30
5487       ldone=.true.
5488    20 continue
5489 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5490       if (MyRank.lt.fgProcs-1) then
5491 C Receive correlation contributions from the next processor
5492         msglen=msglen1
5493         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5494 cd      write (iout,*) 'Processor',MyID,
5495 cd   & ' is receiving correlation contribution from processor',MyID+1,
5496 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5497 cd      write (*,*) 'Processor',MyID,
5498 cd   & ' is receiving correlation contribution from processor',MyID+1,
5499 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5500         nbytes=-1
5501         do while (nbytes.le.0)
5502           call mp_probe(MyID+1,CorrelType,nbytes)
5503         enddo
5504 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5505         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5506 cd      write (iout,*) 'Processor',MyID,
5507 cd   & ' has received correlation contribution from processor',MyID+1,
5508 cd   & ' msglen=',msglen,' nbytes=',nbytes
5509 cd      write (iout,*) 'The received BUFFER array:'
5510 cd      do i=1,max_cont
5511 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5512 cd      enddo
5513         if (msglen.eq.msglen1) then
5514           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5515         else if (msglen.eq.msglen2)  then
5516           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5517           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5518         else
5519           write (iout,*)
5520      & 'ERROR!!!! message length changed while processing correlations.'
5521           write (*,*)
5522      & 'ERROR!!!! message length changed while processing correlations.'
5523           call mp_stopall(Error)
5524         endif ! msglen.eq.msglen1
5525       endif ! MyRank.lt.fgProcs-1
5526       if (ldone) goto 30
5527       ldone=.true.
5528       goto 10
5529    30 continue
5530 #endif
5531       if (lprn) then
5532         write (iout,'(a)') 'Contact function values:'
5533         do i=nnt,nct-2
5534           write (iout,'(2i3,50(1x,i2,f5.2))')
5535      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5536      &    j=1,num_cont_hb(i))
5537         enddo
5538       endif
5539       ecorr=0.0D0
5540 C Remove the loop below after debugging !!!
5541       do i=nnt,nct
5542         do j=1,3
5543           gradcorr(j,i)=0.0D0
5544           gradxorr(j,i)=0.0D0
5545         enddo
5546       enddo
5547 C Calculate the local-electrostatic correlation terms
5548       do i=iatel_s,iatel_e+1
5549         i1=i+1
5550         num_conti=num_cont_hb(i)
5551         num_conti1=num_cont_hb(i+1)
5552         do jj=1,num_conti
5553           j=jcont_hb(jj,i)
5554           do kk=1,num_conti1
5555             j1=jcont_hb(kk,i1)
5556 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5557 c     &         ' jj=',jj,' kk=',kk
5558             if (j1.eq.j+1 .or. j1.eq.j-1) then
5559 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5560 C The system gains extra energy.
5561               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5562               n_corr=n_corr+1
5563             else if (j1.eq.j) then
5564 C Contacts I-J and I-(J+1) occur simultaneously.
5565 C The system loses extra energy.
5566 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5567             endif
5568           enddo ! kk
5569           do kk=1,num_conti
5570             j1=jcont_hb(kk,i)
5571 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5572 c    &         ' jj=',jj,' kk=',kk
5573             if (j1.eq.j+1) then
5574 C Contacts I-J and (I+1)-J occur simultaneously.
5575 C The system loses extra energy.
5576 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5577             endif ! j1==j+1
5578           enddo ! kk
5579         enddo ! jj
5580       enddo ! i
5581       return
5582       end
5583 c------------------------------------------------------------------------------
5584       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5585      &  n_corr1)
5586 C This subroutine calculates multi-body contributions to hydrogen-bonding
5587       implicit real*8 (a-h,o-z)
5588       include 'DIMENSIONS'
5589       include 'sizesclu.dat'
5590       include 'COMMON.IOUNITS'
5591 #ifdef MPL
5592       include 'COMMON.INFO'
5593 #endif
5594       include 'COMMON.FFIELD'
5595       include 'COMMON.DERIV'
5596       include 'COMMON.INTERACT'
5597       include 'COMMON.CONTACTS'
5598 #ifdef MPL
5599       parameter (max_cont=maxconts)
5600       parameter (max_dim=2*(8*3+2))
5601       parameter (msglen1=max_cont*max_dim*4)
5602       parameter (msglen2=2*msglen1)
5603       integer source,CorrelType,CorrelID,Error
5604       double precision buffer(max_cont,max_dim)
5605 #endif
5606       double precision gx(3),gx1(3)
5607       logical lprn,ldone
5608
5609 C Set lprn=.true. for debugging
5610       lprn=.false.
5611       eturn6=0.0d0
5612       ecorr6=0.0d0
5613 #ifdef MPL
5614       n_corr=0
5615       n_corr1=0
5616       if (fgProcs.le.1) goto 30
5617       if (lprn) then
5618         write (iout,'(a)') 'Contact function values:'
5619         do i=nnt,nct-2
5620           write (iout,'(2i3,50(1x,i2,f5.2))')
5621      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5622      &    j=1,num_cont_hb(i))
5623         enddo
5624       endif
5625 C Caution! Following code assumes that electrostatic interactions concerning
5626 C a given atom are split among at most two processors!
5627       CorrelType=477
5628       CorrelID=MyID+1
5629       ldone=.false.
5630       do i=1,max_cont
5631         do j=1,max_dim
5632           buffer(i,j)=0.0D0
5633         enddo
5634       enddo
5635       mm=mod(MyRank,2)
5636 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5637       if (mm) 20,20,10
5638    10 continue
5639 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5640       if (MyRank.gt.0) then
5641 C Send correlation contributions to the preceding processor
5642         msglen=msglen1
5643         nn=num_cont_hb(iatel_s)
5644         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5645 cd      write (iout,*) 'The BUFFER array:'
5646 cd      do i=1,nn
5647 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5648 cd      enddo
5649         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5650           msglen=msglen2
5651             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5652 C Clear the contacts of the atom passed to the neighboring processor
5653         nn=num_cont_hb(iatel_s+1)
5654 cd      do i=1,nn
5655 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5656 cd      enddo
5657             num_cont_hb(iatel_s)=0
5658         endif
5659 cd      write (iout,*) 'Processor ',MyID,MyRank,
5660 cd   & ' is sending correlation contribution to processor',MyID-1,
5661 cd   & ' msglen=',msglen
5662 cd      write (*,*) 'Processor ',MyID,MyRank,
5663 cd   & ' is sending correlation contribution to processor',MyID-1,
5664 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5665         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5666 cd      write (iout,*) 'Processor ',MyID,
5667 cd   & ' has sent correlation contribution to processor',MyID-1,
5668 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5669 cd      write (*,*) 'Processor ',MyID,
5670 cd   & ' has sent correlation contribution to processor',MyID-1,
5671 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5672         msglen=msglen1
5673       endif ! (MyRank.gt.0)
5674       if (ldone) goto 30
5675       ldone=.true.
5676    20 continue
5677 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5678       if (MyRank.lt.fgProcs-1) then
5679 C Receive correlation contributions from the next processor
5680         msglen=msglen1
5681         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5682 cd      write (iout,*) 'Processor',MyID,
5683 cd   & ' is receiving correlation contribution from processor',MyID+1,
5684 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5685 cd      write (*,*) 'Processor',MyID,
5686 cd   & ' is receiving correlation contribution from processor',MyID+1,
5687 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5688         nbytes=-1
5689         do while (nbytes.le.0)
5690           call mp_probe(MyID+1,CorrelType,nbytes)
5691         enddo
5692 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5693         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5694 cd      write (iout,*) 'Processor',MyID,
5695 cd   & ' has received correlation contribution from processor',MyID+1,
5696 cd   & ' msglen=',msglen,' nbytes=',nbytes
5697 cd      write (iout,*) 'The received BUFFER array:'
5698 cd      do i=1,max_cont
5699 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5700 cd      enddo
5701         if (msglen.eq.msglen1) then
5702           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5703         else if (msglen.eq.msglen2)  then
5704           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5705           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5706         else
5707           write (iout,*)
5708      & 'ERROR!!!! message length changed while processing correlations.'
5709           write (*,*)
5710      & 'ERROR!!!! message length changed while processing correlations.'
5711           call mp_stopall(Error)
5712         endif ! msglen.eq.msglen1
5713       endif ! MyRank.lt.fgProcs-1
5714       if (ldone) goto 30
5715       ldone=.true.
5716       goto 10
5717    30 continue
5718 #endif
5719       if (lprn) then
5720         write (iout,'(a)') 'Contact function values:'
5721         do i=nnt,nct-2
5722           write (iout,'(2i3,50(1x,i2,f5.2))')
5723      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5724      &    j=1,num_cont_hb(i))
5725         enddo
5726       endif
5727       ecorr=0.0D0
5728       ecorr5=0.0d0
5729       ecorr6=0.0d0
5730 C Remove the loop below after debugging !!!
5731       do i=nnt,nct
5732         do j=1,3
5733           gradcorr(j,i)=0.0D0
5734           gradxorr(j,i)=0.0D0
5735         enddo
5736       enddo
5737 C Calculate the dipole-dipole interaction energies
5738       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5739       do i=iatel_s,iatel_e+1
5740         num_conti=num_cont_hb(i)
5741         do jj=1,num_conti
5742           j=jcont_hb(jj,i)
5743           call dipole(i,j,jj)
5744         enddo
5745       enddo
5746       endif
5747 C Calculate the local-electrostatic correlation terms
5748       do i=iatel_s,iatel_e+1
5749         i1=i+1
5750         num_conti=num_cont_hb(i)
5751         num_conti1=num_cont_hb(i+1)
5752         do jj=1,num_conti
5753           j=jcont_hb(jj,i)
5754           do kk=1,num_conti1
5755             j1=jcont_hb(kk,i1)
5756 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5757 c     &         ' jj=',jj,' kk=',kk
5758             if (j1.eq.j+1 .or. j1.eq.j-1) then
5759 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5760 C The system gains extra energy.
5761               n_corr=n_corr+1
5762               sqd1=dsqrt(d_cont(jj,i))
5763               sqd2=dsqrt(d_cont(kk,i1))
5764               sred_geom = sqd1*sqd2
5765               IF (sred_geom.lt.cutoff_corr) THEN
5766                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5767      &            ekont,fprimcont)
5768 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5769 c     &         ' jj=',jj,' kk=',kk
5770                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5771                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5772                 do l=1,3
5773                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5774                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5775                 enddo
5776                 n_corr1=n_corr1+1
5777 cd               write (iout,*) 'sred_geom=',sred_geom,
5778 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5779                 call calc_eello(i,j,i+1,j1,jj,kk)
5780                 if (wcorr4.gt.0.0d0)
5781      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5782                 if (wcorr5.gt.0.0d0)
5783      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5784 c                print *,"wcorr5",ecorr5
5785 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5786 cd                write(2,*)'ijkl',i,j,i+1,j1
5787                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5788      &               .or. wturn6.eq.0.0d0))then
5789 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5790 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5791 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5792 c     &            'ecorr6=',ecorr6, wcorr6
5793 cd                write (iout,'(4e15.5)') sred_geom,
5794 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5795 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5796 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5797                 else if (wturn6.gt.0.0d0
5798      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5799 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5800                   eturn6=eturn6+eello_turn6(i,jj,kk)
5801 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5802                 endif
5803               ENDIF
5804 1111          continue
5805             else if (j1.eq.j) then
5806 C Contacts I-J and I-(J+1) occur simultaneously.
5807 C The system loses extra energy.
5808 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5809             endif
5810           enddo ! kk
5811           do kk=1,num_conti
5812             j1=jcont_hb(kk,i)
5813 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5814 c    &         ' jj=',jj,' kk=',kk
5815             if (j1.eq.j+1) then
5816 C Contacts I-J and (I+1)-J occur simultaneously.
5817 C The system loses extra energy.
5818 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5819             endif ! j1==j+1
5820           enddo ! kk
5821         enddo ! jj
5822       enddo ! i
5823       return
5824       end
5825 c------------------------------------------------------------------------------
5826       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5827       implicit real*8 (a-h,o-z)
5828       include 'DIMENSIONS'
5829       include 'COMMON.IOUNITS'
5830       include 'COMMON.DERIV'
5831       include 'COMMON.INTERACT'
5832       include 'COMMON.CONTACTS'
5833       double precision gx(3),gx1(3)
5834       logical lprn
5835       lprn=.false.
5836       eij=facont_hb(jj,i)
5837       ekl=facont_hb(kk,k)
5838       ees0pij=ees0p(jj,i)
5839       ees0pkl=ees0p(kk,k)
5840       ees0mij=ees0m(jj,i)
5841       ees0mkl=ees0m(kk,k)
5842       ekont=eij*ekl
5843       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5844 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5845 C Following 4 lines for diagnostics.
5846 cd    ees0pkl=0.0D0
5847 cd    ees0pij=1.0D0
5848 cd    ees0mkl=0.0D0
5849 cd    ees0mij=1.0D0
5850 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5851 c    &   ' and',k,l
5852 c     write (iout,*)'Contacts have occurred for peptide groups',
5853 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5854 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5855 C Calculate the multi-body contribution to energy.
5856       ecorr=ecorr+ekont*ees
5857       if (calc_grad) then
5858 C Calculate multi-body contributions to the gradient.
5859       do ll=1,3
5860         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5861         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5862      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5863      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5864         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5865      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5866      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5867         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5868         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5869      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5870      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5871         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5872      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5873      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5874       enddo
5875       do m=i+1,j-1
5876         do ll=1,3
5877           gradcorr(ll,m)=gradcorr(ll,m)+
5878      &     ees*ekl*gacont_hbr(ll,jj,i)-
5879      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5880      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5881         enddo
5882       enddo
5883       do m=k+1,l-1
5884         do ll=1,3
5885           gradcorr(ll,m)=gradcorr(ll,m)+
5886      &     ees*eij*gacont_hbr(ll,kk,k)-
5887      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5888      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5889         enddo
5890       enddo
5891       endif
5892       ehbcorr=ekont*ees
5893       return
5894       end
5895 C---------------------------------------------------------------------------
5896       subroutine dipole(i,j,jj)
5897       implicit real*8 (a-h,o-z)
5898       include 'DIMENSIONS'
5899       include 'sizesclu.dat'
5900       include 'COMMON.IOUNITS'
5901       include 'COMMON.CHAIN'
5902       include 'COMMON.FFIELD'
5903       include 'COMMON.DERIV'
5904       include 'COMMON.INTERACT'
5905       include 'COMMON.CONTACTS'
5906       include 'COMMON.TORSION'
5907       include 'COMMON.VAR'
5908       include 'COMMON.GEO'
5909       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5910      &  auxmat(2,2)
5911       iti1 = itortyp(itype(i+1))
5912       if (j.lt.nres-1) then
5913         itj1 = itortyp(itype(j+1))
5914       else
5915         itj1=ntortyp+1
5916       endif
5917       do iii=1,2
5918         dipi(iii,1)=Ub2(iii,i)
5919         dipderi(iii)=Ub2der(iii,i)
5920         dipi(iii,2)=b1(iii,iti1)
5921         dipj(iii,1)=Ub2(iii,j)
5922         dipderj(iii)=Ub2der(iii,j)
5923         dipj(iii,2)=b1(iii,itj1)
5924       enddo
5925       kkk=0
5926       do iii=1,2
5927         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5928         do jjj=1,2
5929           kkk=kkk+1
5930           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5931         enddo
5932       enddo
5933       if (.not.calc_grad) return
5934       do kkk=1,5
5935         do lll=1,3
5936           mmm=0
5937           do iii=1,2
5938             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5939      &        auxvec(1))
5940             do jjj=1,2
5941               mmm=mmm+1
5942               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5943             enddo
5944           enddo
5945         enddo
5946       enddo
5947       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5948       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5949       do iii=1,2
5950         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5951       enddo
5952       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5953       do iii=1,2
5954         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5955       enddo
5956       return
5957       end
5958 C---------------------------------------------------------------------------
5959       subroutine calc_eello(i,j,k,l,jj,kk)
5960 C
5961 C This subroutine computes matrices and vectors needed to calculate
5962 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5963 C
5964       implicit real*8 (a-h,o-z)
5965       include 'DIMENSIONS'
5966       include 'sizesclu.dat'
5967       include 'COMMON.IOUNITS'
5968       include 'COMMON.CHAIN'
5969       include 'COMMON.DERIV'
5970       include 'COMMON.INTERACT'
5971       include 'COMMON.CONTACTS'
5972       include 'COMMON.TORSION'
5973       include 'COMMON.VAR'
5974       include 'COMMON.GEO'
5975       include 'COMMON.FFIELD'
5976       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5977      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5978       logical lprn
5979       common /kutas/ lprn
5980 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5981 cd     & ' jj=',jj,' kk=',kk
5982 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5983       do iii=1,2
5984         do jjj=1,2
5985           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5986           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5987         enddo
5988       enddo
5989       call transpose2(aa1(1,1),aa1t(1,1))
5990       call transpose2(aa2(1,1),aa2t(1,1))
5991       do kkk=1,5
5992         do lll=1,3
5993           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5994      &      aa1tder(1,1,lll,kkk))
5995           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5996      &      aa2tder(1,1,lll,kkk))
5997         enddo
5998       enddo
5999       if (l.eq.j+1) then
6000 C parallel orientation of the two CA-CA-CA frames.
6001         if (i.gt.1) then
6002           iti=itortyp(itype(i))
6003         else
6004           iti=ntortyp+1
6005         endif
6006         itk1=itortyp(itype(k+1))
6007         itj=itortyp(itype(j))
6008         if (l.lt.nres-1) then
6009           itl1=itortyp(itype(l+1))
6010         else
6011           itl1=ntortyp+1
6012         endif
6013 C A1 kernel(j+1) A2T
6014 cd        do iii=1,2
6015 cd          write (iout,'(3f10.5,5x,3f10.5)')
6016 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6017 cd        enddo
6018         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6019      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6020      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6021 C Following matrices are needed only for 6-th order cumulants
6022         IF (wcorr6.gt.0.0d0) THEN
6023         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6024      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6025      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6026         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6027      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6028      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6029      &   ADtEAderx(1,1,1,1,1,1))
6030         lprn=.false.
6031         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6032      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6033      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6034      &   ADtEA1derx(1,1,1,1,1,1))
6035         ENDIF
6036 C End 6-th order cumulants
6037 cd        lprn=.false.
6038 cd        if (lprn) then
6039 cd        write (2,*) 'In calc_eello6'
6040 cd        do iii=1,2
6041 cd          write (2,*) 'iii=',iii
6042 cd          do kkk=1,5
6043 cd            write (2,*) 'kkk=',kkk
6044 cd            do jjj=1,2
6045 cd              write (2,'(3(2f10.5),5x)')
6046 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6047 cd            enddo
6048 cd          enddo
6049 cd        enddo
6050 cd        endif
6051         call transpose2(EUgder(1,1,k),auxmat(1,1))
6052         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6053         call transpose2(EUg(1,1,k),auxmat(1,1))
6054         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6055         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6056         do iii=1,2
6057           do kkk=1,5
6058             do lll=1,3
6059               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6060      &          EAEAderx(1,1,lll,kkk,iii,1))
6061             enddo
6062           enddo
6063         enddo
6064 C A1T kernel(i+1) A2
6065         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6066      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6067      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6068 C Following matrices are needed only for 6-th order cumulants
6069         IF (wcorr6.gt.0.0d0) THEN
6070         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6071      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6072      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6073         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6074      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6075      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6076      &   ADtEAderx(1,1,1,1,1,2))
6077         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6078      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6079      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6080      &   ADtEA1derx(1,1,1,1,1,2))
6081         ENDIF
6082 C End 6-th order cumulants
6083         call transpose2(EUgder(1,1,l),auxmat(1,1))
6084         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6085         call transpose2(EUg(1,1,l),auxmat(1,1))
6086         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6087         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6088         do iii=1,2
6089           do kkk=1,5
6090             do lll=1,3
6091               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6092      &          EAEAderx(1,1,lll,kkk,iii,2))
6093             enddo
6094           enddo
6095         enddo
6096 C AEAb1 and AEAb2
6097 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6098 C They are needed only when the fifth- or the sixth-order cumulants are
6099 C indluded.
6100         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6101         call transpose2(AEA(1,1,1),auxmat(1,1))
6102         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6103         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6104         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6105         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6106         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6107         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6108         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6109         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6110         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6111         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6112         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6113         call transpose2(AEA(1,1,2),auxmat(1,1))
6114         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6115         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6116         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6117         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6118         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6119         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6120         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6121         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6122         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6123         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6124         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6125 C Calculate the Cartesian derivatives of the vectors.
6126         do iii=1,2
6127           do kkk=1,5
6128             do lll=1,3
6129               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6130               call matvec2(auxmat(1,1),b1(1,iti),
6131      &          AEAb1derx(1,lll,kkk,iii,1,1))
6132               call matvec2(auxmat(1,1),Ub2(1,i),
6133      &          AEAb2derx(1,lll,kkk,iii,1,1))
6134               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6135      &          AEAb1derx(1,lll,kkk,iii,2,1))
6136               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6137      &          AEAb2derx(1,lll,kkk,iii,2,1))
6138               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6139               call matvec2(auxmat(1,1),b1(1,itj),
6140      &          AEAb1derx(1,lll,kkk,iii,1,2))
6141               call matvec2(auxmat(1,1),Ub2(1,j),
6142      &          AEAb2derx(1,lll,kkk,iii,1,2))
6143               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6144      &          AEAb1derx(1,lll,kkk,iii,2,2))
6145               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6146      &          AEAb2derx(1,lll,kkk,iii,2,2))
6147             enddo
6148           enddo
6149         enddo
6150         ENDIF
6151 C End vectors
6152       else
6153 C Antiparallel orientation of the two CA-CA-CA frames.
6154         if (i.gt.1) then
6155           iti=itortyp(itype(i))
6156         else
6157           iti=ntortyp+1
6158         endif
6159         itk1=itortyp(itype(k+1))
6160         itl=itortyp(itype(l))
6161         itj=itortyp(itype(j))
6162         if (j.lt.nres-1) then
6163           itj1=itortyp(itype(j+1))
6164         else
6165           itj1=ntortyp+1
6166         endif
6167 C A2 kernel(j-1)T A1T
6168         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6169      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6170      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6171 C Following matrices are needed only for 6-th order cumulants
6172         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6173      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6174         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6175      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6176      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6177         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6178      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6179      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6180      &   ADtEAderx(1,1,1,1,1,1))
6181         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6182      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6183      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6184      &   ADtEA1derx(1,1,1,1,1,1))
6185         ENDIF
6186 C End 6-th order cumulants
6187         call transpose2(EUgder(1,1,k),auxmat(1,1))
6188         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6189         call transpose2(EUg(1,1,k),auxmat(1,1))
6190         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6191         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6192         do iii=1,2
6193           do kkk=1,5
6194             do lll=1,3
6195               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6196      &          EAEAderx(1,1,lll,kkk,iii,1))
6197             enddo
6198           enddo
6199         enddo
6200 C A2T kernel(i+1)T A1
6201         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6202      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6203      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6204 C Following matrices are needed only for 6-th order cumulants
6205         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6206      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6207         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6208      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6209      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6210         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6211      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6212      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6213      &   ADtEAderx(1,1,1,1,1,2))
6214         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6215      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6216      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6217      &   ADtEA1derx(1,1,1,1,1,2))
6218         ENDIF
6219 C End 6-th order cumulants
6220         call transpose2(EUgder(1,1,j),auxmat(1,1))
6221         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6222         call transpose2(EUg(1,1,j),auxmat(1,1))
6223         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6224         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6225         do iii=1,2
6226           do kkk=1,5
6227             do lll=1,3
6228               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6229      &          EAEAderx(1,1,lll,kkk,iii,2))
6230             enddo
6231           enddo
6232         enddo
6233 C AEAb1 and AEAb2
6234 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6235 C They are needed only when the fifth- or the sixth-order cumulants are
6236 C indluded.
6237         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6238      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6239         call transpose2(AEA(1,1,1),auxmat(1,1))
6240         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6241         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6242         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6243         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6244         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6245         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6246         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6247         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6248         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6249         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6250         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6251         call transpose2(AEA(1,1,2),auxmat(1,1))
6252         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6253         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6254         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6255         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6256         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6257         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6258         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6259         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6260         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6261         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6262         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6263 C Calculate the Cartesian derivatives of the vectors.
6264         do iii=1,2
6265           do kkk=1,5
6266             do lll=1,3
6267               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6268               call matvec2(auxmat(1,1),b1(1,iti),
6269      &          AEAb1derx(1,lll,kkk,iii,1,1))
6270               call matvec2(auxmat(1,1),Ub2(1,i),
6271      &          AEAb2derx(1,lll,kkk,iii,1,1))
6272               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6273      &          AEAb1derx(1,lll,kkk,iii,2,1))
6274               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6275      &          AEAb2derx(1,lll,kkk,iii,2,1))
6276               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6277               call matvec2(auxmat(1,1),b1(1,itl),
6278      &          AEAb1derx(1,lll,kkk,iii,1,2))
6279               call matvec2(auxmat(1,1),Ub2(1,l),
6280      &          AEAb2derx(1,lll,kkk,iii,1,2))
6281               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6282      &          AEAb1derx(1,lll,kkk,iii,2,2))
6283               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6284      &          AEAb2derx(1,lll,kkk,iii,2,2))
6285             enddo
6286           enddo
6287         enddo
6288         ENDIF
6289 C End vectors
6290       endif
6291       return
6292       end
6293 C---------------------------------------------------------------------------
6294       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6295      &  KK,KKderg,AKA,AKAderg,AKAderx)
6296       implicit none
6297       integer nderg
6298       logical transp
6299       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6300      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6301      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6302       integer iii,kkk,lll
6303       integer jjj,mmm
6304       logical lprn
6305       common /kutas/ lprn
6306       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6307       do iii=1,nderg
6308         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6309      &    AKAderg(1,1,iii))
6310       enddo
6311 cd      if (lprn) write (2,*) 'In kernel'
6312       do kkk=1,5
6313 cd        if (lprn) write (2,*) 'kkk=',kkk
6314         do lll=1,3
6315           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6316      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6317 cd          if (lprn) then
6318 cd            write (2,*) 'lll=',lll
6319 cd            write (2,*) 'iii=1'
6320 cd            do jjj=1,2
6321 cd              write (2,'(3(2f10.5),5x)')
6322 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6323 cd            enddo
6324 cd          endif
6325           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6326      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6327 cd          if (lprn) then
6328 cd            write (2,*) 'lll=',lll
6329 cd            write (2,*) 'iii=2'
6330 cd            do jjj=1,2
6331 cd              write (2,'(3(2f10.5),5x)')
6332 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6333 cd            enddo
6334 cd          endif
6335         enddo
6336       enddo
6337       return
6338       end
6339 C---------------------------------------------------------------------------
6340       double precision function eello4(i,j,k,l,jj,kk)
6341       implicit real*8 (a-h,o-z)
6342       include 'DIMENSIONS'
6343       include 'sizesclu.dat'
6344       include 'COMMON.IOUNITS'
6345       include 'COMMON.CHAIN'
6346       include 'COMMON.DERIV'
6347       include 'COMMON.INTERACT'
6348       include 'COMMON.CONTACTS'
6349       include 'COMMON.TORSION'
6350       include 'COMMON.VAR'
6351       include 'COMMON.GEO'
6352       double precision pizda(2,2),ggg1(3),ggg2(3)
6353 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6354 cd        eello4=0.0d0
6355 cd        return
6356 cd      endif
6357 cd      print *,'eello4:',i,j,k,l,jj,kk
6358 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6359 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6360 cold      eij=facont_hb(jj,i)
6361 cold      ekl=facont_hb(kk,k)
6362 cold      ekont=eij*ekl
6363       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6364       if (calc_grad) then
6365 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6366       gcorr_loc(k-1)=gcorr_loc(k-1)
6367      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6368       if (l.eq.j+1) then
6369         gcorr_loc(l-1)=gcorr_loc(l-1)
6370      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6371       else
6372         gcorr_loc(j-1)=gcorr_loc(j-1)
6373      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6374       endif
6375       do iii=1,2
6376         do kkk=1,5
6377           do lll=1,3
6378             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6379      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6380 cd            derx(lll,kkk,iii)=0.0d0
6381           enddo
6382         enddo
6383       enddo
6384 cd      gcorr_loc(l-1)=0.0d0
6385 cd      gcorr_loc(j-1)=0.0d0
6386 cd      gcorr_loc(k-1)=0.0d0
6387 cd      eel4=1.0d0
6388 cd      write (iout,*)'Contacts have occurred for peptide groups',
6389 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6390 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6391       if (j.lt.nres-1) then
6392         j1=j+1
6393         j2=j-1
6394       else
6395         j1=j-1
6396         j2=j-2
6397       endif
6398       if (l.lt.nres-1) then
6399         l1=l+1
6400         l2=l-1
6401       else
6402         l1=l-1
6403         l2=l-2
6404       endif
6405       do ll=1,3
6406 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6407         ggg1(ll)=eel4*g_contij(ll,1)
6408         ggg2(ll)=eel4*g_contij(ll,2)
6409         ghalf=0.5d0*ggg1(ll)
6410 cd        ghalf=0.0d0
6411         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6412         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6413         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6414         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6415 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6416         ghalf=0.5d0*ggg2(ll)
6417 cd        ghalf=0.0d0
6418         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6419         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6420         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6421         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6422       enddo
6423 cd      goto 1112
6424       do m=i+1,j-1
6425         do ll=1,3
6426 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6427           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6428         enddo
6429       enddo
6430       do m=k+1,l-1
6431         do ll=1,3
6432 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6433           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6434         enddo
6435       enddo
6436 1112  continue
6437       do m=i+2,j2
6438         do ll=1,3
6439           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6440         enddo
6441       enddo
6442       do m=k+2,l2
6443         do ll=1,3
6444           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6445         enddo
6446       enddo
6447 cd      do iii=1,nres-3
6448 cd        write (2,*) iii,gcorr_loc(iii)
6449 cd      enddo
6450       endif
6451       eello4=ekont*eel4
6452 cd      write (2,*) 'ekont',ekont
6453 cd      write (iout,*) 'eello4',ekont*eel4
6454       return
6455       end
6456 C---------------------------------------------------------------------------
6457       double precision function eello5(i,j,k,l,jj,kk)
6458       implicit real*8 (a-h,o-z)
6459       include 'DIMENSIONS'
6460       include 'sizesclu.dat'
6461       include 'COMMON.IOUNITS'
6462       include 'COMMON.CHAIN'
6463       include 'COMMON.DERIV'
6464       include 'COMMON.INTERACT'
6465       include 'COMMON.CONTACTS'
6466       include 'COMMON.TORSION'
6467       include 'COMMON.VAR'
6468       include 'COMMON.GEO'
6469       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6470       double precision ggg1(3),ggg2(3)
6471 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6472 C                                                                              C
6473 C                            Parallel chains                                   C
6474 C                                                                              C
6475 C          o             o                   o             o                   C
6476 C         /l\           / \             \   / \           / \   /              C
6477 C        /   \         /   \             \ /   \         /   \ /               C
6478 C       j| o |l1       | o |              o| o |         | o |o                C
6479 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6480 C      \i/   \         /   \ /             /   \         /   \                 C
6481 C       o    k1             o                                                  C
6482 C         (I)          (II)                (III)          (IV)                 C
6483 C                                                                              C
6484 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6485 C                                                                              C
6486 C                            Antiparallel chains                               C
6487 C                                                                              C
6488 C          o             o                   o             o                   C
6489 C         /j\           / \             \   / \           / \   /              C
6490 C        /   \         /   \             \ /   \         /   \ /               C
6491 C      j1| o |l        | o |              o| o |         | o |o                C
6492 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6493 C      \i/   \         /   \ /             /   \         /   \                 C
6494 C       o     k1            o                                                  C
6495 C         (I)          (II)                (III)          (IV)                 C
6496 C                                                                              C
6497 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6498 C                                                                              C
6499 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6500 C                                                                              C
6501 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6502 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6503 cd        eello5=0.0d0
6504 cd        return
6505 cd      endif
6506 cd      write (iout,*)
6507 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6508 cd     &   ' and',k,l
6509       itk=itortyp(itype(k))
6510       itl=itortyp(itype(l))
6511       itj=itortyp(itype(j))
6512       eello5_1=0.0d0
6513       eello5_2=0.0d0
6514       eello5_3=0.0d0
6515       eello5_4=0.0d0
6516 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6517 cd     &   eel5_3_num,eel5_4_num)
6518       do iii=1,2
6519         do kkk=1,5
6520           do lll=1,3
6521             derx(lll,kkk,iii)=0.0d0
6522           enddo
6523         enddo
6524       enddo
6525 cd      eij=facont_hb(jj,i)
6526 cd      ekl=facont_hb(kk,k)
6527 cd      ekont=eij*ekl
6528 cd      write (iout,*)'Contacts have occurred for peptide groups',
6529 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6530 cd      goto 1111
6531 C Contribution from the graph I.
6532 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6533 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6534       call transpose2(EUg(1,1,k),auxmat(1,1))
6535       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6536       vv(1)=pizda(1,1)-pizda(2,2)
6537       vv(2)=pizda(1,2)+pizda(2,1)
6538       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6539      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6540       if (calc_grad) then
6541 C Explicit gradient in virtual-dihedral angles.
6542       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6543      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6544      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6545       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6546       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6547       vv(1)=pizda(1,1)-pizda(2,2)
6548       vv(2)=pizda(1,2)+pizda(2,1)
6549       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6550      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6551      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6552       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6553       vv(1)=pizda(1,1)-pizda(2,2)
6554       vv(2)=pizda(1,2)+pizda(2,1)
6555       if (l.eq.j+1) then
6556         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6557      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6558      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6559       else
6560         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6561      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6562      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6563       endif
6564 C Cartesian gradient
6565       do iii=1,2
6566         do kkk=1,5
6567           do lll=1,3
6568             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6569      &        pizda(1,1))
6570             vv(1)=pizda(1,1)-pizda(2,2)
6571             vv(2)=pizda(1,2)+pizda(2,1)
6572             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6573      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6574      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6575           enddo
6576         enddo
6577       enddo
6578 c      goto 1112
6579       endif
6580 c1111  continue
6581 C Contribution from graph II
6582       call transpose2(EE(1,1,itk),auxmat(1,1))
6583       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6584       vv(1)=pizda(1,1)+pizda(2,2)
6585       vv(2)=pizda(2,1)-pizda(1,2)
6586       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6587      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6588       if (calc_grad) then
6589 C Explicit gradient in virtual-dihedral angles.
6590       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6591      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6592       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6593       vv(1)=pizda(1,1)+pizda(2,2)
6594       vv(2)=pizda(2,1)-pizda(1,2)
6595       if (l.eq.j+1) then
6596         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6597      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6598      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6599       else
6600         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6601      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6602      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6603       endif
6604 C Cartesian gradient
6605       do iii=1,2
6606         do kkk=1,5
6607           do lll=1,3
6608             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6609      &        pizda(1,1))
6610             vv(1)=pizda(1,1)+pizda(2,2)
6611             vv(2)=pizda(2,1)-pizda(1,2)
6612             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6613      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6614      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6615           enddo
6616         enddo
6617       enddo
6618 cd      goto 1112
6619       endif
6620 cd1111  continue
6621       if (l.eq.j+1) then
6622 cd        goto 1110
6623 C Parallel orientation
6624 C Contribution from graph III
6625         call transpose2(EUg(1,1,l),auxmat(1,1))
6626         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6627         vv(1)=pizda(1,1)-pizda(2,2)
6628         vv(2)=pizda(1,2)+pizda(2,1)
6629         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6630      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6631         if (calc_grad) then
6632 C Explicit gradient in virtual-dihedral angles.
6633         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6634      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6635      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6636         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6637         vv(1)=pizda(1,1)-pizda(2,2)
6638         vv(2)=pizda(1,2)+pizda(2,1)
6639         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6640      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6641      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6642         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6643         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6644         vv(1)=pizda(1,1)-pizda(2,2)
6645         vv(2)=pizda(1,2)+pizda(2,1)
6646         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6647      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6648      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6649 C Cartesian gradient
6650         do iii=1,2
6651           do kkk=1,5
6652             do lll=1,3
6653               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6654      &          pizda(1,1))
6655               vv(1)=pizda(1,1)-pizda(2,2)
6656               vv(2)=pizda(1,2)+pizda(2,1)
6657               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6658      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6659      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6660             enddo
6661           enddo
6662         enddo
6663 cd        goto 1112
6664         endif
6665 C Contribution from graph IV
6666 cd1110    continue
6667         call transpose2(EE(1,1,itl),auxmat(1,1))
6668         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6669         vv(1)=pizda(1,1)+pizda(2,2)
6670         vv(2)=pizda(2,1)-pizda(1,2)
6671         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6672      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6673         if (calc_grad) then
6674 C Explicit gradient in virtual-dihedral angles.
6675         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6676      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6677         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6678         vv(1)=pizda(1,1)+pizda(2,2)
6679         vv(2)=pizda(2,1)-pizda(1,2)
6680         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6681      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6682      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6683 C Cartesian gradient
6684         do iii=1,2
6685           do kkk=1,5
6686             do lll=1,3
6687               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6688      &          pizda(1,1))
6689               vv(1)=pizda(1,1)+pizda(2,2)
6690               vv(2)=pizda(2,1)-pizda(1,2)
6691               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6692      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6693      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6694             enddo
6695           enddo
6696         enddo
6697         endif
6698       else
6699 C Antiparallel orientation
6700 C Contribution from graph III
6701 c        goto 1110
6702         call transpose2(EUg(1,1,j),auxmat(1,1))
6703         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6704         vv(1)=pizda(1,1)-pizda(2,2)
6705         vv(2)=pizda(1,2)+pizda(2,1)
6706         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6707      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6708         if (calc_grad) then
6709 C Explicit gradient in virtual-dihedral angles.
6710         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6711      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6712      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6713         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6714         vv(1)=pizda(1,1)-pizda(2,2)
6715         vv(2)=pizda(1,2)+pizda(2,1)
6716         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6717      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6719         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6720         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6721         vv(1)=pizda(1,1)-pizda(2,2)
6722         vv(2)=pizda(1,2)+pizda(2,1)
6723         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6724      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6726 C Cartesian gradient
6727         do iii=1,2
6728           do kkk=1,5
6729             do lll=1,3
6730               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6731      &          pizda(1,1))
6732               vv(1)=pizda(1,1)-pizda(2,2)
6733               vv(2)=pizda(1,2)+pizda(2,1)
6734               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6735      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6736      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6737             enddo
6738           enddo
6739         enddo
6740 cd        goto 1112
6741         endif
6742 C Contribution from graph IV
6743 1110    continue
6744         call transpose2(EE(1,1,itj),auxmat(1,1))
6745         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6746         vv(1)=pizda(1,1)+pizda(2,2)
6747         vv(2)=pizda(2,1)-pizda(1,2)
6748         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6749      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6750         if (calc_grad) then
6751 C Explicit gradient in virtual-dihedral angles.
6752         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6753      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6754         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6755         vv(1)=pizda(1,1)+pizda(2,2)
6756         vv(2)=pizda(2,1)-pizda(1,2)
6757         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6758      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6759      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6760 C Cartesian gradient
6761         do iii=1,2
6762           do kkk=1,5
6763             do lll=1,3
6764               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6765      &          pizda(1,1))
6766               vv(1)=pizda(1,1)+pizda(2,2)
6767               vv(2)=pizda(2,1)-pizda(1,2)
6768               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6769      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6770      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6771             enddo
6772           enddo
6773         enddo
6774       endif
6775       endif
6776 1112  continue
6777       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6778 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6779 cd        write (2,*) 'ijkl',i,j,k,l
6780 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6781 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6782 cd      endif
6783 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6784 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6785 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6786 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6787       if (calc_grad) then
6788       if (j.lt.nres-1) then
6789         j1=j+1
6790         j2=j-1
6791       else
6792         j1=j-1
6793         j2=j-2
6794       endif
6795       if (l.lt.nres-1) then
6796         l1=l+1
6797         l2=l-1
6798       else
6799         l1=l-1
6800         l2=l-2
6801       endif
6802 cd      eij=1.0d0
6803 cd      ekl=1.0d0
6804 cd      ekont=1.0d0
6805 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6806       do ll=1,3
6807         ggg1(ll)=eel5*g_contij(ll,1)
6808         ggg2(ll)=eel5*g_contij(ll,2)
6809 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6810         ghalf=0.5d0*ggg1(ll)
6811 cd        ghalf=0.0d0
6812         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6813         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6814         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6815         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6816 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6817         ghalf=0.5d0*ggg2(ll)
6818 cd        ghalf=0.0d0
6819         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6820         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6821         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6822         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6823       enddo
6824 cd      goto 1112
6825       do m=i+1,j-1
6826         do ll=1,3
6827 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6828           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6829         enddo
6830       enddo
6831       do m=k+1,l-1
6832         do ll=1,3
6833 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6834           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6835         enddo
6836       enddo
6837 c1112  continue
6838       do m=i+2,j2
6839         do ll=1,3
6840           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6841         enddo
6842       enddo
6843       do m=k+2,l2
6844         do ll=1,3
6845           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6846         enddo
6847       enddo
6848 cd      do iii=1,nres-3
6849 cd        write (2,*) iii,g_corr5_loc(iii)
6850 cd      enddo
6851       endif
6852       eello5=ekont*eel5
6853 cd      write (2,*) 'ekont',ekont
6854 cd      write (iout,*) 'eello5',ekont*eel5
6855       return
6856       end
6857 c--------------------------------------------------------------------------
6858       double precision function eello6(i,j,k,l,jj,kk)
6859       implicit real*8 (a-h,o-z)
6860       include 'DIMENSIONS'
6861       include 'sizesclu.dat'
6862       include 'COMMON.IOUNITS'
6863       include 'COMMON.CHAIN'
6864       include 'COMMON.DERIV'
6865       include 'COMMON.INTERACT'
6866       include 'COMMON.CONTACTS'
6867       include 'COMMON.TORSION'
6868       include 'COMMON.VAR'
6869       include 'COMMON.GEO'
6870       include 'COMMON.FFIELD'
6871       double precision ggg1(3),ggg2(3)
6872 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6873 cd        eello6=0.0d0
6874 cd        return
6875 cd      endif
6876 cd      write (iout,*)
6877 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6878 cd     &   ' and',k,l
6879       eello6_1=0.0d0
6880       eello6_2=0.0d0
6881       eello6_3=0.0d0
6882       eello6_4=0.0d0
6883       eello6_5=0.0d0
6884       eello6_6=0.0d0
6885 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6886 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6887       do iii=1,2
6888         do kkk=1,5
6889           do lll=1,3
6890             derx(lll,kkk,iii)=0.0d0
6891           enddo
6892         enddo
6893       enddo
6894 cd      eij=facont_hb(jj,i)
6895 cd      ekl=facont_hb(kk,k)
6896 cd      ekont=eij*ekl
6897 cd      eij=1.0d0
6898 cd      ekl=1.0d0
6899 cd      ekont=1.0d0
6900       if (l.eq.j+1) then
6901         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6902         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6903         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6904         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6905         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6906         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6907       else
6908         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6909         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6910         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6911         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6912         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6913           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6914         else
6915           eello6_5=0.0d0
6916         endif
6917         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6918       endif
6919 C If turn contributions are considered, they will be handled separately.
6920       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6921 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6922 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6923 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6924 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6925 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6926 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6927 cd      goto 1112
6928       if (calc_grad) then
6929       if (j.lt.nres-1) then
6930         j1=j+1
6931         j2=j-1
6932       else
6933         j1=j-1
6934         j2=j-2
6935       endif
6936       if (l.lt.nres-1) then
6937         l1=l+1
6938         l2=l-1
6939       else
6940         l1=l-1
6941         l2=l-2
6942       endif
6943       do ll=1,3
6944         ggg1(ll)=eel6*g_contij(ll,1)
6945         ggg2(ll)=eel6*g_contij(ll,2)
6946 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6947         ghalf=0.5d0*ggg1(ll)
6948 cd        ghalf=0.0d0
6949         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6950         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6951         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6952         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6953         ghalf=0.5d0*ggg2(ll)
6954 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6955 cd        ghalf=0.0d0
6956         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6957         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6958         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6959         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6960       enddo
6961 cd      goto 1112
6962       do m=i+1,j-1
6963         do ll=1,3
6964 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6965           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6966         enddo
6967       enddo
6968       do m=k+1,l-1
6969         do ll=1,3
6970 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6971           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6972         enddo
6973       enddo
6974 1112  continue
6975       do m=i+2,j2
6976         do ll=1,3
6977           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6978         enddo
6979       enddo
6980       do m=k+2,l2
6981         do ll=1,3
6982           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6983         enddo
6984       enddo
6985 cd      do iii=1,nres-3
6986 cd        write (2,*) iii,g_corr6_loc(iii)
6987 cd      enddo
6988       endif
6989       eello6=ekont*eel6
6990 cd      write (2,*) 'ekont',ekont
6991 cd      write (iout,*) 'eello6',ekont*eel6
6992       return
6993       end
6994 c--------------------------------------------------------------------------
6995       double precision function eello6_graph1(i,j,k,l,imat,swap)
6996       implicit real*8 (a-h,o-z)
6997       include 'DIMENSIONS'
6998       include 'sizesclu.dat'
6999       include 'COMMON.IOUNITS'
7000       include 'COMMON.CHAIN'
7001       include 'COMMON.DERIV'
7002       include 'COMMON.INTERACT'
7003       include 'COMMON.CONTACTS'
7004       include 'COMMON.TORSION'
7005       include 'COMMON.VAR'
7006       include 'COMMON.GEO'
7007       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7008       logical swap
7009       logical lprn
7010       common /kutas/ lprn
7011 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7012 C                                                                              C
7013 C      Parallel       Antiparallel                                             C
7014 C                                                                              C
7015 C          o             o                                                     C
7016 C         /l\           /j\                                                    C
7017 C        /   \         /   \                                                   C
7018 C       /| o |         | o |\                                                  C
7019 C     \ j|/k\|  /   \  |/k\|l /                                                C
7020 C      \ /   \ /     \ /   \ /                                                 C
7021 C       o     o       o     o                                                  C
7022 C       i             i                                                        C
7023 C                                                                              C
7024 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7025       itk=itortyp(itype(k))
7026       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7027       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7028       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7029       call transpose2(EUgC(1,1,k),auxmat(1,1))
7030       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7031       vv1(1)=pizda1(1,1)-pizda1(2,2)
7032       vv1(2)=pizda1(1,2)+pizda1(2,1)
7033       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7034       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7035       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7036       s5=scalar2(vv(1),Dtobr2(1,i))
7037 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7038       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7039       if (.not. calc_grad) return
7040       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7041      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7042      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7043      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7044      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7045      & +scalar2(vv(1),Dtobr2der(1,i)))
7046       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7047       vv1(1)=pizda1(1,1)-pizda1(2,2)
7048       vv1(2)=pizda1(1,2)+pizda1(2,1)
7049       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7050       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7051       if (l.eq.j+1) then
7052         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7053      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7054      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7055      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7056      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7057       else
7058         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7059      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7060      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7061      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7062      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7063       endif
7064       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7065       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7066       vv1(1)=pizda1(1,1)-pizda1(2,2)
7067       vv1(2)=pizda1(1,2)+pizda1(2,1)
7068       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7069      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7070      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7071      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7072       do iii=1,2
7073         if (swap) then
7074           ind=3-iii
7075         else
7076           ind=iii
7077         endif
7078         do kkk=1,5
7079           do lll=1,3
7080             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7081             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7082             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7083             call transpose2(EUgC(1,1,k),auxmat(1,1))
7084             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7085      &        pizda1(1,1))
7086             vv1(1)=pizda1(1,1)-pizda1(2,2)
7087             vv1(2)=pizda1(1,2)+pizda1(2,1)
7088             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7089             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7090      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7091             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7092      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7093             s5=scalar2(vv(1),Dtobr2(1,i))
7094             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7095           enddo
7096         enddo
7097       enddo
7098       return
7099       end
7100 c----------------------------------------------------------------------------
7101       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7102       implicit real*8 (a-h,o-z)
7103       include 'DIMENSIONS'
7104       include 'sizesclu.dat'
7105       include 'COMMON.IOUNITS'
7106       include 'COMMON.CHAIN'
7107       include 'COMMON.DERIV'
7108       include 'COMMON.INTERACT'
7109       include 'COMMON.CONTACTS'
7110       include 'COMMON.TORSION'
7111       include 'COMMON.VAR'
7112       include 'COMMON.GEO'
7113       logical swap
7114       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7115      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7116       logical lprn
7117       common /kutas/ lprn
7118 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7119 C                                                                              C
7120 C      Parallel       Antiparallel                                             C
7121 C                                                                              C
7122 C          o             o                                                     C
7123 C     \   /l\           /j\   /                                                C
7124 C      \ /   \         /   \ /                                                 C
7125 C       o| o |         | o |o                                                  C
7126 C     \ j|/k\|      \  |/k\|l                                                  C
7127 C      \ /   \       \ /   \                                                   C
7128 C       o             o                                                        C
7129 C       i             i                                                        C
7130 C                                                                              C
7131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7132 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7133 C AL 7/4/01 s1 would occur in the sixth-order moment,
7134 C           but not in a cluster cumulant
7135 #ifdef MOMENT
7136       s1=dip(1,jj,i)*dip(1,kk,k)
7137 #endif
7138       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7139       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7140       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7141       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7142       call transpose2(EUg(1,1,k),auxmat(1,1))
7143       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7144       vv(1)=pizda(1,1)-pizda(2,2)
7145       vv(2)=pizda(1,2)+pizda(2,1)
7146       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7147 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7148 #ifdef MOMENT
7149       eello6_graph2=-(s1+s2+s3+s4)
7150 #else
7151       eello6_graph2=-(s2+s3+s4)
7152 #endif
7153 c      eello6_graph2=-s3
7154       if (.not. calc_grad) return
7155 C Derivatives in gamma(i-1)
7156       if (i.gt.1) then
7157 #ifdef MOMENT
7158         s1=dipderg(1,jj,i)*dip(1,kk,k)
7159 #endif
7160         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7161         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7162         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7163         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7164 #ifdef MOMENT
7165         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7166 #else
7167         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7168 #endif
7169 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7170       endif
7171 C Derivatives in gamma(k-1)
7172 #ifdef MOMENT
7173       s1=dip(1,jj,i)*dipderg(1,kk,k)
7174 #endif
7175       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7176       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7177       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7178       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7179       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7180       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7181       vv(1)=pizda(1,1)-pizda(2,2)
7182       vv(2)=pizda(1,2)+pizda(2,1)
7183       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7184 #ifdef MOMENT
7185       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7186 #else
7187       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7188 #endif
7189 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7190 C Derivatives in gamma(j-1) or gamma(l-1)
7191       if (j.gt.1) then
7192 #ifdef MOMENT
7193         s1=dipderg(3,jj,i)*dip(1,kk,k)
7194 #endif
7195         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7196         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7197         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7198         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7199         vv(1)=pizda(1,1)-pizda(2,2)
7200         vv(2)=pizda(1,2)+pizda(2,1)
7201         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7202 #ifdef MOMENT
7203         if (swap) then
7204           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7205         else
7206           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7207         endif
7208 #endif
7209         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7210 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7211       endif
7212 C Derivatives in gamma(l-1) or gamma(j-1)
7213       if (l.gt.1) then
7214 #ifdef MOMENT
7215         s1=dip(1,jj,i)*dipderg(3,kk,k)
7216 #endif
7217         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7218         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7219         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7220         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7221         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7222         vv(1)=pizda(1,1)-pizda(2,2)
7223         vv(2)=pizda(1,2)+pizda(2,1)
7224         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7225 #ifdef MOMENT
7226         if (swap) then
7227           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7228         else
7229           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7230         endif
7231 #endif
7232         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7233 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7234       endif
7235 C Cartesian derivatives.
7236       if (lprn) then
7237         write (2,*) 'In eello6_graph2'
7238         do iii=1,2
7239           write (2,*) 'iii=',iii
7240           do kkk=1,5
7241             write (2,*) 'kkk=',kkk
7242             do jjj=1,2
7243               write (2,'(3(2f10.5),5x)')
7244      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7245             enddo
7246           enddo
7247         enddo
7248       endif
7249       do iii=1,2
7250         do kkk=1,5
7251           do lll=1,3
7252 #ifdef MOMENT
7253             if (iii.eq.1) then
7254               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7255             else
7256               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7257             endif
7258 #endif
7259             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7260      &        auxvec(1))
7261             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7262             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7263      &        auxvec(1))
7264             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7265             call transpose2(EUg(1,1,k),auxmat(1,1))
7266             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7267      &        pizda(1,1))
7268             vv(1)=pizda(1,1)-pizda(2,2)
7269             vv(2)=pizda(1,2)+pizda(2,1)
7270             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7271 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7272 #ifdef MOMENT
7273             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7274 #else
7275             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7276 #endif
7277             if (swap) then
7278               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7279             else
7280               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7281             endif
7282           enddo
7283         enddo
7284       enddo
7285       return
7286       end
7287 c----------------------------------------------------------------------------
7288       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7289       implicit real*8 (a-h,o-z)
7290       include 'DIMENSIONS'
7291       include 'sizesclu.dat'
7292       include 'COMMON.IOUNITS'
7293       include 'COMMON.CHAIN'
7294       include 'COMMON.DERIV'
7295       include 'COMMON.INTERACT'
7296       include 'COMMON.CONTACTS'
7297       include 'COMMON.TORSION'
7298       include 'COMMON.VAR'
7299       include 'COMMON.GEO'
7300       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7301       logical swap
7302 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7303 C                                                                              C
7304 C      Parallel       Antiparallel                                             C
7305 C                                                                              C
7306 C          o             o                                                     C
7307 C         /l\   /   \   /j\                                                    C
7308 C        /   \ /     \ /   \                                                   C
7309 C       /| o |o       o| o |\                                                  C
7310 C       j|/k\|  /      |/k\|l /                                                C
7311 C        /   \ /       /   \ /                                                 C
7312 C       /     o       /     o                                                  C
7313 C       i             i                                                        C
7314 C                                                                              C
7315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7316 C
7317 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7318 C           energy moment and not to the cluster cumulant.
7319       iti=itortyp(itype(i))
7320       if (j.lt.nres-1) then
7321         itj1=itortyp(itype(j+1))
7322       else
7323         itj1=ntortyp+1
7324       endif
7325       itk=itortyp(itype(k))
7326       itk1=itortyp(itype(k+1))
7327       if (l.lt.nres-1) then
7328         itl1=itortyp(itype(l+1))
7329       else
7330         itl1=ntortyp+1
7331       endif
7332 #ifdef MOMENT
7333       s1=dip(4,jj,i)*dip(4,kk,k)
7334 #endif
7335       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7336       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7337       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7338       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7339       call transpose2(EE(1,1,itk),auxmat(1,1))
7340       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7341       vv(1)=pizda(1,1)+pizda(2,2)
7342       vv(2)=pizda(2,1)-pizda(1,2)
7343       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7344 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7345 #ifdef MOMENT
7346       eello6_graph3=-(s1+s2+s3+s4)
7347 #else
7348       eello6_graph3=-(s2+s3+s4)
7349 #endif
7350 c      eello6_graph3=-s4
7351       if (.not. calc_grad) return
7352 C Derivatives in gamma(k-1)
7353       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7354       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7355       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7356       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7357 C Derivatives in gamma(l-1)
7358       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7359       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7360       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7361       vv(1)=pizda(1,1)+pizda(2,2)
7362       vv(2)=pizda(2,1)-pizda(1,2)
7363       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7364       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7365 C Cartesian derivatives.
7366       do iii=1,2
7367         do kkk=1,5
7368           do lll=1,3
7369 #ifdef MOMENT
7370             if (iii.eq.1) then
7371               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7372             else
7373               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7374             endif
7375 #endif
7376             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7377      &        auxvec(1))
7378             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7379             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7380      &        auxvec(1))
7381             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7382             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7383      &        pizda(1,1))
7384             vv(1)=pizda(1,1)+pizda(2,2)
7385             vv(2)=pizda(2,1)-pizda(1,2)
7386             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7387 #ifdef MOMENT
7388             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7389 #else
7390             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7391 #endif
7392             if (swap) then
7393               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7394             else
7395               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7396             endif
7397 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7398           enddo
7399         enddo
7400       enddo
7401       return
7402       end
7403 c----------------------------------------------------------------------------
7404       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7405       implicit real*8 (a-h,o-z)
7406       include 'DIMENSIONS'
7407       include 'sizesclu.dat'
7408       include 'COMMON.IOUNITS'
7409       include 'COMMON.CHAIN'
7410       include 'COMMON.DERIV'
7411       include 'COMMON.INTERACT'
7412       include 'COMMON.CONTACTS'
7413       include 'COMMON.TORSION'
7414       include 'COMMON.VAR'
7415       include 'COMMON.GEO'
7416       include 'COMMON.FFIELD'
7417       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7418      & auxvec1(2),auxmat1(2,2)
7419       logical swap
7420 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7421 C                                                                              C
7422 C      Parallel       Antiparallel                                             C
7423 C                                                                              C
7424 C          o             o                                                     C
7425 C         /l\   /   \   /j\                                                    C
7426 C        /   \ /     \ /   \                                                   C
7427 C       /| o |o       o| o |\                                                  C
7428 C     \ j|/k\|      \  |/k\|l                                                  C
7429 C      \ /   \       \ /   \                                                   C
7430 C       o     \       o     \                                                  C
7431 C       i             i                                                        C
7432 C                                                                              C
7433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7434 C
7435 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7436 C           energy moment and not to the cluster cumulant.
7437 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7438       iti=itortyp(itype(i))
7439       itj=itortyp(itype(j))
7440       if (j.lt.nres-1) then
7441         itj1=itortyp(itype(j+1))
7442       else
7443         itj1=ntortyp+1
7444       endif
7445       itk=itortyp(itype(k))
7446       if (k.lt.nres-1) then
7447         itk1=itortyp(itype(k+1))
7448       else
7449         itk1=ntortyp+1
7450       endif
7451       itl=itortyp(itype(l))
7452       if (l.lt.nres-1) then
7453         itl1=itortyp(itype(l+1))
7454       else
7455         itl1=ntortyp+1
7456       endif
7457 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7458 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7459 cd     & ' itl',itl,' itl1',itl1
7460 #ifdef MOMENT
7461       if (imat.eq.1) then
7462         s1=dip(3,jj,i)*dip(3,kk,k)
7463       else
7464         s1=dip(2,jj,j)*dip(2,kk,l)
7465       endif
7466 #endif
7467       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7468       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7469       if (j.eq.l+1) then
7470         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7471         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7472       else
7473         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7474         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7475       endif
7476       call transpose2(EUg(1,1,k),auxmat(1,1))
7477       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7478       vv(1)=pizda(1,1)-pizda(2,2)
7479       vv(2)=pizda(2,1)+pizda(1,2)
7480       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7481 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7482 #ifdef MOMENT
7483       eello6_graph4=-(s1+s2+s3+s4)
7484 #else
7485       eello6_graph4=-(s2+s3+s4)
7486 #endif
7487       if (.not. calc_grad) return
7488 C Derivatives in gamma(i-1)
7489       if (i.gt.1) then
7490 #ifdef MOMENT
7491         if (imat.eq.1) then
7492           s1=dipderg(2,jj,i)*dip(3,kk,k)
7493         else
7494           s1=dipderg(4,jj,j)*dip(2,kk,l)
7495         endif
7496 #endif
7497         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7498         if (j.eq.l+1) then
7499           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7500           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7501         else
7502           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7503           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7504         endif
7505         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7506         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7507 cd          write (2,*) 'turn6 derivatives'
7508 #ifdef MOMENT
7509           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7510 #else
7511           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7512 #endif
7513         else
7514 #ifdef MOMENT
7515           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7516 #else
7517           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7518 #endif
7519         endif
7520       endif
7521 C Derivatives in gamma(k-1)
7522 #ifdef MOMENT
7523       if (imat.eq.1) then
7524         s1=dip(3,jj,i)*dipderg(2,kk,k)
7525       else
7526         s1=dip(2,jj,j)*dipderg(4,kk,l)
7527       endif
7528 #endif
7529       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7530       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7531       if (j.eq.l+1) then
7532         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7533         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7534       else
7535         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7536         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7537       endif
7538       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7539       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7540       vv(1)=pizda(1,1)-pizda(2,2)
7541       vv(2)=pizda(2,1)+pizda(1,2)
7542       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7543       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7544 #ifdef MOMENT
7545         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7546 #else
7547         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7548 #endif
7549       else
7550 #ifdef MOMENT
7551         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7552 #else
7553         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7554 #endif
7555       endif
7556 C Derivatives in gamma(j-1) or gamma(l-1)
7557       if (l.eq.j+1 .and. l.gt.1) then
7558         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7559         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7560         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7561         vv(1)=pizda(1,1)-pizda(2,2)
7562         vv(2)=pizda(2,1)+pizda(1,2)
7563         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7564         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7565       else if (j.gt.1) then
7566         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7567         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7568         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7569         vv(1)=pizda(1,1)-pizda(2,2)
7570         vv(2)=pizda(2,1)+pizda(1,2)
7571         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7572         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7573           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7574         else
7575           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7576         endif
7577       endif
7578 C Cartesian derivatives.
7579       do iii=1,2
7580         do kkk=1,5
7581           do lll=1,3
7582 #ifdef MOMENT
7583             if (iii.eq.1) then
7584               if (imat.eq.1) then
7585                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7586               else
7587                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7588               endif
7589             else
7590               if (imat.eq.1) then
7591                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7592               else
7593                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7594               endif
7595             endif
7596 #endif
7597             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7598      &        auxvec(1))
7599             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7600             if (j.eq.l+1) then
7601               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7602      &          b1(1,itj1),auxvec(1))
7603               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7604             else
7605               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7606      &          b1(1,itl1),auxvec(1))
7607               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7608             endif
7609             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7610      &        pizda(1,1))
7611             vv(1)=pizda(1,1)-pizda(2,2)
7612             vv(2)=pizda(2,1)+pizda(1,2)
7613             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7614             if (swap) then
7615               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7616 #ifdef MOMENT
7617                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7618      &             -(s1+s2+s4)
7619 #else
7620                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7621      &             -(s2+s4)
7622 #endif
7623                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7624               else
7625 #ifdef MOMENT
7626                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7627 #else
7628                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7629 #endif
7630                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7631               endif
7632             else
7633 #ifdef MOMENT
7634               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7635 #else
7636               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7637 #endif
7638               if (l.eq.j+1) then
7639                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7640               else
7641                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7642               endif
7643             endif
7644           enddo
7645         enddo
7646       enddo
7647       return
7648       end
7649 c----------------------------------------------------------------------------
7650       double precision function eello_turn6(i,jj,kk)
7651       implicit real*8 (a-h,o-z)
7652       include 'DIMENSIONS'
7653       include 'sizesclu.dat'
7654       include 'COMMON.IOUNITS'
7655       include 'COMMON.CHAIN'
7656       include 'COMMON.DERIV'
7657       include 'COMMON.INTERACT'
7658       include 'COMMON.CONTACTS'
7659       include 'COMMON.TORSION'
7660       include 'COMMON.VAR'
7661       include 'COMMON.GEO'
7662       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7663      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7664      &  ggg1(3),ggg2(3)
7665       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7666      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7667 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7668 C           the respective energy moment and not to the cluster cumulant.
7669       eello_turn6=0.0d0
7670       j=i+4
7671       k=i+1
7672       l=i+3
7673       iti=itortyp(itype(i))
7674       itk=itortyp(itype(k))
7675       itk1=itortyp(itype(k+1))
7676       itl=itortyp(itype(l))
7677       itj=itortyp(itype(j))
7678 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7679 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7680 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7681 cd        eello6=0.0d0
7682 cd        return
7683 cd      endif
7684 cd      write (iout,*)
7685 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7686 cd     &   ' and',k,l
7687 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7688       do iii=1,2
7689         do kkk=1,5
7690           do lll=1,3
7691             derx_turn(lll,kkk,iii)=0.0d0
7692           enddo
7693         enddo
7694       enddo
7695 cd      eij=1.0d0
7696 cd      ekl=1.0d0
7697 cd      ekont=1.0d0
7698       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7699 cd      eello6_5=0.0d0
7700 cd      write (2,*) 'eello6_5',eello6_5
7701 #ifdef MOMENT
7702       call transpose2(AEA(1,1,1),auxmat(1,1))
7703       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7704       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7705       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7706 #else
7707       s1 = 0.0d0
7708 #endif
7709       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7710       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7711       s2 = scalar2(b1(1,itk),vtemp1(1))
7712 #ifdef MOMENT
7713       call transpose2(AEA(1,1,2),atemp(1,1))
7714       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7715       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7716       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7717 #else
7718       s8=0.0d0
7719 #endif
7720       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7721       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7722       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7723 #ifdef MOMENT
7724       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7725       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7726       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7727       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7728       ss13 = scalar2(b1(1,itk),vtemp4(1))
7729       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7730 #else
7731       s13=0.0d0
7732 #endif
7733 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7734 c      s1=0.0d0
7735 c      s2=0.0d0
7736 c      s8=0.0d0
7737 c      s12=0.0d0
7738 c      s13=0.0d0
7739       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7740       if (calc_grad) then
7741 C Derivatives in gamma(i+2)
7742 #ifdef MOMENT
7743       call transpose2(AEA(1,1,1),auxmatd(1,1))
7744       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7745       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7746       call transpose2(AEAderg(1,1,2),atempd(1,1))
7747       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7748       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7749 #else
7750       s8d=0.0d0
7751 #endif
7752       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7753       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7754       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7755 c      s1d=0.0d0
7756 c      s2d=0.0d0
7757 c      s8d=0.0d0
7758 c      s12d=0.0d0
7759 c      s13d=0.0d0
7760       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7761 C Derivatives in gamma(i+3)
7762 #ifdef MOMENT
7763       call transpose2(AEA(1,1,1),auxmatd(1,1))
7764       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7765       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7766       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7767 #else
7768       s1d=0.0d0
7769 #endif
7770       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7771       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7772       s2d = scalar2(b1(1,itk),vtemp1d(1))
7773 #ifdef MOMENT
7774       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7775       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7776 #endif
7777       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7778 #ifdef MOMENT
7779       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7780       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7781       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7782 #else
7783       s13d=0.0d0
7784 #endif
7785 c      s1d=0.0d0
7786 c      s2d=0.0d0
7787 c      s8d=0.0d0
7788 c      s12d=0.0d0
7789 c      s13d=0.0d0
7790 #ifdef MOMENT
7791       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7792      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7793 #else
7794       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7795      &               -0.5d0*ekont*(s2d+s12d)
7796 #endif
7797 C Derivatives in gamma(i+4)
7798       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7799       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7800       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7801 #ifdef MOMENT
7802       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7803       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7804       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7805 #else
7806       s13d = 0.0d0
7807 #endif
7808 c      s1d=0.0d0
7809 c      s2d=0.0d0
7810 c      s8d=0.0d0
7811 C      s12d=0.0d0
7812 c      s13d=0.0d0
7813 #ifdef MOMENT
7814       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7815 #else
7816       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7817 #endif
7818 C Derivatives in gamma(i+5)
7819 #ifdef MOMENT
7820       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7821       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7822       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7823 #else
7824       s1d = 0.0d0
7825 #endif
7826       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7827       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7828       s2d = scalar2(b1(1,itk),vtemp1d(1))
7829 #ifdef MOMENT
7830       call transpose2(AEA(1,1,2),atempd(1,1))
7831       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7832       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7833 #else
7834       s8d = 0.0d0
7835 #endif
7836       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7837       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7838 #ifdef MOMENT
7839       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7840       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7841       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7842 #else
7843       s13d = 0.0d0
7844 #endif
7845 c      s1d=0.0d0
7846 c      s2d=0.0d0
7847 c      s8d=0.0d0
7848 c      s12d=0.0d0
7849 c      s13d=0.0d0
7850 #ifdef MOMENT
7851       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7852      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7853 #else
7854       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7855      &               -0.5d0*ekont*(s2d+s12d)
7856 #endif
7857 C Cartesian derivatives
7858       do iii=1,2
7859         do kkk=1,5
7860           do lll=1,3
7861 #ifdef MOMENT
7862             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7863             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7864             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7865 #else
7866             s1d = 0.0d0
7867 #endif
7868             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7869             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7870      &          vtemp1d(1))
7871             s2d = scalar2(b1(1,itk),vtemp1d(1))
7872 #ifdef MOMENT
7873             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7874             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7875             s8d = -(atempd(1,1)+atempd(2,2))*
7876      &           scalar2(cc(1,1,itl),vtemp2(1))
7877 #else
7878             s8d = 0.0d0
7879 #endif
7880             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7881      &           auxmatd(1,1))
7882             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7883             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7884 c      s1d=0.0d0
7885 c      s2d=0.0d0
7886 c      s8d=0.0d0
7887 c      s12d=0.0d0
7888 c      s13d=0.0d0
7889 #ifdef MOMENT
7890             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7891      &        - 0.5d0*(s1d+s2d)
7892 #else
7893             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7894      &        - 0.5d0*s2d
7895 #endif
7896 #ifdef MOMENT
7897             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7898      &        - 0.5d0*(s8d+s12d)
7899 #else
7900             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7901      &        - 0.5d0*s12d
7902 #endif
7903           enddo
7904         enddo
7905       enddo
7906 #ifdef MOMENT
7907       do kkk=1,5
7908         do lll=1,3
7909           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7910      &      achuj_tempd(1,1))
7911           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7912           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7913           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7914           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7915           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7916      &      vtemp4d(1))
7917           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7918           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7919           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7920         enddo
7921       enddo
7922 #endif
7923 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7924 cd     &  16*eel_turn6_num
7925 cd      goto 1112
7926       if (j.lt.nres-1) then
7927         j1=j+1
7928         j2=j-1
7929       else
7930         j1=j-1
7931         j2=j-2
7932       endif
7933       if (l.lt.nres-1) then
7934         l1=l+1
7935         l2=l-1
7936       else
7937         l1=l-1
7938         l2=l-2
7939       endif
7940       do ll=1,3
7941         ggg1(ll)=eel_turn6*g_contij(ll,1)
7942         ggg2(ll)=eel_turn6*g_contij(ll,2)
7943         ghalf=0.5d0*ggg1(ll)
7944 cd        ghalf=0.0d0
7945         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7946      &    +ekont*derx_turn(ll,2,1)
7947         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7948         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7949      &    +ekont*derx_turn(ll,4,1)
7950         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7951         ghalf=0.5d0*ggg2(ll)
7952 cd        ghalf=0.0d0
7953         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7954      &    +ekont*derx_turn(ll,2,2)
7955         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7956         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7957      &    +ekont*derx_turn(ll,4,2)
7958         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7959       enddo
7960 cd      goto 1112
7961       do m=i+1,j-1
7962         do ll=1,3
7963           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7964         enddo
7965       enddo
7966       do m=k+1,l-1
7967         do ll=1,3
7968           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7969         enddo
7970       enddo
7971 1112  continue
7972       do m=i+2,j2
7973         do ll=1,3
7974           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7975         enddo
7976       enddo
7977       do m=k+2,l2
7978         do ll=1,3
7979           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7980         enddo
7981       enddo
7982 cd      do iii=1,nres-3
7983 cd        write (2,*) iii,g_corr6_loc(iii)
7984 cd      enddo
7985       endif
7986       eello_turn6=ekont*eel_turn6
7987 cd      write (2,*) 'ekont',ekont
7988 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7989       return
7990       end
7991 crc-------------------------------------------------
7992       SUBROUTINE MATVEC2(A1,V1,V2)
7993       implicit real*8 (a-h,o-z)
7994       include 'DIMENSIONS'
7995       DIMENSION A1(2,2),V1(2),V2(2)
7996 c      DO 1 I=1,2
7997 c        VI=0.0
7998 c        DO 3 K=1,2
7999 c    3     VI=VI+A1(I,K)*V1(K)
8000 c        Vaux(I)=VI
8001 c    1 CONTINUE
8002
8003       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8004       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8005
8006       v2(1)=vaux1
8007       v2(2)=vaux2
8008       END
8009 C---------------------------------------
8010       SUBROUTINE MATMAT2(A1,A2,A3)
8011       implicit real*8 (a-h,o-z)
8012       include 'DIMENSIONS'
8013       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8014 c      DIMENSION AI3(2,2)
8015 c        DO  J=1,2
8016 c          A3IJ=0.0
8017 c          DO K=1,2
8018 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8019 c          enddo
8020 c          A3(I,J)=A3IJ
8021 c       enddo
8022 c      enddo
8023
8024       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8025       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8026       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8027       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8028
8029       A3(1,1)=AI3_11
8030       A3(2,1)=AI3_21
8031       A3(1,2)=AI3_12
8032       A3(2,2)=AI3_22
8033       END
8034
8035 c-------------------------------------------------------------------------
8036       double precision function scalar2(u,v)
8037       implicit none
8038       double precision u(2),v(2)
8039       double precision sc
8040       integer i
8041       scalar2=u(1)*v(1)+u(2)*v(2)
8042       return
8043       end
8044
8045 C-----------------------------------------------------------------------------
8046
8047       subroutine transpose2(a,at)
8048       implicit none
8049       double precision a(2,2),at(2,2)
8050       at(1,1)=a(1,1)
8051       at(1,2)=a(2,1)
8052       at(2,1)=a(1,2)
8053       at(2,2)=a(2,2)
8054       return
8055       end
8056 c--------------------------------------------------------------------------
8057       subroutine transpose(n,a,at)
8058       implicit none
8059       integer n,i,j
8060       double precision a(n,n),at(n,n)
8061       do i=1,n
8062         do j=1,n
8063           at(j,i)=a(i,j)
8064         enddo
8065       enddo
8066       return
8067       end
8068 C---------------------------------------------------------------------------
8069       subroutine prodmat3(a1,a2,kk,transp,prod)
8070       implicit none
8071       integer i,j
8072       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8073       logical transp
8074 crc      double precision auxmat(2,2),prod_(2,2)
8075
8076       if (transp) then
8077 crc        call transpose2(kk(1,1),auxmat(1,1))
8078 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8079 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8080
8081            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8082      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8083            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8084      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8085            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8086      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8087            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8088      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8089
8090       else
8091 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8092 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8093
8094            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8095      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8096            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8097      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8098            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8099      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8100            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8101      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8102
8103       endif
8104 c      call transpose2(a2(1,1),a2t(1,1))
8105
8106 crc      print *,transp
8107 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8108 crc      print *,((prod(i,j),i=1,2),j=1,2)
8109
8110       return
8111       end
8112 C-----------------------------------------------------------------------------
8113       double precision function scalar(u,v)
8114       implicit none
8115       double precision u(3),v(3)
8116       double precision sc
8117       integer i
8118       sc=0.0d0
8119       do i=1,3
8120         sc=sc+u(i)*v(i)
8121       enddo
8122       scalar=sc
8123       return
8124       end
8125