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 #ifdef OLDRESTR
3349         kat2=0.0d0
3350 #else
3351         kat2=nexl
3352 #endif
3353 c        betai=beta(i,i+1,i+2,i+3)
3354         betai = phi(i)
3355 c       write (iout,*) "betai =",betai
3356         do k=1,constr_homology
3357           dih_diff(k)=pinorm(dih(k,i)-betai)
3358 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3359 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3360 c     &                                   -(6.28318-dih_diff(i,k))
3361 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3362 c     &                                   6.28318+dih_diff(i,k)
3363
3364           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3365 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3366           gdih(k)=dexp(kat3)
3367           kat2=kat2+gdih(k)
3368 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3369 c          write(*,*)""
3370         enddo
3371 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3372 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3373 #ifdef DEBUG
3374         write (iout,*) "i",i," betai",betai," kat2",kat2
3375         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3376 #endif
3377         if (kat2.le.1.0d-14) cycle
3378         kat=kat-dLOG(kat2/constr_homology)
3379 c       write (iout,*) "kat",kat ! sum of -ln-s
3380
3381 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3382 ccc     & dLOG(kat2), "-kat=", -kat
3383
3384 #ifdef GRAD
3385 c ----------------------------------------------------------------------
3386 c Gradient
3387 c ----------------------------------------------------------------------
3388
3389         sum_gdih=kat2
3390         sum_sgdih=0.0d0
3391         do k=1,constr_homology
3392           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3393 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3394           sum_sgdih=sum_sgdih+sgdih
3395         enddo
3396 c       grad_dih3=sum_sgdih/sum_gdih
3397         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3398
3399 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3400 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3401 ccc     & gloc(nphi+i-3,icg)
3402         gloc(i,icg)=gloc(i,icg)+grad_dih3
3403 c        if (i.eq.25) then
3404 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3405 c        endif
3406 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3407 ccc     & gloc(nphi+i-3,icg)
3408 #endif
3409       enddo ! i-loop for dih
3410 #ifdef DEBUG
3411       write(iout,*) "------- dih restrs end -------"
3412 #endif
3413
3414 c Pseudo-energy and gradient for theta angle restraints from
3415 c homology templates
3416 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3417 c adapted
3418
3419 c
3420 c     For constr_homology reference structures (FP)
3421 c
3422 c     Uconst_back_tot=0.0d0
3423       Eval=0.0d0
3424       Erot=0.0d0
3425 c     Econstr_back legacy
3426 #ifdef GRAD
3427       do i=1,nres
3428 c     do i=ithet_start,ithet_end
3429        dutheta(i)=0.0d0
3430 c     enddo
3431 c     do i=loc_start,loc_end
3432         do j=1,3
3433           duscdiff(j,i)=0.0d0
3434           duscdiffx(j,i)=0.0d0
3435         enddo
3436       enddo
3437 #endif
3438 c
3439 c     do iref=1,nref
3440 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3441 c     write (iout,*) "waga_theta",waga_theta
3442       if (waga_theta.gt.0.0d0) then
3443 #ifdef DEBUG
3444       write (iout,*) "usampl",usampl
3445       write(iout,*) "------- theta restrs start -------"
3446 c     do i=ithet_start,ithet_end
3447 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3448 c     enddo
3449 #endif
3450 c     write (iout,*) "maxres",maxres,"nres",nres
3451
3452       do i=ithet_start,ithet_end
3453 c
3454 c     do i=1,nfrag_back
3455 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3456 c
3457 c Deviation of theta angles wrt constr_homology ref structures
3458 c
3459         utheta_i=0.0d0 ! argument of Gaussian for single k
3460 #ifdef OLDRESTR
3461         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3462 #else
3463         gutheta_i=nexl
3464 #endif
3465 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3466 c       over residues in a fragment
3467 c       write (iout,*) "theta(",i,")=",theta(i)
3468         do k=1,constr_homology
3469 c
3470 c         dtheta_i=theta(j)-thetaref(j,iref)
3471 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3472           theta_diff(k)=thetatpl(k,i)-theta(i)
3473 c
3474           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3475 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3476           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3477           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3478 c         Gradient for single Gaussian restraint in subr Econstr_back
3479 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3480 c
3481         enddo
3482 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3483 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3484
3485 c
3486 #ifdef GRAD
3487 c         Gradient for multiple Gaussian restraint
3488         sum_gtheta=gutheta_i
3489         sum_sgtheta=0.0d0
3490         do k=1,constr_homology
3491 c        New generalized expr for multiple Gaussian from Econstr_back
3492          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3493 c
3494 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3495           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3496         enddo
3497 c
3498 c       Final value of gradient using same var as in Econstr_back
3499         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3500      &               *waga_homology(iset)
3501 c       dutheta(i)=sum_sgtheta/sum_gtheta
3502 c
3503 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3504 #endif
3505         Eval=Eval-dLOG(gutheta_i/constr_homology)
3506 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3507 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3508 c       Uconst_back=Uconst_back+utheta(i)
3509       enddo ! (i-loop for theta)
3510 #ifdef DEBUG
3511       write(iout,*) "------- theta restrs end -------"
3512 #endif
3513       endif
3514 c
3515 c Deviation of local SC geometry
3516 c
3517 c Separation of two i-loops (instructed by AL - 11/3/2014)
3518 c
3519 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3520 c     write (iout,*) "waga_d",waga_d
3521
3522 #ifdef DEBUG
3523       write(iout,*) "------- SC restrs start -------"
3524       write (iout,*) "Initial duscdiff,duscdiffx"
3525       do i=loc_start,loc_end
3526         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3527      &                 (duscdiffx(jik,i),jik=1,3)
3528       enddo
3529 #endif
3530       do i=loc_start,loc_end
3531         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3532 #ifdef OLDRESTR
3533         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3534 #else
3535         guscdiff(i)=nexl
3536 #endif
3537 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3538 c       write(iout,*) "xxtab, yytab, zztab"
3539 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3540         do k=1,constr_homology
3541 c
3542           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3543 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3544           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3545           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3546 c         write(iout,*) "dxx, dyy, dzz"
3547 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3548 c
3549           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3550 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3551 c         uscdiffk(k)=usc_diff(i)
3552           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3553           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3554 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3555 c     &      xxref(j),yyref(j),zzref(j)
3556         enddo
3557 c
3558 c       Gradient
3559 c
3560 c       Generalized expression for multiple Gaussian acc to that for a single
3561 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3562 c
3563 c       Original implementation
3564 c       sum_guscdiff=guscdiff(i)
3565 c
3566 c       sum_sguscdiff=0.0d0
3567 c       do k=1,constr_homology
3568 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3569 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3570 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3571 c       enddo
3572 c
3573 c       Implementation of new expressions for gradient (Jan. 2015)
3574 c
3575 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3576 #ifdef GRAD
3577         do k=1,constr_homology
3578 c
3579 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3580 c       before. Now the drivatives should be correct
3581 c
3582           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3583 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3584           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3585           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3586 c
3587 c         New implementation
3588 c
3589           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3590      &                 sigma_d(k,i) ! for the grad wrt r'
3591 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3592 c
3593 c
3594 c        New implementation
3595          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3596          do jik=1,3
3597             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3598      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3599      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3600             duscdiff(jik,i)=duscdiff(jik,i)+
3601      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3602      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3603             duscdiffx(jik,i)=duscdiffx(jik,i)+
3604      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3605      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3606 c
3607 #ifdef DEBUG
3608              write(iout,*) "jik",jik,"i",i
3609              write(iout,*) "dxx, dyy, dzz"
3610              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3611              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3612 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3613 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3614 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3615 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3616 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3617 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3618 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3619 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3620 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3621 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3622 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3623 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3624 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3625 c            endif
3626 #endif
3627          enddo
3628         enddo
3629 #endif
3630 c
3631 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3632 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3633 c
3634 c        write (iout,*) i," uscdiff",uscdiff(i)
3635 c
3636 c Put together deviations from local geometry
3637
3638 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3639 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3640         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3641 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3642 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3643 c       Uconst_back=Uconst_back+usc_diff(i)
3644 c
3645 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3646 c
3647 c     New implment: multiplied by sum_sguscdiff
3648 c
3649
3650       enddo ! (i-loop for dscdiff)
3651
3652 c      endif
3653
3654 #ifdef DEBUG
3655       write(iout,*) "------- SC restrs end -------"
3656         write (iout,*) "------ After SC loop in e_modeller ------"
3657         do i=loc_start,loc_end
3658          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3659          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3660         enddo
3661       if (waga_theta.eq.1.0d0) then
3662       write (iout,*) "in e_modeller after SC restr end: dutheta"
3663       do i=ithet_start,ithet_end
3664         write (iout,*) i,dutheta(i)
3665       enddo
3666       endif
3667       if (waga_d.eq.1.0d0) then
3668       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3669       do i=1,nres
3670         write (iout,*) i,(duscdiff(j,i),j=1,3)
3671         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3672       enddo
3673       endif
3674 #endif
3675
3676 c Total energy from homology restraints
3677 #ifdef DEBUG
3678       write (iout,*) "odleg",odleg," kat",kat
3679       write (iout,*) "odleg",odleg," kat",kat
3680       write (iout,*) "Eval",Eval," Erot",Erot
3681       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3682       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3683       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3684       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3685 #endif
3686 c
3687 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3688 c
3689 c     ehomology_constr=odleg+kat
3690 c
3691 c     For Lorentzian-type Urestr
3692 c
3693
3694       if (waga_dist.ge.0.0d0) then
3695 c
3696 c          For Gaussian-type Urestr
3697 c
3698         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3699      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3700 c     write (iout,*) "ehomology_constr=",ehomology_constr
3701       else
3702 c
3703 c          For Lorentzian-type Urestr
3704 c
3705         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3706      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3707 c     write (iout,*) "ehomology_constr=",ehomology_constr
3708       endif
3709 #ifdef DEBUG
3710       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
3711       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3712      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
3713       write (iout,*) "ehomology_constr",ehomology_constr
3714 #endif
3715       return
3716
3717   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3718   747 format(a12,i4,i4,i4,f8.3,f8.3)
3719   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3720   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3721   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3722      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3723       end
3724 C--------------------------------------------------------------------------
3725       subroutine ebond(estr)
3726 c
3727 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3728 c
3729       implicit real*8 (a-h,o-z)
3730       include 'DIMENSIONS'
3731       include 'COMMON.LOCAL'
3732       include 'COMMON.GEO'
3733       include 'COMMON.INTERACT'
3734       include 'COMMON.DERIV'
3735       include 'COMMON.VAR'
3736       include 'COMMON.CHAIN'
3737       include 'COMMON.IOUNITS'
3738       include 'COMMON.NAMES'
3739       include 'COMMON.FFIELD'
3740       include 'COMMON.CONTROL'
3741       double precision u(3),ud(3)
3742       estr=0.0d0
3743       do i=nnt+1,nct
3744         diff = vbld(i)-vbldp0
3745 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3746         estr=estr+diff*diff
3747         do j=1,3
3748           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3749         enddo
3750       enddo
3751       estr=0.5d0*AKP*estr
3752 c
3753 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3754 c
3755       do i=nnt,nct
3756         iti=itype(i)
3757         if (iti.ne.10) then
3758           nbi=nbondterm(iti)
3759           if (nbi.eq.1) then
3760             diff=vbld(i+nres)-vbldsc0(1,iti)
3761 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3762 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3763             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3764             do j=1,3
3765               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3766             enddo
3767           else
3768             do j=1,nbi
3769               diff=vbld(i+nres)-vbldsc0(j,iti)
3770               ud(j)=aksc(j,iti)*diff
3771               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3772             enddo
3773             uprod=u(1)
3774             do j=2,nbi
3775               uprod=uprod*u(j)
3776             enddo
3777             usum=0.0d0
3778             usumsqder=0.0d0
3779             do j=1,nbi
3780               uprod1=1.0d0
3781               uprod2=1.0d0
3782               do k=1,nbi
3783                 if (k.ne.j) then
3784                   uprod1=uprod1*u(k)
3785                   uprod2=uprod2*u(k)*u(k)
3786                 endif
3787               enddo
3788               usum=usum+uprod1
3789               usumsqder=usumsqder+ud(j)*uprod2
3790             enddo
3791 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3792 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3793             estr=estr+uprod/usum
3794             do j=1,3
3795              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3796             enddo
3797           endif
3798         endif
3799       enddo
3800       return
3801       end
3802 #ifdef CRYST_THETA
3803 C--------------------------------------------------------------------------
3804       subroutine ebend(etheta)
3805 C
3806 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3807 C angles gamma and its derivatives in consecutive thetas and gammas.
3808 C
3809       implicit real*8 (a-h,o-z)
3810       include 'DIMENSIONS'
3811       include 'sizesclu.dat'
3812       include 'COMMON.LOCAL'
3813       include 'COMMON.GEO'
3814       include 'COMMON.INTERACT'
3815       include 'COMMON.DERIV'
3816       include 'COMMON.VAR'
3817       include 'COMMON.CHAIN'
3818       include 'COMMON.IOUNITS'
3819       include 'COMMON.NAMES'
3820       include 'COMMON.FFIELD'
3821       common /calcthet/ term1,term2,termm,diffak,ratak,
3822      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3823      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3824       double precision y(2),z(2)
3825       delta=0.02d0*pi
3826       time11=dexp(-2*time)
3827       time12=1.0d0
3828       etheta=0.0D0
3829 c      write (iout,*) "nres",nres
3830 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3831 c      write (iout,*) ithet_start,ithet_end
3832       do i=ithet_start,ithet_end
3833 C Zero the energy function and its derivative at 0 or pi.
3834         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3835         it=itype(i-1)
3836 c        if (i.gt.ithet_start .and.
3837 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3838 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3839 c          phii=phi(i)
3840 c          y(1)=dcos(phii)
3841 c          y(2)=dsin(phii)
3842 c        else
3843 c          y(1)=0.0D0
3844 c          y(2)=0.0D0
3845 c        endif
3846 c        if (i.lt.nres .and. itel(i).ne.0) then
3847 c          phii1=phi(i+1)
3848 c          z(1)=dcos(phii1)
3849 c          z(2)=dsin(phii1)
3850 c        else
3851 c          z(1)=0.0D0
3852 c          z(2)=0.0D0
3853 c        endif
3854         if (i.gt.3) then
3855 #ifdef OSF
3856           phii=phi(i)
3857           icrc=0
3858           call proc_proc(phii,icrc)
3859           if (icrc.eq.1) phii=150.0
3860 #else
3861           phii=phi(i)
3862 #endif
3863           y(1)=dcos(phii)
3864           y(2)=dsin(phii)
3865         else
3866           y(1)=0.0D0
3867           y(2)=0.0D0
3868         endif
3869         if (i.lt.nres) then
3870 #ifdef OSF
3871           phii1=phi(i+1)
3872           icrc=0
3873           call proc_proc(phii1,icrc)
3874           if (icrc.eq.1) phii1=150.0
3875           phii1=pinorm(phii1)
3876           z(1)=cos(phii1)
3877 #else
3878           phii1=phi(i+1)
3879           z(1)=dcos(phii1)
3880 #endif
3881           z(2)=dsin(phii1)
3882         else
3883           z(1)=0.0D0
3884           z(2)=0.0D0
3885         endif
3886 C Calculate the "mean" value of theta from the part of the distribution
3887 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3888 C In following comments this theta will be referred to as t_c.
3889         thet_pred_mean=0.0d0
3890         do k=1,2
3891           athetk=athet(k,it)
3892           bthetk=bthet(k,it)
3893           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3894         enddo
3895 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3896         dthett=thet_pred_mean*ssd
3897         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3898 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3899 C Derivatives of the "mean" values in gamma1 and gamma2.
3900         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3901         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3902         if (theta(i).gt.pi-delta) then
3903           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3904      &         E_tc0)
3905           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3906           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3907           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3908      &        E_theta)
3909           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3910      &        E_tc)
3911         else if (theta(i).lt.delta) then
3912           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3913           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3914           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3915      &        E_theta)
3916           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3917           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3918      &        E_tc)
3919         else
3920           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3921      &        E_theta,E_tc)
3922         endif
3923         etheta=etheta+ethetai
3924 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3925 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3926         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3927         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3928         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3929  1215   continue
3930       enddo
3931 C Ufff.... We've done all this!!!
3932       return
3933       end
3934 C---------------------------------------------------------------------------
3935       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3936      &     E_tc)
3937       implicit real*8 (a-h,o-z)
3938       include 'DIMENSIONS'
3939       include 'COMMON.LOCAL'
3940       include 'COMMON.IOUNITS'
3941       common /calcthet/ term1,term2,termm,diffak,ratak,
3942      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3943      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3944 C Calculate the contributions to both Gaussian lobes.
3945 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3946 C The "polynomial part" of the "standard deviation" of this part of
3947 C the distribution.
3948         sig=polthet(3,it)
3949         do j=2,0,-1
3950           sig=sig*thet_pred_mean+polthet(j,it)
3951         enddo
3952 C Derivative of the "interior part" of the "standard deviation of the"
3953 C gamma-dependent Gaussian lobe in t_c.
3954         sigtc=3*polthet(3,it)
3955         do j=2,1,-1
3956           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3957         enddo
3958         sigtc=sig*sigtc
3959 C Set the parameters of both Gaussian lobes of the distribution.
3960 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3961         fac=sig*sig+sigc0(it)
3962         sigcsq=fac+fac
3963         sigc=1.0D0/sigcsq
3964 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3965         sigsqtc=-4.0D0*sigcsq*sigtc
3966 c       print *,i,sig,sigtc,sigsqtc
3967 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3968         sigtc=-sigtc/(fac*fac)
3969 C Following variable is sigma(t_c)**(-2)
3970         sigcsq=sigcsq*sigcsq
3971         sig0i=sig0(it)
3972         sig0inv=1.0D0/sig0i**2
3973         delthec=thetai-thet_pred_mean
3974         delthe0=thetai-theta0i
3975         term1=-0.5D0*sigcsq*delthec*delthec
3976         term2=-0.5D0*sig0inv*delthe0*delthe0
3977 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3978 C NaNs in taking the logarithm. We extract the largest exponent which is added
3979 C to the energy (this being the log of the distribution) at the end of energy
3980 C term evaluation for this virtual-bond angle.
3981         if (term1.gt.term2) then
3982           termm=term1
3983           term2=dexp(term2-termm)
3984           term1=1.0d0
3985         else
3986           termm=term2
3987           term1=dexp(term1-termm)
3988           term2=1.0d0
3989         endif
3990 C The ratio between the gamma-independent and gamma-dependent lobes of
3991 C the distribution is a Gaussian function of thet_pred_mean too.
3992         diffak=gthet(2,it)-thet_pred_mean
3993         ratak=diffak/gthet(3,it)**2
3994         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3995 C Let's differentiate it in thet_pred_mean NOW.
3996         aktc=ak*ratak
3997 C Now put together the distribution terms to make complete distribution.
3998         termexp=term1+ak*term2
3999         termpre=sigc+ak*sig0i
4000 C Contribution of the bending energy from this theta is just the -log of
4001 C the sum of the contributions from the two lobes and the pre-exponential
4002 C factor. Simple enough, isn't it?
4003         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4004 C NOW the derivatives!!!
4005 C 6/6/97 Take into account the deformation.
4006         E_theta=(delthec*sigcsq*term1
4007      &       +ak*delthe0*sig0inv*term2)/termexp
4008         E_tc=((sigtc+aktc*sig0i)/termpre
4009      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4010      &       aktc*term2)/termexp)
4011       return
4012       end
4013 c-----------------------------------------------------------------------------
4014       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4015       implicit real*8 (a-h,o-z)
4016       include 'DIMENSIONS'
4017       include 'COMMON.LOCAL'
4018       include 'COMMON.IOUNITS'
4019       common /calcthet/ term1,term2,termm,diffak,ratak,
4020      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4021      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4022       delthec=thetai-thet_pred_mean
4023       delthe0=thetai-theta0i
4024 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4025       t3 = thetai-thet_pred_mean
4026       t6 = t3**2
4027       t9 = term1
4028       t12 = t3*sigcsq
4029       t14 = t12+t6*sigsqtc
4030       t16 = 1.0d0
4031       t21 = thetai-theta0i
4032       t23 = t21**2
4033       t26 = term2
4034       t27 = t21*t26
4035       t32 = termexp
4036       t40 = t32**2
4037       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4038      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4039      & *(-t12*t9-ak*sig0inv*t27)
4040       return
4041       end
4042 #else
4043 C--------------------------------------------------------------------------
4044       subroutine ebend(etheta)
4045 C
4046 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4047 C angles gamma and its derivatives in consecutive thetas and gammas.
4048 C ab initio-derived potentials from
4049 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4050 C
4051       implicit real*8 (a-h,o-z)
4052       include 'DIMENSIONS'
4053       include 'COMMON.LOCAL'
4054       include 'COMMON.GEO'
4055       include 'COMMON.INTERACT'
4056       include 'COMMON.DERIV'
4057       include 'COMMON.VAR'
4058       include 'COMMON.CHAIN'
4059       include 'COMMON.IOUNITS'
4060       include 'COMMON.NAMES'
4061       include 'COMMON.FFIELD'
4062       include 'COMMON.CONTROL'
4063       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4064      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4065      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4066      & sinph1ph2(maxdouble,maxdouble)
4067       logical lprn /.false./, lprn1 /.false./
4068       etheta=0.0D0
4069       do i=ithet_start,ithet_end
4070         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4071      &    (itype(i).eq.ntyp1)) cycle
4072         dethetai=0.0d0
4073         dephii=0.0d0
4074         dephii1=0.0d0
4075         theti2=0.5d0*theta(i)
4076         ityp2=ithetyp(itype(i-1))
4077         do k=1,nntheterm
4078           coskt(k)=dcos(k*theti2)
4079           sinkt(k)=dsin(k*theti2)
4080         enddo
4081         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4082 #ifdef OSF
4083           phii=phi(i)
4084           if (phii.ne.phii) phii=150.0
4085 #else
4086           phii=phi(i)
4087 #endif
4088           ityp1=ithetyp(itype(i-2))
4089           do k=1,nsingle
4090             cosph1(k)=dcos(k*phii)
4091             sinph1(k)=dsin(k*phii)
4092           enddo
4093         else
4094           phii=0.0d0
4095           ityp1=ithetyp(itype(i-2))
4096           do k=1,nsingle
4097             cosph1(k)=0.0d0
4098             sinph1(k)=0.0d0
4099           enddo
4100         endif
4101         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4102 #ifdef OSF
4103           phii1=phi(i+1)
4104           if (phii1.ne.phii1) phii1=150.0
4105           phii1=pinorm(phii1)
4106 #else
4107           phii1=phi(i+1)
4108 #endif
4109           ityp3=ithetyp(itype(i))
4110           do k=1,nsingle
4111             cosph2(k)=dcos(k*phii1)
4112             sinph2(k)=dsin(k*phii1)
4113           enddo
4114         else
4115           phii1=0.0d0
4116           ityp3=ithetyp(itype(i))
4117           do k=1,nsingle
4118             cosph2(k)=0.0d0
4119             sinph2(k)=0.0d0
4120           enddo
4121         endif
4122 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4123 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4124 c        call flush(iout)
4125         ethetai=aa0thet(ityp1,ityp2,ityp3)
4126         do k=1,ndouble
4127           do l=1,k-1
4128             ccl=cosph1(l)*cosph2(k-l)
4129             ssl=sinph1(l)*sinph2(k-l)
4130             scl=sinph1(l)*cosph2(k-l)
4131             csl=cosph1(l)*sinph2(k-l)
4132             cosph1ph2(l,k)=ccl-ssl
4133             cosph1ph2(k,l)=ccl+ssl
4134             sinph1ph2(l,k)=scl+csl
4135             sinph1ph2(k,l)=scl-csl
4136           enddo
4137         enddo
4138         if (lprn) then
4139         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4140      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4141         write (iout,*) "coskt and sinkt"
4142         do k=1,nntheterm
4143           write (iout,*) k,coskt(k),sinkt(k)
4144         enddo
4145         endif
4146         do k=1,ntheterm
4147           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4148           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4149      &      *coskt(k)
4150           if (lprn)
4151      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4152      &     " ethetai",ethetai
4153         enddo
4154         if (lprn) then
4155         write (iout,*) "cosph and sinph"
4156         do k=1,nsingle
4157           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4158         enddo
4159         write (iout,*) "cosph1ph2 and sinph2ph2"
4160         do k=2,ndouble
4161           do l=1,k-1
4162             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4163      &         sinph1ph2(l,k),sinph1ph2(k,l)
4164           enddo
4165         enddo
4166         write(iout,*) "ethetai",ethetai
4167         endif
4168         do m=1,ntheterm2
4169           do k=1,nsingle
4170             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4171      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4172      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4173      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4174             ethetai=ethetai+sinkt(m)*aux
4175             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4176             dephii=dephii+k*sinkt(m)*(
4177      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4178      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4179             dephii1=dephii1+k*sinkt(m)*(
4180      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4181      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4182             if (lprn)
4183      &      write (iout,*) "m",m," k",k," bbthet",
4184      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4185      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4186      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4187      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4188           enddo
4189         enddo
4190         if (lprn)
4191      &  write(iout,*) "ethetai",ethetai
4192         do m=1,ntheterm3
4193           do k=2,ndouble
4194             do l=1,k-1
4195               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4196      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4197      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4198      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4199               ethetai=ethetai+sinkt(m)*aux
4200               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4201               dephii=dephii+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               dephii1=dephii1+(k-l)*sinkt(m)*(
4207      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4208      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4209      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4210      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4211               if (lprn) then
4212               write (iout,*) "m",m," k",k," l",l," ffthet",
4213      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4214      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4215      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4216      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4217               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4218      &            cosph1ph2(k,l)*sinkt(m),
4219      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4220               endif
4221             enddo
4222           enddo
4223         enddo
4224 10      continue
4225 c        lprn1=.true.
4226         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4227      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4228      &   phii1*rad2deg,ethetai
4229 c        lprn1=.false.
4230         etheta=etheta+ethetai
4231
4232         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4233         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4234         gloc(nphi+i-2,icg)=wang*dethetai
4235       enddo
4236       return
4237       end
4238 #endif
4239 #ifdef CRYST_SC
4240 c-----------------------------------------------------------------------------
4241       subroutine esc(escloc)
4242 C Calculate the local energy of a side chain and its derivatives in the
4243 C corresponding virtual-bond valence angles THETA and the spherical angles
4244 C ALPHA and OMEGA.
4245       implicit real*8 (a-h,o-z)
4246       include 'DIMENSIONS'
4247       include 'sizesclu.dat'
4248       include 'COMMON.GEO'
4249       include 'COMMON.LOCAL'
4250       include 'COMMON.VAR'
4251       include 'COMMON.INTERACT'
4252       include 'COMMON.DERIV'
4253       include 'COMMON.CHAIN'
4254       include 'COMMON.IOUNITS'
4255       include 'COMMON.NAMES'
4256       include 'COMMON.FFIELD'
4257       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4258      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4259       common /sccalc/ time11,time12,time112,theti,it,nlobit
4260       delta=0.02d0*pi
4261       escloc=0.0D0
4262 c     write (iout,'(a)') 'ESC'
4263       do i=loc_start,loc_end
4264         it=itype(i)
4265         if (it.eq.10) goto 1
4266         nlobit=nlob(it)
4267 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4268 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4269         theti=theta(i+1)-pipol
4270         x(1)=dtan(theti)
4271         x(2)=alph(i)
4272         x(3)=omeg(i)
4273 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4274
4275         if (x(2).gt.pi-delta) then
4276           xtemp(1)=x(1)
4277           xtemp(2)=pi-delta
4278           xtemp(3)=x(3)
4279           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4280           xtemp(2)=pi
4281           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4282           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4283      &        escloci,dersc(2))
4284           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4285      &        ddersc0(1),dersc(1))
4286           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4287      &        ddersc0(3),dersc(3))
4288           xtemp(2)=pi-delta
4289           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4290           xtemp(2)=pi
4291           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4292           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4293      &            dersc0(2),esclocbi,dersc02)
4294           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4295      &            dersc12,dersc01)
4296           call splinthet(x(2),0.5d0*delta,ss,ssd)
4297           dersc0(1)=dersc01
4298           dersc0(2)=dersc02
4299           dersc0(3)=0.0d0
4300           do k=1,3
4301             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4302           enddo
4303           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4304 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4305 c    &             esclocbi,ss,ssd
4306           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4307 c         escloci=esclocbi
4308 c         write (iout,*) escloci
4309         else if (x(2).lt.delta) then
4310           xtemp(1)=x(1)
4311           xtemp(2)=delta
4312           xtemp(3)=x(3)
4313           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4314           xtemp(2)=0.0d0
4315           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4316           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4317      &        escloci,dersc(2))
4318           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4319      &        ddersc0(1),dersc(1))
4320           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4321      &        ddersc0(3),dersc(3))
4322           xtemp(2)=delta
4323           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4324           xtemp(2)=0.0d0
4325           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4326           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4327      &            dersc0(2),esclocbi,dersc02)
4328           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4329      &            dersc12,dersc01)
4330           dersc0(1)=dersc01
4331           dersc0(2)=dersc02
4332           dersc0(3)=0.0d0
4333           call splinthet(x(2),0.5d0*delta,ss,ssd)
4334           do k=1,3
4335             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4336           enddo
4337           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4338 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4339 c    &             esclocbi,ss,ssd
4340           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4341 c         write (iout,*) escloci
4342         else
4343           call enesc(x,escloci,dersc,ddummy,.false.)
4344         endif
4345
4346         escloc=escloc+escloci
4347 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4348
4349         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4350      &   wscloc*dersc(1)
4351         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4352         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4353     1   continue
4354       enddo
4355       return
4356       end
4357 C---------------------------------------------------------------------------
4358       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4359       implicit real*8 (a-h,o-z)
4360       include 'DIMENSIONS'
4361       include 'COMMON.GEO'
4362       include 'COMMON.LOCAL'
4363       include 'COMMON.IOUNITS'
4364       common /sccalc/ time11,time12,time112,theti,it,nlobit
4365       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4366       double precision contr(maxlob,-1:1)
4367       logical mixed
4368 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4369         escloc_i=0.0D0
4370         do j=1,3
4371           dersc(j)=0.0D0
4372           if (mixed) ddersc(j)=0.0d0
4373         enddo
4374         x3=x(3)
4375
4376 C Because of periodicity of the dependence of the SC energy in omega we have
4377 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4378 C To avoid underflows, first compute & store the exponents.
4379
4380         do iii=-1,1
4381
4382           x(3)=x3+iii*dwapi
4383
4384           do j=1,nlobit
4385             do k=1,3
4386               z(k)=x(k)-censc(k,j,it)
4387             enddo
4388             do k=1,3
4389               Axk=0.0D0
4390               do l=1,3
4391                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4392               enddo
4393               Ax(k,j,iii)=Axk
4394             enddo
4395             expfac=0.0D0
4396             do k=1,3
4397               expfac=expfac+Ax(k,j,iii)*z(k)
4398             enddo
4399             contr(j,iii)=expfac
4400           enddo ! j
4401
4402         enddo ! iii
4403
4404         x(3)=x3
4405 C As in the case of ebend, we want to avoid underflows in exponentiation and
4406 C subsequent NaNs and INFs in energy calculation.
4407 C Find the largest exponent
4408         emin=contr(1,-1)
4409         do iii=-1,1
4410           do j=1,nlobit
4411             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4412           enddo
4413         enddo
4414         emin=0.5D0*emin
4415 cd      print *,'it=',it,' emin=',emin
4416
4417 C Compute the contribution to SC energy and derivatives
4418         do iii=-1,1
4419
4420           do j=1,nlobit
4421             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4422 cd          print *,'j=',j,' expfac=',expfac
4423             escloc_i=escloc_i+expfac
4424             do k=1,3
4425               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4426             enddo
4427             if (mixed) then
4428               do k=1,3,2
4429                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4430      &            +gaussc(k,2,j,it))*expfac
4431               enddo
4432             endif
4433           enddo
4434
4435         enddo ! iii
4436
4437         dersc(1)=dersc(1)/cos(theti)**2
4438         ddersc(1)=ddersc(1)/cos(theti)**2
4439         ddersc(3)=ddersc(3)
4440
4441         escloci=-(dlog(escloc_i)-emin)
4442         do j=1,3
4443           dersc(j)=dersc(j)/escloc_i
4444         enddo
4445         if (mixed) then
4446           do j=1,3,2
4447             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4448           enddo
4449         endif
4450       return
4451       end
4452 C------------------------------------------------------------------------------
4453       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4454       implicit real*8 (a-h,o-z)
4455       include 'DIMENSIONS'
4456       include 'COMMON.GEO'
4457       include 'COMMON.LOCAL'
4458       include 'COMMON.IOUNITS'
4459       common /sccalc/ time11,time12,time112,theti,it,nlobit
4460       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4461       double precision contr(maxlob)
4462       logical mixed
4463
4464       escloc_i=0.0D0
4465
4466       do j=1,3
4467         dersc(j)=0.0D0
4468       enddo
4469
4470       do j=1,nlobit
4471         do k=1,2
4472           z(k)=x(k)-censc(k,j,it)
4473         enddo
4474         z(3)=dwapi
4475         do k=1,3
4476           Axk=0.0D0
4477           do l=1,3
4478             Axk=Axk+gaussc(l,k,j,it)*z(l)
4479           enddo
4480           Ax(k,j)=Axk
4481         enddo
4482         expfac=0.0D0
4483         do k=1,3
4484           expfac=expfac+Ax(k,j)*z(k)
4485         enddo
4486         contr(j)=expfac
4487       enddo ! j
4488
4489 C As in the case of ebend, we want to avoid underflows in exponentiation and
4490 C subsequent NaNs and INFs in energy calculation.
4491 C Find the largest exponent
4492       emin=contr(1)
4493       do j=1,nlobit
4494         if (emin.gt.contr(j)) emin=contr(j)
4495       enddo
4496       emin=0.5D0*emin
4497
4498 C Compute the contribution to SC energy and derivatives
4499
4500       dersc12=0.0d0
4501       do j=1,nlobit
4502         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4503         escloc_i=escloc_i+expfac
4504         do k=1,2
4505           dersc(k)=dersc(k)+Ax(k,j)*expfac
4506         enddo
4507         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4508      &            +gaussc(1,2,j,it))*expfac
4509         dersc(3)=0.0d0
4510       enddo
4511
4512       dersc(1)=dersc(1)/cos(theti)**2
4513       dersc12=dersc12/cos(theti)**2
4514       escloci=-(dlog(escloc_i)-emin)
4515       do j=1,2
4516         dersc(j)=dersc(j)/escloc_i
4517       enddo
4518       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4519       return
4520       end
4521 #else
4522 c----------------------------------------------------------------------------------
4523       subroutine esc(escloc)
4524 C Calculate the local energy of a side chain and its derivatives in the
4525 C corresponding virtual-bond valence angles THETA and the spherical angles
4526 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4527 C added by Urszula Kozlowska. 07/11/2007
4528 C
4529       implicit real*8 (a-h,o-z)
4530       include 'DIMENSIONS'
4531       include 'COMMON.GEO'
4532       include 'COMMON.LOCAL'
4533       include 'COMMON.VAR'
4534       include 'COMMON.SCROT'
4535       include 'COMMON.INTERACT'
4536       include 'COMMON.DERIV'
4537       include 'COMMON.CHAIN'
4538       include 'COMMON.IOUNITS'
4539       include 'COMMON.NAMES'
4540       include 'COMMON.FFIELD'
4541       include 'COMMON.CONTROL'
4542       include 'COMMON.VECTORS'
4543       double precision x_prime(3),y_prime(3),z_prime(3)
4544      &    , sumene,dsc_i,dp2_i,x(65),
4545      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4546      &    de_dxx,de_dyy,de_dzz,de_dt
4547       double precision s1_t,s1_6_t,s2_t,s2_6_t
4548       double precision
4549      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4550      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4551      & dt_dCi(3),dt_dCi1(3)
4552       common /sccalc/ time11,time12,time112,theti,it,nlobit
4553       delta=0.02d0*pi
4554       escloc=0.0D0
4555       do i=loc_start,loc_end
4556         costtab(i+1) =dcos(theta(i+1))
4557         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4558         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4559         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4560         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4561         cosfac=dsqrt(cosfac2)
4562         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4563         sinfac=dsqrt(sinfac2)
4564         it=itype(i)
4565         if (it.eq.10) goto 1
4566 c
4567 C  Compute the axes of tghe local cartesian coordinates system; store in
4568 c   x_prime, y_prime and z_prime
4569 c
4570         do j=1,3
4571           x_prime(j) = 0.00
4572           y_prime(j) = 0.00
4573           z_prime(j) = 0.00
4574         enddo
4575 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4576 C     &   dc_norm(3,i+nres)
4577         do j = 1,3
4578           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4579           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4580         enddo
4581         do j = 1,3
4582           z_prime(j) = -uz(j,i-1)
4583         enddo
4584 c       write (2,*) "i",i
4585 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4586 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4587 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4588 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4589 c      & " xy",scalar(x_prime(1),y_prime(1)),
4590 c      & " xz",scalar(x_prime(1),z_prime(1)),
4591 c      & " yy",scalar(y_prime(1),y_prime(1)),
4592 c      & " yz",scalar(y_prime(1),z_prime(1)),
4593 c      & " zz",scalar(z_prime(1),z_prime(1))
4594 c
4595 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4596 C to local coordinate system. Store in xx, yy, zz.
4597 c
4598         xx=0.0d0
4599         yy=0.0d0
4600         zz=0.0d0
4601         do j = 1,3
4602           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4603           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4604           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4605         enddo
4606
4607         xxtab(i)=xx
4608         yytab(i)=yy
4609         zztab(i)=zz
4610 C
4611 C Compute the energy of the ith side cbain
4612 C
4613 c        write (2,*) "xx",xx," yy",yy," zz",zz
4614         it=itype(i)
4615         do j = 1,65
4616           x(j) = sc_parmin(j,it)
4617         enddo
4618 #ifdef CHECK_COORD
4619 Cc diagnostics - remove later
4620         xx1 = dcos(alph(2))
4621         yy1 = dsin(alph(2))*dcos(omeg(2))
4622         zz1 = -dsin(alph(2))*dsin(omeg(2))
4623         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4624      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4625      &    xx1,yy1,zz1
4626 C,"  --- ", xx_w,yy_w,zz_w
4627 c end diagnostics
4628 #endif
4629         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4630      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4631      &   + x(10)*yy*zz
4632         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4633      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4634      & + x(20)*yy*zz
4635         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4636      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4637      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4638      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4639      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4640      &  +x(40)*xx*yy*zz
4641         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4642      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4643      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4644      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4645      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4646      &  +x(60)*xx*yy*zz
4647         dsc_i   = 0.743d0+x(61)
4648         dp2_i   = 1.9d0+x(62)
4649         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4650      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4651         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4652      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4653         s1=(1+x(63))/(0.1d0 + dscp1)
4654         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4655         s2=(1+x(65))/(0.1d0 + dscp2)
4656         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4657         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4658      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4659 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4660 c     &   sumene4,
4661 c     &   dscp1,dscp2,sumene
4662 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4663         escloc = escloc + sumene
4664 c        write (2,*) "escloc",escloc
4665         if (.not. calc_grad) goto 1
4666 #ifdef DEBUG
4667 C
4668 C This section to check the numerical derivatives of the energy of ith side
4669 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4670 C #define DEBUG in the code to turn it on.
4671 C
4672         write (2,*) "sumene               =",sumene
4673         aincr=1.0d-7
4674         xxsave=xx
4675         xx=xx+aincr
4676         write (2,*) xx,yy,zz
4677         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4678         de_dxx_num=(sumenep-sumene)/aincr
4679         xx=xxsave
4680         write (2,*) "xx+ sumene from enesc=",sumenep
4681         yysave=yy
4682         yy=yy+aincr
4683         write (2,*) xx,yy,zz
4684         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4685         de_dyy_num=(sumenep-sumene)/aincr
4686         yy=yysave
4687         write (2,*) "yy+ sumene from enesc=",sumenep
4688         zzsave=zz
4689         zz=zz+aincr
4690         write (2,*) xx,yy,zz
4691         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4692         de_dzz_num=(sumenep-sumene)/aincr
4693         zz=zzsave
4694         write (2,*) "zz+ sumene from enesc=",sumenep
4695         costsave=cost2tab(i+1)
4696         sintsave=sint2tab(i+1)
4697         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4698         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4699         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4700         de_dt_num=(sumenep-sumene)/aincr
4701         write (2,*) " t+ sumene from enesc=",sumenep
4702         cost2tab(i+1)=costsave
4703         sint2tab(i+1)=sintsave
4704 C End of diagnostics section.
4705 #endif
4706 C
4707 C Compute the gradient of esc
4708 C
4709         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4710         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4711         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4712         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4713         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4714         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4715         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4716         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4717         pom1=(sumene3*sint2tab(i+1)+sumene1)
4718      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4719         pom2=(sumene4*cost2tab(i+1)+sumene2)
4720      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4721         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4722         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4723      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4724      &  +x(40)*yy*zz
4725         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4726         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4727      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4728      &  +x(60)*yy*zz
4729         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4730      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4731      &        +(pom1+pom2)*pom_dx
4732 #ifdef DEBUG
4733         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4734 #endif
4735 C
4736         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4737         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4738      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4739      &  +x(40)*xx*zz
4740         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4741         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4742      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4743      &  +x(59)*zz**2 +x(60)*xx*zz
4744         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4745      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4746      &        +(pom1-pom2)*pom_dy
4747 #ifdef DEBUG
4748         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4749 #endif
4750 C
4751         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4752      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4753      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4754      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4755      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4756      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4757      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4758      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4759 #ifdef DEBUG
4760         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4761 #endif
4762 C
4763         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4764      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4765      &  +pom1*pom_dt1+pom2*pom_dt2
4766 #ifdef DEBUG
4767         write(2,*), "de_dt = ", de_dt,de_dt_num
4768 #endif
4769 c
4770 C
4771        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4772        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4773        cosfac2xx=cosfac2*xx
4774        sinfac2yy=sinfac2*yy
4775        do k = 1,3
4776          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4777      &      vbld_inv(i+1)
4778          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4779      &      vbld_inv(i)
4780          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4781          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4782 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4783 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4784 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4785 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4786          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4787          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4788          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4789          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4790          dZZ_Ci1(k)=0.0d0
4791          dZZ_Ci(k)=0.0d0
4792          do j=1,3
4793            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4794            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4795          enddo
4796
4797          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4798          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4799          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4800 c
4801          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4802          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4803        enddo
4804
4805        do k=1,3
4806          dXX_Ctab(k,i)=dXX_Ci(k)
4807          dXX_C1tab(k,i)=dXX_Ci1(k)
4808          dYY_Ctab(k,i)=dYY_Ci(k)
4809          dYY_C1tab(k,i)=dYY_Ci1(k)
4810          dZZ_Ctab(k,i)=dZZ_Ci(k)
4811          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4812          dXX_XYZtab(k,i)=dXX_XYZ(k)
4813          dYY_XYZtab(k,i)=dYY_XYZ(k)
4814          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4815        enddo
4816
4817        do k = 1,3
4818 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4819 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4820 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4821 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4822 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4823 c     &    dt_dci(k)
4824 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4825 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4826          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4827      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4828          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4829      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4830          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4831      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4832        enddo
4833 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4834 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4835
4836 C to check gradient call subroutine check_grad
4837
4838     1 continue
4839       enddo
4840       return
4841       end
4842 #endif
4843 c------------------------------------------------------------------------------
4844       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4845 C
4846 C This procedure calculates two-body contact function g(rij) and its derivative:
4847 C
4848 C           eps0ij                                     !       x < -1
4849 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4850 C            0                                         !       x > 1
4851 C
4852 C where x=(rij-r0ij)/delta
4853 C
4854 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4855 C
4856       implicit none
4857       double precision rij,r0ij,eps0ij,fcont,fprimcont
4858       double precision x,x2,x4,delta
4859 c     delta=0.02D0*r0ij
4860 c      delta=0.2D0*r0ij
4861       x=(rij-r0ij)/delta
4862       if (x.lt.-1.0D0) then
4863         fcont=eps0ij
4864         fprimcont=0.0D0
4865       else if (x.le.1.0D0) then
4866         x2=x*x
4867         x4=x2*x2
4868         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4869         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4870       else
4871         fcont=0.0D0
4872         fprimcont=0.0D0
4873       endif
4874       return
4875       end
4876 c------------------------------------------------------------------------------
4877       subroutine splinthet(theti,delta,ss,ssder)
4878       implicit real*8 (a-h,o-z)
4879       include 'DIMENSIONS'
4880       include 'sizesclu.dat'
4881       include 'COMMON.VAR'
4882       include 'COMMON.GEO'
4883       thetup=pi-delta
4884       thetlow=delta
4885       if (theti.gt.pipol) then
4886         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4887       else
4888         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4889         ssder=-ssder
4890       endif
4891       return
4892       end
4893 c------------------------------------------------------------------------------
4894       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4895       implicit none
4896       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4897       double precision ksi,ksi2,ksi3,a1,a2,a3
4898       a1=fprim0*delta/(f1-f0)
4899       a2=3.0d0-2.0d0*a1
4900       a3=a1-2.0d0
4901       ksi=(x-x0)/delta
4902       ksi2=ksi*ksi
4903       ksi3=ksi2*ksi
4904       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4905       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4906       return
4907       end
4908 c------------------------------------------------------------------------------
4909       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4910       implicit none
4911       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4912       double precision ksi,ksi2,ksi3,a1,a2,a3
4913       ksi=(x-x0)/delta
4914       ksi2=ksi*ksi
4915       ksi3=ksi2*ksi
4916       a1=fprim0x*delta
4917       a2=3*(f1x-f0x)-2*fprim0x*delta
4918       a3=fprim0x*delta-2*(f1x-f0x)
4919       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4920       return
4921       end
4922 C-----------------------------------------------------------------------------
4923 #ifdef CRYST_TOR
4924 C-----------------------------------------------------------------------------
4925       subroutine etor(etors,edihcnstr,fact)
4926       implicit real*8 (a-h,o-z)
4927       include 'DIMENSIONS'
4928       include 'sizesclu.dat'
4929       include 'COMMON.VAR'
4930       include 'COMMON.GEO'
4931       include 'COMMON.LOCAL'
4932       include 'COMMON.TORSION'
4933       include 'COMMON.INTERACT'
4934       include 'COMMON.DERIV'
4935       include 'COMMON.CHAIN'
4936       include 'COMMON.NAMES'
4937       include 'COMMON.IOUNITS'
4938       include 'COMMON.FFIELD'
4939       include 'COMMON.TORCNSTR'
4940       logical lprn
4941 C Set lprn=.true. for debugging
4942       lprn=.false.
4943 c      lprn=.true.
4944       etors=0.0D0
4945       do i=iphi_start,iphi_end
4946         itori=itortyp(itype(i-2))
4947         itori1=itortyp(itype(i-1))
4948         phii=phi(i)
4949         gloci=0.0D0
4950 C Proline-Proline pair is a special case...
4951         if (itori.eq.3 .and. itori1.eq.3) then
4952           if (phii.gt.-dwapi3) then
4953             cosphi=dcos(3*phii)
4954             fac=1.0D0/(1.0D0-cosphi)
4955             etorsi=v1(1,3,3)*fac
4956             etorsi=etorsi+etorsi
4957             etors=etors+etorsi-v1(1,3,3)
4958             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4959           endif
4960           do j=1,3
4961             v1ij=v1(j+1,itori,itori1)
4962             v2ij=v2(j+1,itori,itori1)
4963             cosphi=dcos(j*phii)
4964             sinphi=dsin(j*phii)
4965             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4966             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4967           enddo
4968         else
4969           do j=1,nterm_old
4970             v1ij=v1(j,itori,itori1)
4971             v2ij=v2(j,itori,itori1)
4972             cosphi=dcos(j*phii)
4973             sinphi=dsin(j*phii)
4974             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4975             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4976           enddo
4977         endif
4978         if (lprn)
4979      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4980      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4981      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4982         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4983 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4984       enddo
4985 ! 6/20/98 - dihedral angle constraints
4986       edihcnstr=0.0d0
4987       do i=1,ndih_constr
4988         itori=idih_constr(i)
4989         phii=phi(itori)
4990         difi=pinorm(phii-phi0(i))
4991         if (difi.gt.drange(i)) then
4992           difi=difi-drange(i)
4993           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4994           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4995         else if (difi.lt.-drange(i)) then
4996           difi=difi+drange(i)
4997           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4998           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4999         endif
5000 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5001 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5002       enddo
5003       write (iout,*) 'edihcnstr',edihcnstr
5004       return
5005       end
5006 c------------------------------------------------------------------------------
5007 #else
5008       subroutine etor(etors,edihcnstr,fact)
5009       implicit real*8 (a-h,o-z)
5010       include 'DIMENSIONS'
5011       include 'sizesclu.dat'
5012       include 'COMMON.VAR'
5013       include 'COMMON.GEO'
5014       include 'COMMON.LOCAL'
5015       include 'COMMON.TORSION'
5016       include 'COMMON.INTERACT'
5017       include 'COMMON.DERIV'
5018       include 'COMMON.CHAIN'
5019       include 'COMMON.NAMES'
5020       include 'COMMON.IOUNITS'
5021       include 'COMMON.FFIELD'
5022       include 'COMMON.TORCNSTR'
5023       logical lprn
5024 C Set lprn=.true. for debugging
5025       lprn=.false.
5026 c      lprn=.true.
5027       etors=0.0D0
5028       do i=iphi_start,iphi_end
5029         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5030         itori=itortyp(itype(i-2))
5031         itori1=itortyp(itype(i-1))
5032         phii=phi(i)
5033         gloci=0.0D0
5034 C Regular cosine and sine terms
5035         do j=1,nterm(itori,itori1)
5036           v1ij=v1(j,itori,itori1)
5037           v2ij=v2(j,itori,itori1)
5038           cosphi=dcos(j*phii)
5039           sinphi=dsin(j*phii)
5040           etors=etors+v1ij*cosphi+v2ij*sinphi
5041           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5042         enddo
5043 C Lorentz terms
5044 C                         v1
5045 C  E = SUM ----------------------------------- - v1
5046 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5047 C
5048         cosphi=dcos(0.5d0*phii)
5049         sinphi=dsin(0.5d0*phii)
5050         do j=1,nlor(itori,itori1)
5051           vl1ij=vlor1(j,itori,itori1)
5052           vl2ij=vlor2(j,itori,itori1)
5053           vl3ij=vlor3(j,itori,itori1)
5054           pom=vl2ij*cosphi+vl3ij*sinphi
5055           pom1=1.0d0/(pom*pom+1.0d0)
5056           etors=etors+vl1ij*pom1
5057           pom=-pom*pom1*pom1
5058           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5059         enddo
5060 C Subtract the constant term
5061         etors=etors-v0(itori,itori1)
5062         if (lprn)
5063      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5064      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5065      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5066         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5067 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5068  1215   continue
5069       enddo
5070 ! 6/20/98 - dihedral angle constraints
5071       edihcnstr=0.0d0
5072 c      write (iout,*) "Dihedral angle restraint energy"
5073       do i=1,ndih_constr
5074         itori=idih_constr(i)
5075         phii=phi(itori)
5076         difi=pinorm(phii-phi0(i))
5077 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5078 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
5079         if (difi.gt.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         else if (difi.lt.-drange(i)) then
5085           difi=difi+drange(i)
5086           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5087           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5088 c          write (iout,*) 0.25d0*ftors*difi**4
5089         endif
5090       enddo
5091 c      write (iout,*) 'edihcnstr',edihcnstr
5092       return
5093       end
5094 c----------------------------------------------------------------------------
5095       subroutine etor_d(etors_d,fact2)
5096 C 6/23/01 Compute double torsional energy
5097       implicit real*8 (a-h,o-z)
5098       include 'DIMENSIONS'
5099       include 'sizesclu.dat'
5100       include 'COMMON.VAR'
5101       include 'COMMON.GEO'
5102       include 'COMMON.LOCAL'
5103       include 'COMMON.TORSION'
5104       include 'COMMON.INTERACT'
5105       include 'COMMON.DERIV'
5106       include 'COMMON.CHAIN'
5107       include 'COMMON.NAMES'
5108       include 'COMMON.IOUNITS'
5109       include 'COMMON.FFIELD'
5110       include 'COMMON.TORCNSTR'
5111       logical lprn
5112 C Set lprn=.true. for debugging
5113       lprn=.false.
5114 c     lprn=.true.
5115       etors_d=0.0D0
5116       do i=iphi_start,iphi_end-1
5117         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5118      &     goto 1215
5119         itori=itortyp(itype(i-2))
5120         itori1=itortyp(itype(i-1))
5121         itori2=itortyp(itype(i))
5122         phii=phi(i)
5123         phii1=phi(i+1)
5124         gloci1=0.0D0
5125         gloci2=0.0D0
5126 C Regular cosine and sine terms
5127         do j=1,ntermd_1(itori,itori1,itori2)
5128           v1cij=v1c(1,j,itori,itori1,itori2)
5129           v1sij=v1s(1,j,itori,itori1,itori2)
5130           v2cij=v1c(2,j,itori,itori1,itori2)
5131           v2sij=v1s(2,j,itori,itori1,itori2)
5132           cosphi1=dcos(j*phii)
5133           sinphi1=dsin(j*phii)
5134           cosphi2=dcos(j*phii1)
5135           sinphi2=dsin(j*phii1)
5136           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5137      &     v2cij*cosphi2+v2sij*sinphi2
5138           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5139           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5140         enddo
5141         do k=2,ntermd_2(itori,itori1,itori2)
5142           do l=1,k-1
5143             v1cdij = v2c(k,l,itori,itori1,itori2)
5144             v2cdij = v2c(l,k,itori,itori1,itori2)
5145             v1sdij = v2s(k,l,itori,itori1,itori2)
5146             v2sdij = v2s(l,k,itori,itori1,itori2)
5147             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5148             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5149             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5150             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5151             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5152      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5153             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5154      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5155             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5156      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5157           enddo
5158         enddo
5159         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5160         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5161  1215   continue
5162       enddo
5163       return
5164       end
5165 #endif
5166 c------------------------------------------------------------------------------
5167       subroutine eback_sc_corr(esccor,fact)
5168 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5169 c        conformational states; temporarily implemented as differences
5170 c        between UNRES torsional potentials (dependent on three types of
5171 c        residues) and the torsional potentials dependent on all 20 types
5172 c        of residues computed from AM1 energy surfaces of terminally-blocked
5173 c        amino-acid residues.
5174       implicit real*8 (a-h,o-z)
5175       include 'DIMENSIONS'
5176       include 'COMMON.VAR'
5177       include 'COMMON.GEO'
5178       include 'COMMON.LOCAL'
5179       include 'COMMON.TORSION'
5180       include 'COMMON.SCCOR'
5181       include 'COMMON.INTERACT'
5182       include 'COMMON.DERIV'
5183       include 'COMMON.CHAIN'
5184       include 'COMMON.NAMES'
5185       include 'COMMON.IOUNITS'
5186       include 'COMMON.FFIELD'
5187       include 'COMMON.CONTROL'
5188       logical lprn
5189 C Set lprn=.true. for debugging
5190       lprn=.false.
5191 c      lprn=.true.
5192 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5193       esccor=0.0D0
5194       do i=itau_start,itau_end
5195         esccor_ii=0.0D0
5196         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5197         isccori=isccortyp(itype(i-2))
5198         isccori1=isccortyp(itype(i-1))
5199         phii=phi(i)
5200 cccc  Added 9 May 2012
5201 cc Tauangle is torsional engle depending on the value of first digit
5202 c(see comment below)
5203 cc Omicron is flat angle depending on the value of first digit
5204 c(see comment below)
5205
5206
5207         do intertyp=1,3 !intertyp
5208 cc Added 09 May 2012 (Adasko)
5209 cc  Intertyp means interaction type of backbone mainchain correlation:
5210 c   1 = SC...Ca...Ca...Ca
5211 c   2 = Ca...Ca...Ca...SC
5212 c   3 = SC...Ca...Ca...SCi
5213         gloci=0.0D0
5214         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5215      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5216      &      (itype(i-1).eq.21)))
5217      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5218      &     .or.(itype(i-2).eq.21)))
5219      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5220      &      (itype(i-1).eq.21)))) cycle
5221         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5222         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5223      & cycle
5224         do j=1,nterm_sccor(isccori,isccori1)
5225           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5226           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5227           cosphi=dcos(j*tauangle(intertyp,i))
5228           sinphi=dsin(j*tauangle(intertyp,i))
5229           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5230 #ifdef DEBUG
5231           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5232 #endif
5233           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5234         enddo
5235         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5236 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5237 c     &gloc_sc(intertyp,i-3,icg)
5238         if (lprn)
5239      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5240      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5241      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5242      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5243         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5244        enddo !intertyp
5245 #ifdef DEBUG
5246        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5247 #endif
5248       enddo
5249
5250       return
5251       end
5252 c------------------------------------------------------------------------------
5253       subroutine multibody(ecorr)
5254 C This subroutine calculates multi-body contributions to energy following
5255 C the idea of Skolnick et al. If side chains I and J make a contact and
5256 C at the same time side chains I+1 and J+1 make a contact, an extra
5257 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5258       implicit real*8 (a-h,o-z)
5259       include 'DIMENSIONS'
5260       include 'COMMON.IOUNITS'
5261       include 'COMMON.DERIV'
5262       include 'COMMON.INTERACT'
5263       include 'COMMON.CONTACTS'
5264       double precision gx(3),gx1(3)
5265       logical lprn
5266
5267 C Set lprn=.true. for debugging
5268       lprn=.false.
5269
5270       if (lprn) then
5271         write (iout,'(a)') 'Contact function values:'
5272         do i=nnt,nct-2
5273           write (iout,'(i2,20(1x,i2,f10.5))')
5274      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5275         enddo
5276       endif
5277       ecorr=0.0D0
5278       do i=nnt,nct
5279         do j=1,3
5280           gradcorr(j,i)=0.0D0
5281           gradxorr(j,i)=0.0D0
5282         enddo
5283       enddo
5284       do i=nnt,nct-2
5285
5286         DO ISHIFT = 3,4
5287
5288         i1=i+ishift
5289         num_conti=num_cont(i)
5290         num_conti1=num_cont(i1)
5291         do jj=1,num_conti
5292           j=jcont(jj,i)
5293           do kk=1,num_conti1
5294             j1=jcont(kk,i1)
5295             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5296 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5297 cd   &                   ' ishift=',ishift
5298 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5299 C The system gains extra energy.
5300               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5301             endif   ! j1==j+-ishift
5302           enddo     ! kk
5303         enddo       ! jj
5304
5305         ENDDO ! ISHIFT
5306
5307       enddo         ! i
5308       return
5309       end
5310 c------------------------------------------------------------------------------
5311       double precision function esccorr(i,j,k,l,jj,kk)
5312       implicit real*8 (a-h,o-z)
5313       include 'DIMENSIONS'
5314       include 'COMMON.IOUNITS'
5315       include 'COMMON.DERIV'
5316       include 'COMMON.INTERACT'
5317       include 'COMMON.CONTACTS'
5318       double precision gx(3),gx1(3)
5319       logical lprn
5320       lprn=.false.
5321       eij=facont(jj,i)
5322       ekl=facont(kk,k)
5323 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5324 C Calculate the multi-body contribution to energy.
5325 C Calculate multi-body contributions to the gradient.
5326 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5327 cd   & k,l,(gacont(m,kk,k),m=1,3)
5328       do m=1,3
5329         gx(m) =ekl*gacont(m,jj,i)
5330         gx1(m)=eij*gacont(m,kk,k)
5331         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5332         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5333         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5334         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5335       enddo
5336       do m=i,j-1
5337         do ll=1,3
5338           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5339         enddo
5340       enddo
5341       do m=k,l-1
5342         do ll=1,3
5343           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5344         enddo
5345       enddo
5346       esccorr=-eij*ekl
5347       return
5348       end
5349 c------------------------------------------------------------------------------
5350 #ifdef MPL
5351       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5352       implicit real*8 (a-h,o-z)
5353       include 'DIMENSIONS'
5354       integer dimen1,dimen2,atom,indx
5355       double precision buffer(dimen1,dimen2)
5356       double precision zapas
5357       common /contacts_hb/ zapas(3,20,maxres,7),
5358      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5359      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5360       num_kont=num_cont_hb(atom)
5361       do i=1,num_kont
5362         do k=1,7
5363           do j=1,3
5364             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5365           enddo ! j
5366         enddo ! k
5367         buffer(i,indx+22)=facont_hb(i,atom)
5368         buffer(i,indx+23)=ees0p(i,atom)
5369         buffer(i,indx+24)=ees0m(i,atom)
5370         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5371       enddo ! i
5372       buffer(1,indx+26)=dfloat(num_kont)
5373       return
5374       end
5375 c------------------------------------------------------------------------------
5376       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5377       implicit real*8 (a-h,o-z)
5378       include 'DIMENSIONS'
5379       integer dimen1,dimen2,atom,indx
5380       double precision buffer(dimen1,dimen2)
5381       double precision zapas
5382       common /contacts_hb/ zapas(3,20,maxres,7),
5383      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5384      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5385       num_kont=buffer(1,indx+26)
5386       num_kont_old=num_cont_hb(atom)
5387       num_cont_hb(atom)=num_kont+num_kont_old
5388       do i=1,num_kont
5389         ii=i+num_kont_old
5390         do k=1,7
5391           do j=1,3
5392             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5393           enddo ! j
5394         enddo ! k
5395         facont_hb(ii,atom)=buffer(i,indx+22)
5396         ees0p(ii,atom)=buffer(i,indx+23)
5397         ees0m(ii,atom)=buffer(i,indx+24)
5398         jcont_hb(ii,atom)=buffer(i,indx+25)
5399       enddo ! i
5400       return
5401       end
5402 c------------------------------------------------------------------------------
5403 #endif
5404       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5405 C This subroutine calculates multi-body contributions to hydrogen-bonding
5406       implicit real*8 (a-h,o-z)
5407       include 'DIMENSIONS'
5408       include 'sizesclu.dat'
5409       include 'COMMON.IOUNITS'
5410 #ifdef MPL
5411       include 'COMMON.INFO'
5412 #endif
5413       include 'COMMON.FFIELD'
5414       include 'COMMON.DERIV'
5415       include 'COMMON.INTERACT'
5416       include 'COMMON.CONTACTS'
5417 #ifdef MPL
5418       parameter (max_cont=maxconts)
5419       parameter (max_dim=2*(8*3+2))
5420       parameter (msglen1=max_cont*max_dim*4)
5421       parameter (msglen2=2*msglen1)
5422       integer source,CorrelType,CorrelID,Error
5423       double precision buffer(max_cont,max_dim)
5424 #endif
5425       double precision gx(3),gx1(3)
5426       logical lprn,ldone
5427
5428 C Set lprn=.true. for debugging
5429       lprn=.false.
5430 #ifdef MPL
5431       n_corr=0
5432       n_corr1=0
5433       if (fgProcs.le.1) goto 30
5434       if (lprn) then
5435         write (iout,'(a)') 'Contact function values:'
5436         do i=nnt,nct-2
5437           write (iout,'(2i3,50(1x,i2,f5.2))')
5438      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5439      &    j=1,num_cont_hb(i))
5440         enddo
5441       endif
5442 C Caution! Following code assumes that electrostatic interactions concerning
5443 C a given atom are split among at most two processors!
5444       CorrelType=477
5445       CorrelID=MyID+1
5446       ldone=.false.
5447       do i=1,max_cont
5448         do j=1,max_dim
5449           buffer(i,j)=0.0D0
5450         enddo
5451       enddo
5452       mm=mod(MyRank,2)
5453 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5454       if (mm) 20,20,10
5455    10 continue
5456 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5457       if (MyRank.gt.0) then
5458 C Send correlation contributions to the preceding processor
5459         msglen=msglen1
5460         nn=num_cont_hb(iatel_s)
5461         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5462 cd      write (iout,*) 'The BUFFER array:'
5463 cd      do i=1,nn
5464 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5465 cd      enddo
5466         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5467           msglen=msglen2
5468             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5469 C Clear the contacts of the atom passed to the neighboring processor
5470         nn=num_cont_hb(iatel_s+1)
5471 cd      do i=1,nn
5472 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5473 cd      enddo
5474             num_cont_hb(iatel_s)=0
5475         endif
5476 cd      write (iout,*) 'Processor ',MyID,MyRank,
5477 cd   & ' is sending correlation contribution to processor',MyID-1,
5478 cd   & ' msglen=',msglen
5479 cd      write (*,*) 'Processor ',MyID,MyRank,
5480 cd   & ' is sending correlation contribution to processor',MyID-1,
5481 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5482         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5483 cd      write (iout,*) 'Processor ',MyID,
5484 cd   & ' has sent correlation contribution to processor',MyID-1,
5485 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5486 cd      write (*,*) 'Processor ',MyID,
5487 cd   & ' has sent correlation contribution to processor',MyID-1,
5488 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5489         msglen=msglen1
5490       endif ! (MyRank.gt.0)
5491       if (ldone) goto 30
5492       ldone=.true.
5493    20 continue
5494 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5495       if (MyRank.lt.fgProcs-1) then
5496 C Receive correlation contributions from the next processor
5497         msglen=msglen1
5498         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5499 cd      write (iout,*) 'Processor',MyID,
5500 cd   & ' is receiving correlation contribution from processor',MyID+1,
5501 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5502 cd      write (*,*) 'Processor',MyID,
5503 cd   & ' is receiving correlation contribution from processor',MyID+1,
5504 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5505         nbytes=-1
5506         do while (nbytes.le.0)
5507           call mp_probe(MyID+1,CorrelType,nbytes)
5508         enddo
5509 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5510         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5511 cd      write (iout,*) 'Processor',MyID,
5512 cd   & ' has received correlation contribution from processor',MyID+1,
5513 cd   & ' msglen=',msglen,' nbytes=',nbytes
5514 cd      write (iout,*) 'The received BUFFER array:'
5515 cd      do i=1,max_cont
5516 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5517 cd      enddo
5518         if (msglen.eq.msglen1) then
5519           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5520         else if (msglen.eq.msglen2)  then
5521           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5522           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5523         else
5524           write (iout,*)
5525      & 'ERROR!!!! message length changed while processing correlations.'
5526           write (*,*)
5527      & 'ERROR!!!! message length changed while processing correlations.'
5528           call mp_stopall(Error)
5529         endif ! msglen.eq.msglen1
5530       endif ! MyRank.lt.fgProcs-1
5531       if (ldone) goto 30
5532       ldone=.true.
5533       goto 10
5534    30 continue
5535 #endif
5536       if (lprn) then
5537         write (iout,'(a)') 'Contact function values:'
5538         do i=nnt,nct-2
5539           write (iout,'(2i3,50(1x,i2,f5.2))')
5540      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5541      &    j=1,num_cont_hb(i))
5542         enddo
5543       endif
5544       ecorr=0.0D0
5545 C Remove the loop below after debugging !!!
5546       do i=nnt,nct
5547         do j=1,3
5548           gradcorr(j,i)=0.0D0
5549           gradxorr(j,i)=0.0D0
5550         enddo
5551       enddo
5552 C Calculate the local-electrostatic correlation terms
5553       do i=iatel_s,iatel_e+1
5554         i1=i+1
5555         num_conti=num_cont_hb(i)
5556         num_conti1=num_cont_hb(i+1)
5557         do jj=1,num_conti
5558           j=jcont_hb(jj,i)
5559           do kk=1,num_conti1
5560             j1=jcont_hb(kk,i1)
5561 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5562 c     &         ' jj=',jj,' kk=',kk
5563             if (j1.eq.j+1 .or. j1.eq.j-1) then
5564 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5565 C The system gains extra energy.
5566               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5567               n_corr=n_corr+1
5568             else if (j1.eq.j) then
5569 C Contacts I-J and I-(J+1) occur simultaneously.
5570 C The system loses extra energy.
5571 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5572             endif
5573           enddo ! kk
5574           do kk=1,num_conti
5575             j1=jcont_hb(kk,i)
5576 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5577 c    &         ' jj=',jj,' kk=',kk
5578             if (j1.eq.j+1) then
5579 C Contacts I-J and (I+1)-J occur simultaneously.
5580 C The system loses extra energy.
5581 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5582             endif ! j1==j+1
5583           enddo ! kk
5584         enddo ! jj
5585       enddo ! i
5586       return
5587       end
5588 c------------------------------------------------------------------------------
5589       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5590      &  n_corr1)
5591 C This subroutine calculates multi-body contributions to hydrogen-bonding
5592       implicit real*8 (a-h,o-z)
5593       include 'DIMENSIONS'
5594       include 'sizesclu.dat'
5595       include 'COMMON.IOUNITS'
5596 #ifdef MPL
5597       include 'COMMON.INFO'
5598 #endif
5599       include 'COMMON.FFIELD'
5600       include 'COMMON.DERIV'
5601       include 'COMMON.INTERACT'
5602       include 'COMMON.CONTACTS'
5603 #ifdef MPL
5604       parameter (max_cont=maxconts)
5605       parameter (max_dim=2*(8*3+2))
5606       parameter (msglen1=max_cont*max_dim*4)
5607       parameter (msglen2=2*msglen1)
5608       integer source,CorrelType,CorrelID,Error
5609       double precision buffer(max_cont,max_dim)
5610 #endif
5611       double precision gx(3),gx1(3)
5612       logical lprn,ldone
5613
5614 C Set lprn=.true. for debugging
5615       lprn=.false.
5616       eturn6=0.0d0
5617       ecorr6=0.0d0
5618 #ifdef MPL
5619       n_corr=0
5620       n_corr1=0
5621       if (fgProcs.le.1) goto 30
5622       if (lprn) then
5623         write (iout,'(a)') 'Contact function values:'
5624         do i=nnt,nct-2
5625           write (iout,'(2i3,50(1x,i2,f5.2))')
5626      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5627      &    j=1,num_cont_hb(i))
5628         enddo
5629       endif
5630 C Caution! Following code assumes that electrostatic interactions concerning
5631 C a given atom are split among at most two processors!
5632       CorrelType=477
5633       CorrelID=MyID+1
5634       ldone=.false.
5635       do i=1,max_cont
5636         do j=1,max_dim
5637           buffer(i,j)=0.0D0
5638         enddo
5639       enddo
5640       mm=mod(MyRank,2)
5641 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5642       if (mm) 20,20,10
5643    10 continue
5644 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5645       if (MyRank.gt.0) then
5646 C Send correlation contributions to the preceding processor
5647         msglen=msglen1
5648         nn=num_cont_hb(iatel_s)
5649         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5650 cd      write (iout,*) 'The BUFFER array:'
5651 cd      do i=1,nn
5652 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5653 cd      enddo
5654         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5655           msglen=msglen2
5656             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5657 C Clear the contacts of the atom passed to the neighboring processor
5658         nn=num_cont_hb(iatel_s+1)
5659 cd      do i=1,nn
5660 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5661 cd      enddo
5662             num_cont_hb(iatel_s)=0
5663         endif
5664 cd      write (iout,*) 'Processor ',MyID,MyRank,
5665 cd   & ' is sending correlation contribution to processor',MyID-1,
5666 cd   & ' msglen=',msglen
5667 cd      write (*,*) 'Processor ',MyID,MyRank,
5668 cd   & ' is sending correlation contribution to processor',MyID-1,
5669 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5670         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5671 cd      write (iout,*) 'Processor ',MyID,
5672 cd   & ' has sent correlation contribution to processor',MyID-1,
5673 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5674 cd      write (*,*) 'Processor ',MyID,
5675 cd   & ' has sent correlation contribution to processor',MyID-1,
5676 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5677         msglen=msglen1
5678       endif ! (MyRank.gt.0)
5679       if (ldone) goto 30
5680       ldone=.true.
5681    20 continue
5682 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5683       if (MyRank.lt.fgProcs-1) then
5684 C Receive correlation contributions from the next processor
5685         msglen=msglen1
5686         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5687 cd      write (iout,*) 'Processor',MyID,
5688 cd   & ' is receiving correlation contribution from processor',MyID+1,
5689 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5690 cd      write (*,*) 'Processor',MyID,
5691 cd   & ' is receiving correlation contribution from processor',MyID+1,
5692 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5693         nbytes=-1
5694         do while (nbytes.le.0)
5695           call mp_probe(MyID+1,CorrelType,nbytes)
5696         enddo
5697 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5698         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5699 cd      write (iout,*) 'Processor',MyID,
5700 cd   & ' has received correlation contribution from processor',MyID+1,
5701 cd   & ' msglen=',msglen,' nbytes=',nbytes
5702 cd      write (iout,*) 'The received BUFFER array:'
5703 cd      do i=1,max_cont
5704 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5705 cd      enddo
5706         if (msglen.eq.msglen1) then
5707           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5708         else if (msglen.eq.msglen2)  then
5709           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5710           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5711         else
5712           write (iout,*)
5713      & 'ERROR!!!! message length changed while processing correlations.'
5714           write (*,*)
5715      & 'ERROR!!!! message length changed while processing correlations.'
5716           call mp_stopall(Error)
5717         endif ! msglen.eq.msglen1
5718       endif ! MyRank.lt.fgProcs-1
5719       if (ldone) goto 30
5720       ldone=.true.
5721       goto 10
5722    30 continue
5723 #endif
5724       if (lprn) then
5725         write (iout,'(a)') 'Contact function values:'
5726         do i=nnt,nct-2
5727           write (iout,'(2i3,50(1x,i2,f5.2))')
5728      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5729      &    j=1,num_cont_hb(i))
5730         enddo
5731       endif
5732       ecorr=0.0D0
5733       ecorr5=0.0d0
5734       ecorr6=0.0d0
5735 C Remove the loop below after debugging !!!
5736       do i=nnt,nct
5737         do j=1,3
5738           gradcorr(j,i)=0.0D0
5739           gradxorr(j,i)=0.0D0
5740         enddo
5741       enddo
5742 C Calculate the dipole-dipole interaction energies
5743       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5744       do i=iatel_s,iatel_e+1
5745         num_conti=num_cont_hb(i)
5746         do jj=1,num_conti
5747           j=jcont_hb(jj,i)
5748           call dipole(i,j,jj)
5749         enddo
5750       enddo
5751       endif
5752 C Calculate the local-electrostatic correlation terms
5753       do i=iatel_s,iatel_e+1
5754         i1=i+1
5755         num_conti=num_cont_hb(i)
5756         num_conti1=num_cont_hb(i+1)
5757         do jj=1,num_conti
5758           j=jcont_hb(jj,i)
5759           do kk=1,num_conti1
5760             j1=jcont_hb(kk,i1)
5761 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5762 c     &         ' jj=',jj,' kk=',kk
5763             if (j1.eq.j+1 .or. j1.eq.j-1) then
5764 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5765 C The system gains extra energy.
5766               n_corr=n_corr+1
5767               sqd1=dsqrt(d_cont(jj,i))
5768               sqd2=dsqrt(d_cont(kk,i1))
5769               sred_geom = sqd1*sqd2
5770               IF (sred_geom.lt.cutoff_corr) THEN
5771                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5772      &            ekont,fprimcont)
5773 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5774 c     &         ' jj=',jj,' kk=',kk
5775                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5776                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5777                 do l=1,3
5778                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5779                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5780                 enddo
5781                 n_corr1=n_corr1+1
5782 cd               write (iout,*) 'sred_geom=',sred_geom,
5783 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5784                 call calc_eello(i,j,i+1,j1,jj,kk)
5785                 if (wcorr4.gt.0.0d0)
5786      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5787                 if (wcorr5.gt.0.0d0)
5788      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5789 c                print *,"wcorr5",ecorr5
5790 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5791 cd                write(2,*)'ijkl',i,j,i+1,j1
5792                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5793      &               .or. wturn6.eq.0.0d0))then
5794 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5795 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5796 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5797 c     &            'ecorr6=',ecorr6, wcorr6
5798 cd                write (iout,'(4e15.5)') sred_geom,
5799 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5800 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5801 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5802                 else if (wturn6.gt.0.0d0
5803      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5804 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5805                   eturn6=eturn6+eello_turn6(i,jj,kk)
5806 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5807                 endif
5808               ENDIF
5809 1111          continue
5810             else if (j1.eq.j) then
5811 C Contacts I-J and I-(J+1) occur simultaneously.
5812 C The system loses extra energy.
5813 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5814             endif
5815           enddo ! kk
5816           do kk=1,num_conti
5817             j1=jcont_hb(kk,i)
5818 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5819 c    &         ' jj=',jj,' kk=',kk
5820             if (j1.eq.j+1) then
5821 C Contacts I-J and (I+1)-J occur simultaneously.
5822 C The system loses extra energy.
5823 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5824             endif ! j1==j+1
5825           enddo ! kk
5826         enddo ! jj
5827       enddo ! i
5828       return
5829       end
5830 c------------------------------------------------------------------------------
5831       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5832       implicit real*8 (a-h,o-z)
5833       include 'DIMENSIONS'
5834       include 'COMMON.IOUNITS'
5835       include 'COMMON.DERIV'
5836       include 'COMMON.INTERACT'
5837       include 'COMMON.CONTACTS'
5838       double precision gx(3),gx1(3)
5839       logical lprn
5840       lprn=.false.
5841       eij=facont_hb(jj,i)
5842       ekl=facont_hb(kk,k)
5843       ees0pij=ees0p(jj,i)
5844       ees0pkl=ees0p(kk,k)
5845       ees0mij=ees0m(jj,i)
5846       ees0mkl=ees0m(kk,k)
5847       ekont=eij*ekl
5848       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5849 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5850 C Following 4 lines for diagnostics.
5851 cd    ees0pkl=0.0D0
5852 cd    ees0pij=1.0D0
5853 cd    ees0mkl=0.0D0
5854 cd    ees0mij=1.0D0
5855 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5856 c    &   ' and',k,l
5857 c     write (iout,*)'Contacts have occurred for peptide groups',
5858 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5859 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5860 C Calculate the multi-body contribution to energy.
5861       ecorr=ecorr+ekont*ees
5862       if (calc_grad) then
5863 C Calculate multi-body contributions to the gradient.
5864       do ll=1,3
5865         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5866         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5867      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5868      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5869         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5870      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5871      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5872         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5873         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5874      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5875      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5876         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5877      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5878      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5879       enddo
5880       do m=i+1,j-1
5881         do ll=1,3
5882           gradcorr(ll,m)=gradcorr(ll,m)+
5883      &     ees*ekl*gacont_hbr(ll,jj,i)-
5884      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5885      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5886         enddo
5887       enddo
5888       do m=k+1,l-1
5889         do ll=1,3
5890           gradcorr(ll,m)=gradcorr(ll,m)+
5891      &     ees*eij*gacont_hbr(ll,kk,k)-
5892      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5893      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5894         enddo
5895       enddo
5896       endif
5897       ehbcorr=ekont*ees
5898       return
5899       end
5900 C---------------------------------------------------------------------------
5901       subroutine dipole(i,j,jj)
5902       implicit real*8 (a-h,o-z)
5903       include 'DIMENSIONS'
5904       include 'sizesclu.dat'
5905       include 'COMMON.IOUNITS'
5906       include 'COMMON.CHAIN'
5907       include 'COMMON.FFIELD'
5908       include 'COMMON.DERIV'
5909       include 'COMMON.INTERACT'
5910       include 'COMMON.CONTACTS'
5911       include 'COMMON.TORSION'
5912       include 'COMMON.VAR'
5913       include 'COMMON.GEO'
5914       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5915      &  auxmat(2,2)
5916       iti1 = itortyp(itype(i+1))
5917       if (j.lt.nres-1) then
5918         itj1 = itortyp(itype(j+1))
5919       else
5920         itj1=ntortyp+1
5921       endif
5922       do iii=1,2
5923         dipi(iii,1)=Ub2(iii,i)
5924         dipderi(iii)=Ub2der(iii,i)
5925         dipi(iii,2)=b1(iii,iti1)
5926         dipj(iii,1)=Ub2(iii,j)
5927         dipderj(iii)=Ub2der(iii,j)
5928         dipj(iii,2)=b1(iii,itj1)
5929       enddo
5930       kkk=0
5931       do iii=1,2
5932         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5933         do jjj=1,2
5934           kkk=kkk+1
5935           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5936         enddo
5937       enddo
5938       if (.not.calc_grad) return
5939       do kkk=1,5
5940         do lll=1,3
5941           mmm=0
5942           do iii=1,2
5943             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5944      &        auxvec(1))
5945             do jjj=1,2
5946               mmm=mmm+1
5947               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5948             enddo
5949           enddo
5950         enddo
5951       enddo
5952       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5953       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5954       do iii=1,2
5955         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5956       enddo
5957       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5958       do iii=1,2
5959         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5960       enddo
5961       return
5962       end
5963 C---------------------------------------------------------------------------
5964       subroutine calc_eello(i,j,k,l,jj,kk)
5965 C
5966 C This subroutine computes matrices and vectors needed to calculate
5967 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5968 C
5969       implicit real*8 (a-h,o-z)
5970       include 'DIMENSIONS'
5971       include 'sizesclu.dat'
5972       include 'COMMON.IOUNITS'
5973       include 'COMMON.CHAIN'
5974       include 'COMMON.DERIV'
5975       include 'COMMON.INTERACT'
5976       include 'COMMON.CONTACTS'
5977       include 'COMMON.TORSION'
5978       include 'COMMON.VAR'
5979       include 'COMMON.GEO'
5980       include 'COMMON.FFIELD'
5981       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5982      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5983       logical lprn
5984       common /kutas/ lprn
5985 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5986 cd     & ' jj=',jj,' kk=',kk
5987 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5988       do iii=1,2
5989         do jjj=1,2
5990           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5991           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5992         enddo
5993       enddo
5994       call transpose2(aa1(1,1),aa1t(1,1))
5995       call transpose2(aa2(1,1),aa2t(1,1))
5996       do kkk=1,5
5997         do lll=1,3
5998           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5999      &      aa1tder(1,1,lll,kkk))
6000           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6001      &      aa2tder(1,1,lll,kkk))
6002         enddo
6003       enddo
6004       if (l.eq.j+1) then
6005 C parallel orientation of the two CA-CA-CA frames.
6006         if (i.gt.1) then
6007           iti=itortyp(itype(i))
6008         else
6009           iti=ntortyp+1
6010         endif
6011         itk1=itortyp(itype(k+1))
6012         itj=itortyp(itype(j))
6013         if (l.lt.nres-1) then
6014           itl1=itortyp(itype(l+1))
6015         else
6016           itl1=ntortyp+1
6017         endif
6018 C A1 kernel(j+1) A2T
6019 cd        do iii=1,2
6020 cd          write (iout,'(3f10.5,5x,3f10.5)')
6021 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6022 cd        enddo
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.,EUg(1,1,l),EUgder(1,1,l),
6025      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6026 C Following matrices are needed only for 6-th order cumulants
6027         IF (wcorr6.gt.0.0d0) THEN
6028         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6029      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6030      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
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.,Ug2DtEUg(1,1,l),
6033      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6034      &   ADtEAderx(1,1,1,1,1,1))
6035         lprn=.false.
6036         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6037      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6038      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6039      &   ADtEA1derx(1,1,1,1,1,1))
6040         ENDIF
6041 C End 6-th order cumulants
6042 cd        lprn=.false.
6043 cd        if (lprn) then
6044 cd        write (2,*) 'In calc_eello6'
6045 cd        do iii=1,2
6046 cd          write (2,*) 'iii=',iii
6047 cd          do kkk=1,5
6048 cd            write (2,*) 'kkk=',kkk
6049 cd            do jjj=1,2
6050 cd              write (2,'(3(2f10.5),5x)')
6051 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6052 cd            enddo
6053 cd          enddo
6054 cd        enddo
6055 cd        endif
6056         call transpose2(EUgder(1,1,k),auxmat(1,1))
6057         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6058         call transpose2(EUg(1,1,k),auxmat(1,1))
6059         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6060         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6061         do iii=1,2
6062           do kkk=1,5
6063             do lll=1,3
6064               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6065      &          EAEAderx(1,1,lll,kkk,iii,1))
6066             enddo
6067           enddo
6068         enddo
6069 C A1T kernel(i+1) A2
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.,EUg(1,1,k),EUgder(1,1,k),
6072      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6073 C Following matrices are needed only for 6-th order cumulants
6074         IF (wcorr6.gt.0.0d0) THEN
6075         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6076      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6077      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6078         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6079      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6080      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6081      &   ADtEAderx(1,1,1,1,1,2))
6082         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6083      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6084      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6085      &   ADtEA1derx(1,1,1,1,1,2))
6086         ENDIF
6087 C End 6-th order cumulants
6088         call transpose2(EUgder(1,1,l),auxmat(1,1))
6089         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6090         call transpose2(EUg(1,1,l),auxmat(1,1))
6091         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6092         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6093         do iii=1,2
6094           do kkk=1,5
6095             do lll=1,3
6096               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6097      &          EAEAderx(1,1,lll,kkk,iii,2))
6098             enddo
6099           enddo
6100         enddo
6101 C AEAb1 and AEAb2
6102 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6103 C They are needed only when the fifth- or the sixth-order cumulants are
6104 C indluded.
6105         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6106         call transpose2(AEA(1,1,1),auxmat(1,1))
6107         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6108         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6109         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6110         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6111         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6112         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6113         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6114         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6115         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6116         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6117         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6118         call transpose2(AEA(1,1,2),auxmat(1,1))
6119         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6120         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6121         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6122         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6123         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6124         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6125         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6126         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6127         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6128         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6129         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6130 C Calculate the Cartesian derivatives of the vectors.
6131         do iii=1,2
6132           do kkk=1,5
6133             do lll=1,3
6134               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6135               call matvec2(auxmat(1,1),b1(1,iti),
6136      &          AEAb1derx(1,lll,kkk,iii,1,1))
6137               call matvec2(auxmat(1,1),Ub2(1,i),
6138      &          AEAb2derx(1,lll,kkk,iii,1,1))
6139               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6140      &          AEAb1derx(1,lll,kkk,iii,2,1))
6141               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6142      &          AEAb2derx(1,lll,kkk,iii,2,1))
6143               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6144               call matvec2(auxmat(1,1),b1(1,itj),
6145      &          AEAb1derx(1,lll,kkk,iii,1,2))
6146               call matvec2(auxmat(1,1),Ub2(1,j),
6147      &          AEAb2derx(1,lll,kkk,iii,1,2))
6148               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6149      &          AEAb1derx(1,lll,kkk,iii,2,2))
6150               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6151      &          AEAb2derx(1,lll,kkk,iii,2,2))
6152             enddo
6153           enddo
6154         enddo
6155         ENDIF
6156 C End vectors
6157       else
6158 C Antiparallel orientation of the two CA-CA-CA frames.
6159         if (i.gt.1) then
6160           iti=itortyp(itype(i))
6161         else
6162           iti=ntortyp+1
6163         endif
6164         itk1=itortyp(itype(k+1))
6165         itl=itortyp(itype(l))
6166         itj=itortyp(itype(j))
6167         if (j.lt.nres-1) then
6168           itj1=itortyp(itype(j+1))
6169         else
6170           itj1=ntortyp+1
6171         endif
6172 C A2 kernel(j-1)T A1T
6173         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6174      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6175      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6176 C Following matrices are needed only for 6-th order cumulants
6177         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6178      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6179         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6180      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6181      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6182         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6183      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6184      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6185      &   ADtEAderx(1,1,1,1,1,1))
6186         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6187      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6188      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6189      &   ADtEA1derx(1,1,1,1,1,1))
6190         ENDIF
6191 C End 6-th order cumulants
6192         call transpose2(EUgder(1,1,k),auxmat(1,1))
6193         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6194         call transpose2(EUg(1,1,k),auxmat(1,1))
6195         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6196         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6197         do iii=1,2
6198           do kkk=1,5
6199             do lll=1,3
6200               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6201      &          EAEAderx(1,1,lll,kkk,iii,1))
6202             enddo
6203           enddo
6204         enddo
6205 C A2T kernel(i+1)T A1
6206         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6207      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6208      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6209 C Following matrices are needed only for 6-th order cumulants
6210         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6211      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6212         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6213      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6214      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6215         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6216      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6217      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6218      &   ADtEAderx(1,1,1,1,1,2))
6219         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6220      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6221      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6222      &   ADtEA1derx(1,1,1,1,1,2))
6223         ENDIF
6224 C End 6-th order cumulants
6225         call transpose2(EUgder(1,1,j),auxmat(1,1))
6226         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6227         call transpose2(EUg(1,1,j),auxmat(1,1))
6228         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6229         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6230         do iii=1,2
6231           do kkk=1,5
6232             do lll=1,3
6233               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6234      &          EAEAderx(1,1,lll,kkk,iii,2))
6235             enddo
6236           enddo
6237         enddo
6238 C AEAb1 and AEAb2
6239 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6240 C They are needed only when the fifth- or the sixth-order cumulants are
6241 C indluded.
6242         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6243      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6244         call transpose2(AEA(1,1,1),auxmat(1,1))
6245         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6246         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6247         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6248         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6249         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6250         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6251         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6252         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6253         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6254         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6255         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6256         call transpose2(AEA(1,1,2),auxmat(1,1))
6257         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6258         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6259         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6260         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6261         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6262         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6263         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6264         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6265         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6266         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6267         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6268 C Calculate the Cartesian derivatives of the vectors.
6269         do iii=1,2
6270           do kkk=1,5
6271             do lll=1,3
6272               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6273               call matvec2(auxmat(1,1),b1(1,iti),
6274      &          AEAb1derx(1,lll,kkk,iii,1,1))
6275               call matvec2(auxmat(1,1),Ub2(1,i),
6276      &          AEAb2derx(1,lll,kkk,iii,1,1))
6277               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6278      &          AEAb1derx(1,lll,kkk,iii,2,1))
6279               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6280      &          AEAb2derx(1,lll,kkk,iii,2,1))
6281               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6282               call matvec2(auxmat(1,1),b1(1,itl),
6283      &          AEAb1derx(1,lll,kkk,iii,1,2))
6284               call matvec2(auxmat(1,1),Ub2(1,l),
6285      &          AEAb2derx(1,lll,kkk,iii,1,2))
6286               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6287      &          AEAb1derx(1,lll,kkk,iii,2,2))
6288               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6289      &          AEAb2derx(1,lll,kkk,iii,2,2))
6290             enddo
6291           enddo
6292         enddo
6293         ENDIF
6294 C End vectors
6295       endif
6296       return
6297       end
6298 C---------------------------------------------------------------------------
6299       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6300      &  KK,KKderg,AKA,AKAderg,AKAderx)
6301       implicit none
6302       integer nderg
6303       logical transp
6304       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6305      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6306      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6307       integer iii,kkk,lll
6308       integer jjj,mmm
6309       logical lprn
6310       common /kutas/ lprn
6311       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6312       do iii=1,nderg
6313         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6314      &    AKAderg(1,1,iii))
6315       enddo
6316 cd      if (lprn) write (2,*) 'In kernel'
6317       do kkk=1,5
6318 cd        if (lprn) write (2,*) 'kkk=',kkk
6319         do lll=1,3
6320           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6321      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6322 cd          if (lprn) then
6323 cd            write (2,*) 'lll=',lll
6324 cd            write (2,*) 'iii=1'
6325 cd            do jjj=1,2
6326 cd              write (2,'(3(2f10.5),5x)')
6327 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6328 cd            enddo
6329 cd          endif
6330           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6331      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6332 cd          if (lprn) then
6333 cd            write (2,*) 'lll=',lll
6334 cd            write (2,*) 'iii=2'
6335 cd            do jjj=1,2
6336 cd              write (2,'(3(2f10.5),5x)')
6337 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6338 cd            enddo
6339 cd          endif
6340         enddo
6341       enddo
6342       return
6343       end
6344 C---------------------------------------------------------------------------
6345       double precision function eello4(i,j,k,l,jj,kk)
6346       implicit real*8 (a-h,o-z)
6347       include 'DIMENSIONS'
6348       include 'sizesclu.dat'
6349       include 'COMMON.IOUNITS'
6350       include 'COMMON.CHAIN'
6351       include 'COMMON.DERIV'
6352       include 'COMMON.INTERACT'
6353       include 'COMMON.CONTACTS'
6354       include 'COMMON.TORSION'
6355       include 'COMMON.VAR'
6356       include 'COMMON.GEO'
6357       double precision pizda(2,2),ggg1(3),ggg2(3)
6358 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6359 cd        eello4=0.0d0
6360 cd        return
6361 cd      endif
6362 cd      print *,'eello4:',i,j,k,l,jj,kk
6363 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6364 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6365 cold      eij=facont_hb(jj,i)
6366 cold      ekl=facont_hb(kk,k)
6367 cold      ekont=eij*ekl
6368       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6369       if (calc_grad) then
6370 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6371       gcorr_loc(k-1)=gcorr_loc(k-1)
6372      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6373       if (l.eq.j+1) then
6374         gcorr_loc(l-1)=gcorr_loc(l-1)
6375      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6376       else
6377         gcorr_loc(j-1)=gcorr_loc(j-1)
6378      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6379       endif
6380       do iii=1,2
6381         do kkk=1,5
6382           do lll=1,3
6383             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6384      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6385 cd            derx(lll,kkk,iii)=0.0d0
6386           enddo
6387         enddo
6388       enddo
6389 cd      gcorr_loc(l-1)=0.0d0
6390 cd      gcorr_loc(j-1)=0.0d0
6391 cd      gcorr_loc(k-1)=0.0d0
6392 cd      eel4=1.0d0
6393 cd      write (iout,*)'Contacts have occurred for peptide groups',
6394 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6395 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6396       if (j.lt.nres-1) then
6397         j1=j+1
6398         j2=j-1
6399       else
6400         j1=j-1
6401         j2=j-2
6402       endif
6403       if (l.lt.nres-1) then
6404         l1=l+1
6405         l2=l-1
6406       else
6407         l1=l-1
6408         l2=l-2
6409       endif
6410       do ll=1,3
6411 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6412         ggg1(ll)=eel4*g_contij(ll,1)
6413         ggg2(ll)=eel4*g_contij(ll,2)
6414         ghalf=0.5d0*ggg1(ll)
6415 cd        ghalf=0.0d0
6416         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6417         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6418         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6419         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6420 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6421         ghalf=0.5d0*ggg2(ll)
6422 cd        ghalf=0.0d0
6423         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6424         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6425         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6426         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6427       enddo
6428 cd      goto 1112
6429       do m=i+1,j-1
6430         do ll=1,3
6431 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6432           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6433         enddo
6434       enddo
6435       do m=k+1,l-1
6436         do ll=1,3
6437 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6438           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6439         enddo
6440       enddo
6441 1112  continue
6442       do m=i+2,j2
6443         do ll=1,3
6444           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6445         enddo
6446       enddo
6447       do m=k+2,l2
6448         do ll=1,3
6449           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6450         enddo
6451       enddo
6452 cd      do iii=1,nres-3
6453 cd        write (2,*) iii,gcorr_loc(iii)
6454 cd      enddo
6455       endif
6456       eello4=ekont*eel4
6457 cd      write (2,*) 'ekont',ekont
6458 cd      write (iout,*) 'eello4',ekont*eel4
6459       return
6460       end
6461 C---------------------------------------------------------------------------
6462       double precision function eello5(i,j,k,l,jj,kk)
6463       implicit real*8 (a-h,o-z)
6464       include 'DIMENSIONS'
6465       include 'sizesclu.dat'
6466       include 'COMMON.IOUNITS'
6467       include 'COMMON.CHAIN'
6468       include 'COMMON.DERIV'
6469       include 'COMMON.INTERACT'
6470       include 'COMMON.CONTACTS'
6471       include 'COMMON.TORSION'
6472       include 'COMMON.VAR'
6473       include 'COMMON.GEO'
6474       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6475       double precision ggg1(3),ggg2(3)
6476 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6477 C                                                                              C
6478 C                            Parallel chains                                   C
6479 C                                                                              C
6480 C          o             o                   o             o                   C
6481 C         /l\           / \             \   / \           / \   /              C
6482 C        /   \         /   \             \ /   \         /   \ /               C
6483 C       j| o |l1       | o |              o| o |         | o |o                C
6484 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6485 C      \i/   \         /   \ /             /   \         /   \                 C
6486 C       o    k1             o                                                  C
6487 C         (I)          (II)                (III)          (IV)                 C
6488 C                                                                              C
6489 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6490 C                                                                              C
6491 C                            Antiparallel chains                               C
6492 C                                                                              C
6493 C          o             o                   o             o                   C
6494 C         /j\           / \             \   / \           / \   /              C
6495 C        /   \         /   \             \ /   \         /   \ /               C
6496 C      j1| o |l        | o |              o| o |         | o |o                C
6497 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6498 C      \i/   \         /   \ /             /   \         /   \                 C
6499 C       o     k1            o                                                  C
6500 C         (I)          (II)                (III)          (IV)                 C
6501 C                                                                              C
6502 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6503 C                                                                              C
6504 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6505 C                                                                              C
6506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6507 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6508 cd        eello5=0.0d0
6509 cd        return
6510 cd      endif
6511 cd      write (iout,*)
6512 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6513 cd     &   ' and',k,l
6514       itk=itortyp(itype(k))
6515       itl=itortyp(itype(l))
6516       itj=itortyp(itype(j))
6517       eello5_1=0.0d0
6518       eello5_2=0.0d0
6519       eello5_3=0.0d0
6520       eello5_4=0.0d0
6521 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6522 cd     &   eel5_3_num,eel5_4_num)
6523       do iii=1,2
6524         do kkk=1,5
6525           do lll=1,3
6526             derx(lll,kkk,iii)=0.0d0
6527           enddo
6528         enddo
6529       enddo
6530 cd      eij=facont_hb(jj,i)
6531 cd      ekl=facont_hb(kk,k)
6532 cd      ekont=eij*ekl
6533 cd      write (iout,*)'Contacts have occurred for peptide groups',
6534 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6535 cd      goto 1111
6536 C Contribution from the graph I.
6537 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6538 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6539       call transpose2(EUg(1,1,k),auxmat(1,1))
6540       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6541       vv(1)=pizda(1,1)-pizda(2,2)
6542       vv(2)=pizda(1,2)+pizda(2,1)
6543       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6544      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6545       if (calc_grad) then
6546 C Explicit gradient in virtual-dihedral angles.
6547       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6548      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6549      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6551       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6552       vv(1)=pizda(1,1)-pizda(2,2)
6553       vv(2)=pizda(1,2)+pizda(2,1)
6554       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6555      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6556      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6557       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6558       vv(1)=pizda(1,1)-pizda(2,2)
6559       vv(2)=pizda(1,2)+pizda(2,1)
6560       if (l.eq.j+1) then
6561         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6562      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6563      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6564       else
6565         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6566      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6567      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6568       endif
6569 C Cartesian gradient
6570       do iii=1,2
6571         do kkk=1,5
6572           do lll=1,3
6573             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6574      &        pizda(1,1))
6575             vv(1)=pizda(1,1)-pizda(2,2)
6576             vv(2)=pizda(1,2)+pizda(2,1)
6577             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6578      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6579      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6580           enddo
6581         enddo
6582       enddo
6583 c      goto 1112
6584       endif
6585 c1111  continue
6586 C Contribution from graph II
6587       call transpose2(EE(1,1,itk),auxmat(1,1))
6588       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6589       vv(1)=pizda(1,1)+pizda(2,2)
6590       vv(2)=pizda(2,1)-pizda(1,2)
6591       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6592      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6593       if (calc_grad) then
6594 C Explicit gradient in virtual-dihedral angles.
6595       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6596      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6597       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6598       vv(1)=pizda(1,1)+pizda(2,2)
6599       vv(2)=pizda(2,1)-pizda(1,2)
6600       if (l.eq.j+1) then
6601         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6602      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6603      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6604       else
6605         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6606      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6607      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6608       endif
6609 C Cartesian gradient
6610       do iii=1,2
6611         do kkk=1,5
6612           do lll=1,3
6613             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6614      &        pizda(1,1))
6615             vv(1)=pizda(1,1)+pizda(2,2)
6616             vv(2)=pizda(2,1)-pizda(1,2)
6617             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6618      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6619      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6620           enddo
6621         enddo
6622       enddo
6623 cd      goto 1112
6624       endif
6625 cd1111  continue
6626       if (l.eq.j+1) then
6627 cd        goto 1110
6628 C Parallel orientation
6629 C Contribution from graph III
6630         call transpose2(EUg(1,1,l),auxmat(1,1))
6631         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6632         vv(1)=pizda(1,1)-pizda(2,2)
6633         vv(2)=pizda(1,2)+pizda(2,1)
6634         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6635      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6636         if (calc_grad) then
6637 C Explicit gradient in virtual-dihedral angles.
6638         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6639      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6640      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6641         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6642         vv(1)=pizda(1,1)-pizda(2,2)
6643         vv(2)=pizda(1,2)+pizda(2,1)
6644         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6645      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6646      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6647         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6648         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6649         vv(1)=pizda(1,1)-pizda(2,2)
6650         vv(2)=pizda(1,2)+pizda(2,1)
6651         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6652      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6653      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6654 C Cartesian gradient
6655         do iii=1,2
6656           do kkk=1,5
6657             do lll=1,3
6658               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6659      &          pizda(1,1))
6660               vv(1)=pizda(1,1)-pizda(2,2)
6661               vv(2)=pizda(1,2)+pizda(2,1)
6662               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6663      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6664      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6665             enddo
6666           enddo
6667         enddo
6668 cd        goto 1112
6669         endif
6670 C Contribution from graph IV
6671 cd1110    continue
6672         call transpose2(EE(1,1,itl),auxmat(1,1))
6673         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6674         vv(1)=pizda(1,1)+pizda(2,2)
6675         vv(2)=pizda(2,1)-pizda(1,2)
6676         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6677      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6678         if (calc_grad) then
6679 C Explicit gradient in virtual-dihedral angles.
6680         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6681      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6682         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6683         vv(1)=pizda(1,1)+pizda(2,2)
6684         vv(2)=pizda(2,1)-pizda(1,2)
6685         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6686      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6687      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6688 C Cartesian gradient
6689         do iii=1,2
6690           do kkk=1,5
6691             do lll=1,3
6692               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6693      &          pizda(1,1))
6694               vv(1)=pizda(1,1)+pizda(2,2)
6695               vv(2)=pizda(2,1)-pizda(1,2)
6696               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6697      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6698      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6699             enddo
6700           enddo
6701         enddo
6702         endif
6703       else
6704 C Antiparallel orientation
6705 C Contribution from graph III
6706 c        goto 1110
6707         call transpose2(EUg(1,1,j),auxmat(1,1))
6708         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6709         vv(1)=pizda(1,1)-pizda(2,2)
6710         vv(2)=pizda(1,2)+pizda(2,1)
6711         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6712      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6713         if (calc_grad) then
6714 C Explicit gradient in virtual-dihedral angles.
6715         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6716      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6717      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6718         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6719         vv(1)=pizda(1,1)-pizda(2,2)
6720         vv(2)=pizda(1,2)+pizda(2,1)
6721         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6722      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6723      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6724         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6725         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6726         vv(1)=pizda(1,1)-pizda(2,2)
6727         vv(2)=pizda(1,2)+pizda(2,1)
6728         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6729      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6730      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6731 C Cartesian gradient
6732         do iii=1,2
6733           do kkk=1,5
6734             do lll=1,3
6735               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6736      &          pizda(1,1))
6737               vv(1)=pizda(1,1)-pizda(2,2)
6738               vv(2)=pizda(1,2)+pizda(2,1)
6739               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6740      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6741      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6742             enddo
6743           enddo
6744         enddo
6745 cd        goto 1112
6746         endif
6747 C Contribution from graph IV
6748 1110    continue
6749         call transpose2(EE(1,1,itj),auxmat(1,1))
6750         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6751         vv(1)=pizda(1,1)+pizda(2,2)
6752         vv(2)=pizda(2,1)-pizda(1,2)
6753         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6754      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6755         if (calc_grad) then
6756 C Explicit gradient in virtual-dihedral angles.
6757         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6758      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6759         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6760         vv(1)=pizda(1,1)+pizda(2,2)
6761         vv(2)=pizda(2,1)-pizda(1,2)
6762         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6763      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6764      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6765 C Cartesian gradient
6766         do iii=1,2
6767           do kkk=1,5
6768             do lll=1,3
6769               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6770      &          pizda(1,1))
6771               vv(1)=pizda(1,1)+pizda(2,2)
6772               vv(2)=pizda(2,1)-pizda(1,2)
6773               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6774      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6775      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6776             enddo
6777           enddo
6778         enddo
6779       endif
6780       endif
6781 1112  continue
6782       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6783 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6784 cd        write (2,*) 'ijkl',i,j,k,l
6785 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6786 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6787 cd      endif
6788 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6789 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6790 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6791 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6792       if (calc_grad) then
6793       if (j.lt.nres-1) then
6794         j1=j+1
6795         j2=j-1
6796       else
6797         j1=j-1
6798         j2=j-2
6799       endif
6800       if (l.lt.nres-1) then
6801         l1=l+1
6802         l2=l-1
6803       else
6804         l1=l-1
6805         l2=l-2
6806       endif
6807 cd      eij=1.0d0
6808 cd      ekl=1.0d0
6809 cd      ekont=1.0d0
6810 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6811       do ll=1,3
6812         ggg1(ll)=eel5*g_contij(ll,1)
6813         ggg2(ll)=eel5*g_contij(ll,2)
6814 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6815         ghalf=0.5d0*ggg1(ll)
6816 cd        ghalf=0.0d0
6817         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6818         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6819         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6820         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6821 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6822         ghalf=0.5d0*ggg2(ll)
6823 cd        ghalf=0.0d0
6824         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6825         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6826         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6827         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6828       enddo
6829 cd      goto 1112
6830       do m=i+1,j-1
6831         do ll=1,3
6832 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6833           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6834         enddo
6835       enddo
6836       do m=k+1,l-1
6837         do ll=1,3
6838 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6839           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6840         enddo
6841       enddo
6842 c1112  continue
6843       do m=i+2,j2
6844         do ll=1,3
6845           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6846         enddo
6847       enddo
6848       do m=k+2,l2
6849         do ll=1,3
6850           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6851         enddo
6852       enddo
6853 cd      do iii=1,nres-3
6854 cd        write (2,*) iii,g_corr5_loc(iii)
6855 cd      enddo
6856       endif
6857       eello5=ekont*eel5
6858 cd      write (2,*) 'ekont',ekont
6859 cd      write (iout,*) 'eello5',ekont*eel5
6860       return
6861       end
6862 c--------------------------------------------------------------------------
6863       double precision function eello6(i,j,k,l,jj,kk)
6864       implicit real*8 (a-h,o-z)
6865       include 'DIMENSIONS'
6866       include 'sizesclu.dat'
6867       include 'COMMON.IOUNITS'
6868       include 'COMMON.CHAIN'
6869       include 'COMMON.DERIV'
6870       include 'COMMON.INTERACT'
6871       include 'COMMON.CONTACTS'
6872       include 'COMMON.TORSION'
6873       include 'COMMON.VAR'
6874       include 'COMMON.GEO'
6875       include 'COMMON.FFIELD'
6876       double precision ggg1(3),ggg2(3)
6877 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6878 cd        eello6=0.0d0
6879 cd        return
6880 cd      endif
6881 cd      write (iout,*)
6882 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6883 cd     &   ' and',k,l
6884       eello6_1=0.0d0
6885       eello6_2=0.0d0
6886       eello6_3=0.0d0
6887       eello6_4=0.0d0
6888       eello6_5=0.0d0
6889       eello6_6=0.0d0
6890 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6891 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6892       do iii=1,2
6893         do kkk=1,5
6894           do lll=1,3
6895             derx(lll,kkk,iii)=0.0d0
6896           enddo
6897         enddo
6898       enddo
6899 cd      eij=facont_hb(jj,i)
6900 cd      ekl=facont_hb(kk,k)
6901 cd      ekont=eij*ekl
6902 cd      eij=1.0d0
6903 cd      ekl=1.0d0
6904 cd      ekont=1.0d0
6905       if (l.eq.j+1) then
6906         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6907         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6908         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6909         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6910         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6911         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6912       else
6913         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6914         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6915         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6916         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6917         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6918           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6919         else
6920           eello6_5=0.0d0
6921         endif
6922         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6923       endif
6924 C If turn contributions are considered, they will be handled separately.
6925       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6926 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6927 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6928 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6929 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6930 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6931 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6932 cd      goto 1112
6933       if (calc_grad) then
6934       if (j.lt.nres-1) then
6935         j1=j+1
6936         j2=j-1
6937       else
6938         j1=j-1
6939         j2=j-2
6940       endif
6941       if (l.lt.nres-1) then
6942         l1=l+1
6943         l2=l-1
6944       else
6945         l1=l-1
6946         l2=l-2
6947       endif
6948       do ll=1,3
6949         ggg1(ll)=eel6*g_contij(ll,1)
6950         ggg2(ll)=eel6*g_contij(ll,2)
6951 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6952         ghalf=0.5d0*ggg1(ll)
6953 cd        ghalf=0.0d0
6954         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6955         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6956         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6957         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6958         ghalf=0.5d0*ggg2(ll)
6959 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6960 cd        ghalf=0.0d0
6961         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6962         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6963         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6964         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6965       enddo
6966 cd      goto 1112
6967       do m=i+1,j-1
6968         do ll=1,3
6969 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6970           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6971         enddo
6972       enddo
6973       do m=k+1,l-1
6974         do ll=1,3
6975 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6976           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6977         enddo
6978       enddo
6979 1112  continue
6980       do m=i+2,j2
6981         do ll=1,3
6982           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6983         enddo
6984       enddo
6985       do m=k+2,l2
6986         do ll=1,3
6987           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6988         enddo
6989       enddo
6990 cd      do iii=1,nres-3
6991 cd        write (2,*) iii,g_corr6_loc(iii)
6992 cd      enddo
6993       endif
6994       eello6=ekont*eel6
6995 cd      write (2,*) 'ekont',ekont
6996 cd      write (iout,*) 'eello6',ekont*eel6
6997       return
6998       end
6999 c--------------------------------------------------------------------------
7000       double precision function eello6_graph1(i,j,k,l,imat,swap)
7001       implicit real*8 (a-h,o-z)
7002       include 'DIMENSIONS'
7003       include 'sizesclu.dat'
7004       include 'COMMON.IOUNITS'
7005       include 'COMMON.CHAIN'
7006       include 'COMMON.DERIV'
7007       include 'COMMON.INTERACT'
7008       include 'COMMON.CONTACTS'
7009       include 'COMMON.TORSION'
7010       include 'COMMON.VAR'
7011       include 'COMMON.GEO'
7012       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7013       logical swap
7014       logical lprn
7015       common /kutas/ lprn
7016 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7017 C                                                                              C
7018 C      Parallel       Antiparallel                                             C
7019 C                                                                              C
7020 C          o             o                                                     C
7021 C         /l\           /j\                                                    C
7022 C        /   \         /   \                                                   C
7023 C       /| o |         | o |\                                                  C
7024 C     \ j|/k\|  /   \  |/k\|l /                                                C
7025 C      \ /   \ /     \ /   \ /                                                 C
7026 C       o     o       o     o                                                  C
7027 C       i             i                                                        C
7028 C                                                                              C
7029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7030       itk=itortyp(itype(k))
7031       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7032       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7033       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7034       call transpose2(EUgC(1,1,k),auxmat(1,1))
7035       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7036       vv1(1)=pizda1(1,1)-pizda1(2,2)
7037       vv1(2)=pizda1(1,2)+pizda1(2,1)
7038       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7039       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7040       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7041       s5=scalar2(vv(1),Dtobr2(1,i))
7042 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7043       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7044       if (.not. calc_grad) return
7045       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7046      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7047      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7048      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7049      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7050      & +scalar2(vv(1),Dtobr2der(1,i)))
7051       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7052       vv1(1)=pizda1(1,1)-pizda1(2,2)
7053       vv1(2)=pizda1(1,2)+pizda1(2,1)
7054       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7055       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7056       if (l.eq.j+1) then
7057         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7058      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7059      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7060      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7061      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7062       else
7063         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7064      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7065      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7066      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7067      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7068       endif
7069       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7070       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7071       vv1(1)=pizda1(1,1)-pizda1(2,2)
7072       vv1(2)=pizda1(1,2)+pizda1(2,1)
7073       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7074      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7075      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7076      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7077       do iii=1,2
7078         if (swap) then
7079           ind=3-iii
7080         else
7081           ind=iii
7082         endif
7083         do kkk=1,5
7084           do lll=1,3
7085             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7086             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7087             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7088             call transpose2(EUgC(1,1,k),auxmat(1,1))
7089             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7090      &        pizda1(1,1))
7091             vv1(1)=pizda1(1,1)-pizda1(2,2)
7092             vv1(2)=pizda1(1,2)+pizda1(2,1)
7093             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7094             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7095      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7096             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7097      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7098             s5=scalar2(vv(1),Dtobr2(1,i))
7099             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7100           enddo
7101         enddo
7102       enddo
7103       return
7104       end
7105 c----------------------------------------------------------------------------
7106       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7107       implicit real*8 (a-h,o-z)
7108       include 'DIMENSIONS'
7109       include 'sizesclu.dat'
7110       include 'COMMON.IOUNITS'
7111       include 'COMMON.CHAIN'
7112       include 'COMMON.DERIV'
7113       include 'COMMON.INTERACT'
7114       include 'COMMON.CONTACTS'
7115       include 'COMMON.TORSION'
7116       include 'COMMON.VAR'
7117       include 'COMMON.GEO'
7118       logical swap
7119       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7120      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7121       logical lprn
7122       common /kutas/ lprn
7123 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7124 C                                                                              C
7125 C      Parallel       Antiparallel                                             C
7126 C                                                                              C
7127 C          o             o                                                     C
7128 C     \   /l\           /j\   /                                                C
7129 C      \ /   \         /   \ /                                                 C
7130 C       o| o |         | o |o                                                  C
7131 C     \ j|/k\|      \  |/k\|l                                                  C
7132 C      \ /   \       \ /   \                                                   C
7133 C       o             o                                                        C
7134 C       i             i                                                        C
7135 C                                                                              C
7136 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7137 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7138 C AL 7/4/01 s1 would occur in the sixth-order moment,
7139 C           but not in a cluster cumulant
7140 #ifdef MOMENT
7141       s1=dip(1,jj,i)*dip(1,kk,k)
7142 #endif
7143       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7144       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7145       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7146       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7147       call transpose2(EUg(1,1,k),auxmat(1,1))
7148       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7149       vv(1)=pizda(1,1)-pizda(2,2)
7150       vv(2)=pizda(1,2)+pizda(2,1)
7151       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7152 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7153 #ifdef MOMENT
7154       eello6_graph2=-(s1+s2+s3+s4)
7155 #else
7156       eello6_graph2=-(s2+s3+s4)
7157 #endif
7158 c      eello6_graph2=-s3
7159       if (.not. calc_grad) return
7160 C Derivatives in gamma(i-1)
7161       if (i.gt.1) then
7162 #ifdef MOMENT
7163         s1=dipderg(1,jj,i)*dip(1,kk,k)
7164 #endif
7165         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7166         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7167         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7168         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7169 #ifdef MOMENT
7170         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7171 #else
7172         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7173 #endif
7174 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7175       endif
7176 C Derivatives in gamma(k-1)
7177 #ifdef MOMENT
7178       s1=dip(1,jj,i)*dipderg(1,kk,k)
7179 #endif
7180       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7181       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7182       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7183       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7184       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7185       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7186       vv(1)=pizda(1,1)-pizda(2,2)
7187       vv(2)=pizda(1,2)+pizda(2,1)
7188       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7189 #ifdef MOMENT
7190       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7191 #else
7192       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7193 #endif
7194 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7195 C Derivatives in gamma(j-1) or gamma(l-1)
7196       if (j.gt.1) then
7197 #ifdef MOMENT
7198         s1=dipderg(3,jj,i)*dip(1,kk,k)
7199 #endif
7200         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7201         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7202         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7203         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7204         vv(1)=pizda(1,1)-pizda(2,2)
7205         vv(2)=pizda(1,2)+pizda(2,1)
7206         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7207 #ifdef MOMENT
7208         if (swap) then
7209           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7210         else
7211           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7212         endif
7213 #endif
7214         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7215 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7216       endif
7217 C Derivatives in gamma(l-1) or gamma(j-1)
7218       if (l.gt.1) then
7219 #ifdef MOMENT
7220         s1=dip(1,jj,i)*dipderg(3,kk,k)
7221 #endif
7222         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7223         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7224         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7225         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7226         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7227         vv(1)=pizda(1,1)-pizda(2,2)
7228         vv(2)=pizda(1,2)+pizda(2,1)
7229         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7230 #ifdef MOMENT
7231         if (swap) then
7232           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7233         else
7234           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7235         endif
7236 #endif
7237         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7238 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7239       endif
7240 C Cartesian derivatives.
7241       if (lprn) then
7242         write (2,*) 'In eello6_graph2'
7243         do iii=1,2
7244           write (2,*) 'iii=',iii
7245           do kkk=1,5
7246             write (2,*) 'kkk=',kkk
7247             do jjj=1,2
7248               write (2,'(3(2f10.5),5x)')
7249      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7250             enddo
7251           enddo
7252         enddo
7253       endif
7254       do iii=1,2
7255         do kkk=1,5
7256           do lll=1,3
7257 #ifdef MOMENT
7258             if (iii.eq.1) then
7259               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7260             else
7261               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7262             endif
7263 #endif
7264             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7265      &        auxvec(1))
7266             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7267             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7268      &        auxvec(1))
7269             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7270             call transpose2(EUg(1,1,k),auxmat(1,1))
7271             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7272      &        pizda(1,1))
7273             vv(1)=pizda(1,1)-pizda(2,2)
7274             vv(2)=pizda(1,2)+pizda(2,1)
7275             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7276 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7277 #ifdef MOMENT
7278             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7279 #else
7280             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7281 #endif
7282             if (swap) then
7283               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7284             else
7285               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7286             endif
7287           enddo
7288         enddo
7289       enddo
7290       return
7291       end
7292 c----------------------------------------------------------------------------
7293       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7294       implicit real*8 (a-h,o-z)
7295       include 'DIMENSIONS'
7296       include 'sizesclu.dat'
7297       include 'COMMON.IOUNITS'
7298       include 'COMMON.CHAIN'
7299       include 'COMMON.DERIV'
7300       include 'COMMON.INTERACT'
7301       include 'COMMON.CONTACTS'
7302       include 'COMMON.TORSION'
7303       include 'COMMON.VAR'
7304       include 'COMMON.GEO'
7305       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7306       logical swap
7307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7308 C                                                                              C
7309 C      Parallel       Antiparallel                                             C
7310 C                                                                              C
7311 C          o             o                                                     C
7312 C         /l\   /   \   /j\                                                    C
7313 C        /   \ /     \ /   \                                                   C
7314 C       /| o |o       o| o |\                                                  C
7315 C       j|/k\|  /      |/k\|l /                                                C
7316 C        /   \ /       /   \ /                                                 C
7317 C       /     o       /     o                                                  C
7318 C       i             i                                                        C
7319 C                                                                              C
7320 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7321 C
7322 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7323 C           energy moment and not to the cluster cumulant.
7324       iti=itortyp(itype(i))
7325       if (j.lt.nres-1) then
7326         itj1=itortyp(itype(j+1))
7327       else
7328         itj1=ntortyp+1
7329       endif
7330       itk=itortyp(itype(k))
7331       itk1=itortyp(itype(k+1))
7332       if (l.lt.nres-1) then
7333         itl1=itortyp(itype(l+1))
7334       else
7335         itl1=ntortyp+1
7336       endif
7337 #ifdef MOMENT
7338       s1=dip(4,jj,i)*dip(4,kk,k)
7339 #endif
7340       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7341       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7342       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7343       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7344       call transpose2(EE(1,1,itk),auxmat(1,1))
7345       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7346       vv(1)=pizda(1,1)+pizda(2,2)
7347       vv(2)=pizda(2,1)-pizda(1,2)
7348       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7349 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7350 #ifdef MOMENT
7351       eello6_graph3=-(s1+s2+s3+s4)
7352 #else
7353       eello6_graph3=-(s2+s3+s4)
7354 #endif
7355 c      eello6_graph3=-s4
7356       if (.not. calc_grad) return
7357 C Derivatives in gamma(k-1)
7358       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7359       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7360       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7361       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7362 C Derivatives in gamma(l-1)
7363       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7364       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7365       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7366       vv(1)=pizda(1,1)+pizda(2,2)
7367       vv(2)=pizda(2,1)-pizda(1,2)
7368       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7369       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7370 C Cartesian derivatives.
7371       do iii=1,2
7372         do kkk=1,5
7373           do lll=1,3
7374 #ifdef MOMENT
7375             if (iii.eq.1) then
7376               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7377             else
7378               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7379             endif
7380 #endif
7381             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7382      &        auxvec(1))
7383             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7384             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7385      &        auxvec(1))
7386             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7387             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7388      &        pizda(1,1))
7389             vv(1)=pizda(1,1)+pizda(2,2)
7390             vv(2)=pizda(2,1)-pizda(1,2)
7391             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7392 #ifdef MOMENT
7393             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7394 #else
7395             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7396 #endif
7397             if (swap) then
7398               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7399             else
7400               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7401             endif
7402 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7403           enddo
7404         enddo
7405       enddo
7406       return
7407       end
7408 c----------------------------------------------------------------------------
7409       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7410       implicit real*8 (a-h,o-z)
7411       include 'DIMENSIONS'
7412       include 'sizesclu.dat'
7413       include 'COMMON.IOUNITS'
7414       include 'COMMON.CHAIN'
7415       include 'COMMON.DERIV'
7416       include 'COMMON.INTERACT'
7417       include 'COMMON.CONTACTS'
7418       include 'COMMON.TORSION'
7419       include 'COMMON.VAR'
7420       include 'COMMON.GEO'
7421       include 'COMMON.FFIELD'
7422       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7423      & auxvec1(2),auxmat1(2,2)
7424       logical swap
7425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7426 C                                                                              C
7427 C      Parallel       Antiparallel                                             C
7428 C                                                                              C
7429 C          o             o                                                     C
7430 C         /l\   /   \   /j\                                                    C
7431 C        /   \ /     \ /   \                                                   C
7432 C       /| o |o       o| o |\                                                  C
7433 C     \ j|/k\|      \  |/k\|l                                                  C
7434 C      \ /   \       \ /   \                                                   C
7435 C       o     \       o     \                                                  C
7436 C       i             i                                                        C
7437 C                                                                              C
7438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7439 C
7440 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7441 C           energy moment and not to the cluster cumulant.
7442 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7443       iti=itortyp(itype(i))
7444       itj=itortyp(itype(j))
7445       if (j.lt.nres-1) then
7446         itj1=itortyp(itype(j+1))
7447       else
7448         itj1=ntortyp+1
7449       endif
7450       itk=itortyp(itype(k))
7451       if (k.lt.nres-1) then
7452         itk1=itortyp(itype(k+1))
7453       else
7454         itk1=ntortyp+1
7455       endif
7456       itl=itortyp(itype(l))
7457       if (l.lt.nres-1) then
7458         itl1=itortyp(itype(l+1))
7459       else
7460         itl1=ntortyp+1
7461       endif
7462 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7463 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7464 cd     & ' itl',itl,' itl1',itl1
7465 #ifdef MOMENT
7466       if (imat.eq.1) then
7467         s1=dip(3,jj,i)*dip(3,kk,k)
7468       else
7469         s1=dip(2,jj,j)*dip(2,kk,l)
7470       endif
7471 #endif
7472       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7473       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7474       if (j.eq.l+1) then
7475         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7476         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7477       else
7478         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7479         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7480       endif
7481       call transpose2(EUg(1,1,k),auxmat(1,1))
7482       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7483       vv(1)=pizda(1,1)-pizda(2,2)
7484       vv(2)=pizda(2,1)+pizda(1,2)
7485       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7486 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7487 #ifdef MOMENT
7488       eello6_graph4=-(s1+s2+s3+s4)
7489 #else
7490       eello6_graph4=-(s2+s3+s4)
7491 #endif
7492       if (.not. calc_grad) return
7493 C Derivatives in gamma(i-1)
7494       if (i.gt.1) then
7495 #ifdef MOMENT
7496         if (imat.eq.1) then
7497           s1=dipderg(2,jj,i)*dip(3,kk,k)
7498         else
7499           s1=dipderg(4,jj,j)*dip(2,kk,l)
7500         endif
7501 #endif
7502         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7503         if (j.eq.l+1) then
7504           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7505           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7506         else
7507           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7508           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7509         endif
7510         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7511         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7512 cd          write (2,*) 'turn6 derivatives'
7513 #ifdef MOMENT
7514           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7515 #else
7516           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7517 #endif
7518         else
7519 #ifdef MOMENT
7520           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7521 #else
7522           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7523 #endif
7524         endif
7525       endif
7526 C Derivatives in gamma(k-1)
7527 #ifdef MOMENT
7528       if (imat.eq.1) then
7529         s1=dip(3,jj,i)*dipderg(2,kk,k)
7530       else
7531         s1=dip(2,jj,j)*dipderg(4,kk,l)
7532       endif
7533 #endif
7534       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7535       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7536       if (j.eq.l+1) then
7537         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7538         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7539       else
7540         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7541         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7542       endif
7543       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7544       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7545       vv(1)=pizda(1,1)-pizda(2,2)
7546       vv(2)=pizda(2,1)+pizda(1,2)
7547       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7548       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7549 #ifdef MOMENT
7550         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7551 #else
7552         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7553 #endif
7554       else
7555 #ifdef MOMENT
7556         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7557 #else
7558         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7559 #endif
7560       endif
7561 C Derivatives in gamma(j-1) or gamma(l-1)
7562       if (l.eq.j+1 .and. l.gt.1) then
7563         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7564         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7565         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7566         vv(1)=pizda(1,1)-pizda(2,2)
7567         vv(2)=pizda(2,1)+pizda(1,2)
7568         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7569         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7570       else if (j.gt.1) then
7571         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7572         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7573         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7574         vv(1)=pizda(1,1)-pizda(2,2)
7575         vv(2)=pizda(2,1)+pizda(1,2)
7576         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7577         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7578           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7579         else
7580           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7581         endif
7582       endif
7583 C Cartesian derivatives.
7584       do iii=1,2
7585         do kkk=1,5
7586           do lll=1,3
7587 #ifdef MOMENT
7588             if (iii.eq.1) then
7589               if (imat.eq.1) then
7590                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7591               else
7592                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7593               endif
7594             else
7595               if (imat.eq.1) then
7596                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7597               else
7598                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7599               endif
7600             endif
7601 #endif
7602             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7603      &        auxvec(1))
7604             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7605             if (j.eq.l+1) then
7606               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7607      &          b1(1,itj1),auxvec(1))
7608               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7609             else
7610               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7611      &          b1(1,itl1),auxvec(1))
7612               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7613             endif
7614             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7615      &        pizda(1,1))
7616             vv(1)=pizda(1,1)-pizda(2,2)
7617             vv(2)=pizda(2,1)+pizda(1,2)
7618             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7619             if (swap) then
7620               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7621 #ifdef MOMENT
7622                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7623      &             -(s1+s2+s4)
7624 #else
7625                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7626      &             -(s2+s4)
7627 #endif
7628                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7629               else
7630 #ifdef MOMENT
7631                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7632 #else
7633                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7634 #endif
7635                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7636               endif
7637             else
7638 #ifdef MOMENT
7639               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7640 #else
7641               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7642 #endif
7643               if (l.eq.j+1) then
7644                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7645               else
7646                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7647               endif
7648             endif
7649           enddo
7650         enddo
7651       enddo
7652       return
7653       end
7654 c----------------------------------------------------------------------------
7655       double precision function eello_turn6(i,jj,kk)
7656       implicit real*8 (a-h,o-z)
7657       include 'DIMENSIONS'
7658       include 'sizesclu.dat'
7659       include 'COMMON.IOUNITS'
7660       include 'COMMON.CHAIN'
7661       include 'COMMON.DERIV'
7662       include 'COMMON.INTERACT'
7663       include 'COMMON.CONTACTS'
7664       include 'COMMON.TORSION'
7665       include 'COMMON.VAR'
7666       include 'COMMON.GEO'
7667       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7668      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7669      &  ggg1(3),ggg2(3)
7670       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7671      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7672 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7673 C           the respective energy moment and not to the cluster cumulant.
7674       eello_turn6=0.0d0
7675       j=i+4
7676       k=i+1
7677       l=i+3
7678       iti=itortyp(itype(i))
7679       itk=itortyp(itype(k))
7680       itk1=itortyp(itype(k+1))
7681       itl=itortyp(itype(l))
7682       itj=itortyp(itype(j))
7683 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7684 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7685 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7686 cd        eello6=0.0d0
7687 cd        return
7688 cd      endif
7689 cd      write (iout,*)
7690 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7691 cd     &   ' and',k,l
7692 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7693       do iii=1,2
7694         do kkk=1,5
7695           do lll=1,3
7696             derx_turn(lll,kkk,iii)=0.0d0
7697           enddo
7698         enddo
7699       enddo
7700 cd      eij=1.0d0
7701 cd      ekl=1.0d0
7702 cd      ekont=1.0d0
7703       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7704 cd      eello6_5=0.0d0
7705 cd      write (2,*) 'eello6_5',eello6_5
7706 #ifdef MOMENT
7707       call transpose2(AEA(1,1,1),auxmat(1,1))
7708       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7709       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7710       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7711 #else
7712       s1 = 0.0d0
7713 #endif
7714       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7715       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7716       s2 = scalar2(b1(1,itk),vtemp1(1))
7717 #ifdef MOMENT
7718       call transpose2(AEA(1,1,2),atemp(1,1))
7719       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7720       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7721       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7722 #else
7723       s8=0.0d0
7724 #endif
7725       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7726       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7727       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7728 #ifdef MOMENT
7729       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7730       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7731       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7732       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7733       ss13 = scalar2(b1(1,itk),vtemp4(1))
7734       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7735 #else
7736       s13=0.0d0
7737 #endif
7738 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7739 c      s1=0.0d0
7740 c      s2=0.0d0
7741 c      s8=0.0d0
7742 c      s12=0.0d0
7743 c      s13=0.0d0
7744       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7745       if (calc_grad) then
7746 C Derivatives in gamma(i+2)
7747 #ifdef MOMENT
7748       call transpose2(AEA(1,1,1),auxmatd(1,1))
7749       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7750       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7751       call transpose2(AEAderg(1,1,2),atempd(1,1))
7752       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7753       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7754 #else
7755       s8d=0.0d0
7756 #endif
7757       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7758       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7759       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7760 c      s1d=0.0d0
7761 c      s2d=0.0d0
7762 c      s8d=0.0d0
7763 c      s12d=0.0d0
7764 c      s13d=0.0d0
7765       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7766 C Derivatives in gamma(i+3)
7767 #ifdef MOMENT
7768       call transpose2(AEA(1,1,1),auxmatd(1,1))
7769       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7770       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7771       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7772 #else
7773       s1d=0.0d0
7774 #endif
7775       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7776       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7777       s2d = scalar2(b1(1,itk),vtemp1d(1))
7778 #ifdef MOMENT
7779       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7780       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7781 #endif
7782       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7783 #ifdef MOMENT
7784       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7785       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7786       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7787 #else
7788       s13d=0.0d0
7789 #endif
7790 c      s1d=0.0d0
7791 c      s2d=0.0d0
7792 c      s8d=0.0d0
7793 c      s12d=0.0d0
7794 c      s13d=0.0d0
7795 #ifdef MOMENT
7796       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7797      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7798 #else
7799       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7800      &               -0.5d0*ekont*(s2d+s12d)
7801 #endif
7802 C Derivatives in gamma(i+4)
7803       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7804       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7805       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7806 #ifdef MOMENT
7807       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7808       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7809       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7810 #else
7811       s13d = 0.0d0
7812 #endif
7813 c      s1d=0.0d0
7814 c      s2d=0.0d0
7815 c      s8d=0.0d0
7816 C      s12d=0.0d0
7817 c      s13d=0.0d0
7818 #ifdef MOMENT
7819       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7820 #else
7821       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7822 #endif
7823 C Derivatives in gamma(i+5)
7824 #ifdef MOMENT
7825       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7826       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7827       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7828 #else
7829       s1d = 0.0d0
7830 #endif
7831       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7832       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7833       s2d = scalar2(b1(1,itk),vtemp1d(1))
7834 #ifdef MOMENT
7835       call transpose2(AEA(1,1,2),atempd(1,1))
7836       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7837       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7838 #else
7839       s8d = 0.0d0
7840 #endif
7841       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7842       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7843 #ifdef MOMENT
7844       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7845       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7846       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7847 #else
7848       s13d = 0.0d0
7849 #endif
7850 c      s1d=0.0d0
7851 c      s2d=0.0d0
7852 c      s8d=0.0d0
7853 c      s12d=0.0d0
7854 c      s13d=0.0d0
7855 #ifdef MOMENT
7856       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7857      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7858 #else
7859       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7860      &               -0.5d0*ekont*(s2d+s12d)
7861 #endif
7862 C Cartesian derivatives
7863       do iii=1,2
7864         do kkk=1,5
7865           do lll=1,3
7866 #ifdef MOMENT
7867             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7868             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7869             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7870 #else
7871             s1d = 0.0d0
7872 #endif
7873             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7874             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7875      &          vtemp1d(1))
7876             s2d = scalar2(b1(1,itk),vtemp1d(1))
7877 #ifdef MOMENT
7878             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7879             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7880             s8d = -(atempd(1,1)+atempd(2,2))*
7881      &           scalar2(cc(1,1,itl),vtemp2(1))
7882 #else
7883             s8d = 0.0d0
7884 #endif
7885             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7886      &           auxmatd(1,1))
7887             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7888             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7889 c      s1d=0.0d0
7890 c      s2d=0.0d0
7891 c      s8d=0.0d0
7892 c      s12d=0.0d0
7893 c      s13d=0.0d0
7894 #ifdef MOMENT
7895             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7896      &        - 0.5d0*(s1d+s2d)
7897 #else
7898             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7899      &        - 0.5d0*s2d
7900 #endif
7901 #ifdef MOMENT
7902             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7903      &        - 0.5d0*(s8d+s12d)
7904 #else
7905             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7906      &        - 0.5d0*s12d
7907 #endif
7908           enddo
7909         enddo
7910       enddo
7911 #ifdef MOMENT
7912       do kkk=1,5
7913         do lll=1,3
7914           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7915      &      achuj_tempd(1,1))
7916           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7917           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7918           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7919           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7920           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7921      &      vtemp4d(1))
7922           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7923           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7924           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7925         enddo
7926       enddo
7927 #endif
7928 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7929 cd     &  16*eel_turn6_num
7930 cd      goto 1112
7931       if (j.lt.nres-1) then
7932         j1=j+1
7933         j2=j-1
7934       else
7935         j1=j-1
7936         j2=j-2
7937       endif
7938       if (l.lt.nres-1) then
7939         l1=l+1
7940         l2=l-1
7941       else
7942         l1=l-1
7943         l2=l-2
7944       endif
7945       do ll=1,3
7946         ggg1(ll)=eel_turn6*g_contij(ll,1)
7947         ggg2(ll)=eel_turn6*g_contij(ll,2)
7948         ghalf=0.5d0*ggg1(ll)
7949 cd        ghalf=0.0d0
7950         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7951      &    +ekont*derx_turn(ll,2,1)
7952         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7953         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7954      &    +ekont*derx_turn(ll,4,1)
7955         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7956         ghalf=0.5d0*ggg2(ll)
7957 cd        ghalf=0.0d0
7958         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7959      &    +ekont*derx_turn(ll,2,2)
7960         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7961         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7962      &    +ekont*derx_turn(ll,4,2)
7963         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7964       enddo
7965 cd      goto 1112
7966       do m=i+1,j-1
7967         do ll=1,3
7968           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7969         enddo
7970       enddo
7971       do m=k+1,l-1
7972         do ll=1,3
7973           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7974         enddo
7975       enddo
7976 1112  continue
7977       do m=i+2,j2
7978         do ll=1,3
7979           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7980         enddo
7981       enddo
7982       do m=k+2,l2
7983         do ll=1,3
7984           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7985         enddo
7986       enddo
7987 cd      do iii=1,nres-3
7988 cd        write (2,*) iii,g_corr6_loc(iii)
7989 cd      enddo
7990       endif
7991       eello_turn6=ekont*eel_turn6
7992 cd      write (2,*) 'ekont',ekont
7993 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7994       return
7995       end
7996 crc-------------------------------------------------
7997       SUBROUTINE MATVEC2(A1,V1,V2)
7998       implicit real*8 (a-h,o-z)
7999       include 'DIMENSIONS'
8000       DIMENSION A1(2,2),V1(2),V2(2)
8001 c      DO 1 I=1,2
8002 c        VI=0.0
8003 c        DO 3 K=1,2
8004 c    3     VI=VI+A1(I,K)*V1(K)
8005 c        Vaux(I)=VI
8006 c    1 CONTINUE
8007
8008       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8009       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8010
8011       v2(1)=vaux1
8012       v2(2)=vaux2
8013       END
8014 C---------------------------------------
8015       SUBROUTINE MATMAT2(A1,A2,A3)
8016       implicit real*8 (a-h,o-z)
8017       include 'DIMENSIONS'
8018       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8019 c      DIMENSION AI3(2,2)
8020 c        DO  J=1,2
8021 c          A3IJ=0.0
8022 c          DO K=1,2
8023 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8024 c          enddo
8025 c          A3(I,J)=A3IJ
8026 c       enddo
8027 c      enddo
8028
8029       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8030       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8031       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8032       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8033
8034       A3(1,1)=AI3_11
8035       A3(2,1)=AI3_21
8036       A3(1,2)=AI3_12
8037       A3(2,2)=AI3_22
8038       END
8039
8040 c-------------------------------------------------------------------------
8041       double precision function scalar2(u,v)
8042       implicit none
8043       double precision u(2),v(2)
8044       double precision sc
8045       integer i
8046       scalar2=u(1)*v(1)+u(2)*v(2)
8047       return
8048       end
8049
8050 C-----------------------------------------------------------------------------
8051
8052       subroutine transpose2(a,at)
8053       implicit none
8054       double precision a(2,2),at(2,2)
8055       at(1,1)=a(1,1)
8056       at(1,2)=a(2,1)
8057       at(2,1)=a(1,2)
8058       at(2,2)=a(2,2)
8059       return
8060       end
8061 c--------------------------------------------------------------------------
8062       subroutine transpose(n,a,at)
8063       implicit none
8064       integer n,i,j
8065       double precision a(n,n),at(n,n)
8066       do i=1,n
8067         do j=1,n
8068           at(j,i)=a(i,j)
8069         enddo
8070       enddo
8071       return
8072       end
8073 C---------------------------------------------------------------------------
8074       subroutine prodmat3(a1,a2,kk,transp,prod)
8075       implicit none
8076       integer i,j
8077       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8078       logical transp
8079 crc      double precision auxmat(2,2),prod_(2,2)
8080
8081       if (transp) then
8082 crc        call transpose2(kk(1,1),auxmat(1,1))
8083 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8084 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8085
8086            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8087      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8088            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8089      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8090            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8091      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8092            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8093      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8094
8095       else
8096 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8097 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8098
8099            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8100      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8101            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8102      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8103            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8104      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8105            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8106      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8107
8108       endif
8109 c      call transpose2(a2(1,1),a2t(1,1))
8110
8111 crc      print *,transp
8112 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8113 crc      print *,((prod(i,j),i=1,2),j=1,2)
8114
8115       return
8116       end
8117 C-----------------------------------------------------------------------------
8118       double precision function scalar(u,v)
8119       implicit none
8120       double precision u(3),v(3)
8121       double precision sc
8122       integer i
8123       sc=0.0d0
8124       do i=1,3
8125         sc=sc+u(i)*v(i)
8126       enddo
8127       scalar=sc
8128       return
8129       end
8130