source/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       endif
 104       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 105          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 106       endif
 107
 108
 109 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 110       if (constr_homology.ge.1) then
 111         call e_modeller(ehomology_constr)
 112       else
 113         ehomology_constr=0.0d0
 114       endif
 115
 116 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 117
 118 C     BARTEK for dfa test!
 119       if (wdfa_dist.gt.0) then
 120         call edfad(edfadis)
 121       else
 122         edfadis=0.0d0
 123       endif
 124 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 125       if (wdfa_tor.gt.0) then
 126         call edfat(edfator)
 127       else
 128         edfator=0.0d0
 129       endif
 130 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 131       if (wdfa_nei.gt.0) then
 132         call edfan(edfanei)
 133       else
 134         edfanei=0.0d0
 135       endif
 136 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 137       if (wdfa_beta.gt.0) then
 138         call edfab(edfabet)
 139       else
 140         edfabet=0.0d0
 141       endif
 142 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 143
 144 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 145 #ifdef SPLITELE
 146       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 147      & +wvdwpp*evdw1
 148      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 149      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 150      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 151      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 152      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 153      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 154      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 155      & +wdfa_beta*edfabet
 156 #else
 157       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 158      & +welec*fact(1)*(ees+evdw1)
 159      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 160      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 161      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 162      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 163      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 164      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 165      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 166      & +wdfa_beta*edfabet
 167 #endif
 168       energia(0)=etot
 169       energia(1)=evdw
 170 #ifdef SCP14
 171       energia(2)=evdw2-evdw2_14
 172       energia(17)=evdw2_14
 173 #else
 174       energia(2)=evdw2
 175       energia(17)=0.0d0
 176 #endif
 177 #ifdef SPLITELE
 178       energia(3)=ees
 179       energia(16)=evdw1
 180 #else
 181       energia(3)=ees+evdw1
 182       energia(16)=0.0d0
 183 #endif
 184       energia(4)=ecorr
 185       energia(5)=ecorr5
 186       energia(6)=ecorr6
 187       energia(7)=eel_loc
 188       energia(8)=eello_turn3
 189       energia(9)=eello_turn4
 190       energia(10)=eturn6
 191       energia(11)=ebe
 192       energia(12)=escloc
 193       energia(13)=etors
 194       energia(14)=etors_d
 195       energia(15)=ehpb
 196       energia(18)=estr
 197       energia(19)=esccor
 198       energia(20)=edihcnstr
 199       energia(21)=evdw_t
 200       energia(22)=ehomology_constr
 201       energia(23)=edfadis
 202       energia(24)=edfator
 203       energia(25)=edfanei
 204       energia(26)=edfabet
 205 c      if (dyn_ss) call dyn_set_nss
 206 c detecting NaNQ
 207 #ifdef ISNAN
 208 #ifdef AIX
 209       if (isnan(etot).ne.0) energia(0)=1.0d+99
 210 #else
 211       if (isnan(etot)) energia(0)=1.0d+99
 212 #endif
 213 #else
 214       i=0
 215 #ifdef WINPGI
 216       idumm=proc_proc(etot,i)
 217 #else
 218       call proc_proc(etot,i)
 219 #endif
 220       if(i.eq.1)energia(0)=1.0d+99
 221 #endif
 222 #ifdef MPL
 223 c     endif
 224 #endif
 225       if (calc_grad) then
 226 C
 227 C Sum up the components of the Cartesian gradient.
 228 C
 229 #ifdef SPLITELE
 230       do i=1,nct
 231         do j=1,3
 232           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 233      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 234      &                wbond*gradb(j,i)+
 235      &                wstrain*ghpbc(j,i)+
 236      &                wcorr*fact(3)*gradcorr(j,i)+
 237      &                wel_loc*fact(2)*gel_loc(j,i)+
 238      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 239      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 240      &                wcorr5*fact(4)*gradcorr5(j,i)+
 241      &                wcorr6*fact(5)*gradcorr6(j,i)+
 242      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 243      &                wsccor*fact(2)*gsccorc(j,i)+
 244      &                wdfa_dist*gdfad(j,i)+
 245      &                wdfa_tor*gdfat(j,i)+
 246      &                wdfa_nei*gdfan(j,i)+
 247      &                wdfa_beta*gdfab(j,i)
 248           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 249      &                  wbond*gradbx(j,i)+
 250      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 251      &                  wsccor*fact(2)*gsccorx(j,i)
 252         enddo
 253 #else
 254       do i=1,nct
 255         do j=1,3
 256           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 257      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 258      &                wbond*gradb(j,i)+
 259      &                wcorr*fact(3)*gradcorr(j,i)+
 260      &                wel_loc*fact(2)*gel_loc(j,i)+
 261      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 262      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 263      &                wcorr5*fact(4)*gradcorr5(j,i)+
 264      &                wcorr6*fact(5)*gradcorr6(j,i)+
 265      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 266      &                wsccor*fact(2)*gsccorc(j,i)+
 267      &                wdfa_dist*gdfad(j,i)+
 268      &                wdfa_tor*gdfat(j,i)+
 269      &                wdfa_nei*gdfan(j,i)+
 270      &                wdfa_beta*gdfab(j,i)
 271           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 272      &                  wbond*gradbx(j,i)+
 273      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 274      &                  wsccor*fact(1)*gsccorx(j,i)
 275         enddo
 276 #endif
 277       enddo
 278
 279
 280       do i=1,nres-3
 281         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 282      &   +wcorr5*fact(4)*g_corr5_loc(i)
 283      &   +wcorr6*fact(5)*g_corr6_loc(i)
 284      &   +wturn4*fact(3)*gel_loc_turn4(i)
 285      &   +wturn3*fact(2)*gel_loc_turn3(i)
 286      &   +wturn6*fact(5)*gel_loc_turn6(i)
 287      &   +wel_loc*fact(2)*gel_loc_loc(i)
 288      &   +wsccor*fact(1)*gsccor_loc(i)
 289       enddo
 290       endif
 291       return
 292       end
 293 C------------------------------------------------------------------------
 294       subroutine enerprint(energia,fact)
 295       implicit real*8 (a-h,o-z)
 296       include 'DIMENSIONS'
 297       include 'DIMENSIONS.ZSCOPT'
 298       include 'COMMON.IOUNITS'
 299       include 'COMMON.FFIELD'
 300       include 'COMMON.SBRIDGE'
 301       double precision energia(0:max_ene),fact(6)
 302       etot=energia(0)
 303       evdw=energia(1)+fact(6)*energia(21)
 304 #ifdef SCP14
 305       evdw2=energia(2)+energia(17)
 306 #else
 307       evdw2=energia(2)
 308 #endif
 309       ees=energia(3)
 310 #ifdef SPLITELE
 311       evdw1=energia(16)
 312 #endif
 313       ecorr=energia(4)
 314       ecorr5=energia(5)
 315       ecorr6=energia(6)
 316       eel_loc=energia(7)
 317       eello_turn3=energia(8)
 318       eello_turn4=energia(9)
 319       eello_turn6=energia(10)
 320       ebe=energia(11)
 321       escloc=energia(12)
 322       etors=energia(13)
 323       etors_d=energia(14)
 324       ehpb=energia(15)
 325       esccor=energia(19)
 326       edihcnstr=energia(20)
 327       estr=energia(18)
 328       ehomology_constr=energia(22)
 329       edfadis=energia(23)
 330       edfator=energia(24)
 331       edfanei=energia(25)
 332       edfabet=energia(26)
 333 #ifdef SPLITELE
 334       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 335      &  wvdwpp,
 336      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 337      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 338      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 339      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 340      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 341      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 342      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 343      &  wdfa_beta,etot
 344    10 format (/'Virtual-chain energies:'//
 345      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 346      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 347      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 348      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 349      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 350      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 351      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 352      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 353      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 354      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 355      & ' (SS bridges & dist. cnstr.)'/
 356      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 357      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 358      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 359      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 360      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 361      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 362      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 363      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 364      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 365      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 366      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 367      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 368      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 369      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 370      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 371      & 'ETOT=  ',1pE16.6,' (total)')
 372 #else
 373       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 374      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 375      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 376      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 377      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 378      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 379      &  edihcnstr,ehomology_constr,ebr*nss,
 380      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 381      &  wdfa_beta,etot
 382    10 format (/'Virtual-chain energies:'//
 383      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 384      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 385      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 386      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 387      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 388      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 389      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 390      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 391      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 392      & ' (SS bridges & dist. cnstr.)'/
 393      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 394      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 395      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 396      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 397      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 398      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 399      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 400      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 401      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 402      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 403      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 404      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 405      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 406      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 407      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 408      & 'ETOT=  ',1pE16.6,' (total)')
 409 #endif
 410       return
 411       end
 412 C-----------------------------------------------------------------------
 413       subroutine elj(evdw,evdw_t)
 414 C
 415 C This subroutine calculates the interaction energy of nonbonded side chains
 416 C assuming the LJ potential of interaction.
 417 C
 418       implicit real*8 (a-h,o-z)
 419       include 'DIMENSIONS'
 420       include 'DIMENSIONS.ZSCOPT'
 421       include "DIMENSIONS.COMPAR"
 422       parameter (accur=1.0d-10)
 423       include 'COMMON.GEO'
 424       include 'COMMON.VAR'
 425       include 'COMMON.LOCAL'
 426       include 'COMMON.CHAIN'
 427       include 'COMMON.DERIV'
 428       include 'COMMON.INTERACT'
 429       include 'COMMON.TORSION'
 430       include 'COMMON.ENEPS'
 431       include 'COMMON.SBRIDGE'
 432       include 'COMMON.NAMES'
 433       include 'COMMON.IOUNITS'
 434       include 'COMMON.CONTACTS'
 435       dimension gg(3)
 436       integer icant
 437       external icant
 438 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 439       do i=1,210
 440         do j=1,2
 441           eneps_temp(j,i)=0.0d0
 442         enddo
 443       enddo
 444       evdw=0.0D0
 445       evdw_t=0.0d0
 446       do i=iatsc_s,iatsc_e
 447         itypi=itype(i)
 448         itypi1=itype(i+1)
 449         xi=c(1,nres+i)
 450         yi=c(2,nres+i)
 451         zi=c(3,nres+i)
 452 C Change 12/1/95
 453         num_conti=0
 454 C
 455 C Calculate SC interaction energy.
 456 C
 457         do iint=1,nint_gr(i)
 458 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 459 cd   &                  'iend=',iend(i,iint)
 460           do j=istart(i,iint),iend(i,iint)
 461             itypj=itype(j)
 462             xj=c(1,nres+j)-xi
 463             yj=c(2,nres+j)-yi
 464             zj=c(3,nres+j)-zi
 465 C Change 12/1/95 to calculate four-body interactions
 466             rij=xj*xj+yj*yj+zj*zj
 467             rrij=1.0D0/rij
 468 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 469             eps0ij=eps(itypi,itypj)
 470             fac=rrij**expon2
 471             e1=fac*fac*aa(itypi,itypj)
 472             e2=fac*bb(itypi,itypj)
 473             evdwij=e1+e2
 474             ij=icant(itypi,itypj)
 475             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 476             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 477 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 478 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 479 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 480 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 481 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 482 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 483             if (bb(itypi,itypj).gt.0.0d0) then
 484               evdw=evdw+evdwij
 485             else
 486               evdw_t=evdw_t+evdwij
 487             endif
 488             if (calc_grad) then
 489 C
 490 C Calculate the components of the gradient in DC and X
 491 C
 492             fac=-rrij*(e1+evdwij)
 493             gg(1)=xj*fac
 494             gg(2)=yj*fac
 495             gg(3)=zj*fac
 496             do k=1,3
 497               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 498               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 499             enddo
 500             do k=i,j-1
 501               do l=1,3
 502                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 503               enddo
 504             enddo
 505             endif
 506 C
 507 C 12/1/95, revised on 5/20/97
 508 C
 509 C Calculate the contact function. The ith column of the array JCONT will
 510 C contain the numbers of atoms that make contacts with the atom I (of numbers
 511 C greater than I). The arrays FACONT and GACONT will contain the values of
 512 C the contact function and its derivative.
 513 C
 514 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 515 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 516 C Uncomment next line, if the correlation interactions are contact function only
 517             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 518               rij=dsqrt(rij)
 519               sigij=sigma(itypi,itypj)
 520               r0ij=rs0(itypi,itypj)
 521 C
 522 C Check whether the SC's are not too far to make a contact.
 523 C
 524               rcut=1.5d0*r0ij
 525               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 526 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 527 C
 528               if (fcont.gt.0.0D0) then
 529 C If the SC-SC distance if close to sigma, apply spline.
 530 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 531 cAdam &             fcont1,fprimcont1)
 532 cAdam           fcont1=1.0d0-fcont1
 533 cAdam           if (fcont1.gt.0.0d0) then
 534 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 535 cAdam             fcont=fcont*fcont1
 536 cAdam           endif
 537 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 538 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 539 cga             do k=1,3
 540 cga               gg(k)=gg(k)*eps0ij
 541 cga             enddo
 542 cga             eps0ij=-evdwij*eps0ij
 543 C Uncomment for AL's type of SC correlation interactions.
 544 cadam           eps0ij=-evdwij
 545                 num_conti=num_conti+1
 546                 jcont(num_conti,i)=j
 547                 facont(num_conti,i)=fcont*eps0ij
 548                 fprimcont=eps0ij*fprimcont/rij
 549                 fcont=expon*fcont
 550 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 551 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 552 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 553 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 554                 gacont(1,num_conti,i)=-fprimcont*xj
 555                 gacont(2,num_conti,i)=-fprimcont*yj
 556                 gacont(3,num_conti,i)=-fprimcont*zj
 557 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 558 cd              write (iout,'(2i3,3f10.5)')
 559 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 560               endif
 561             endif
 562           enddo      ! j
 563         enddo        ! iint
 564 C Change 12/1/95
 565         num_cont(i)=num_conti
 566       enddo          ! i
 567       if (calc_grad) then
 568       do i=1,nct
 569         do j=1,3
 570           gvdwc(j,i)=expon*gvdwc(j,i)
 571           gvdwx(j,i)=expon*gvdwx(j,i)
 572         enddo
 573       enddo
 574       endif
 575 C******************************************************************************
 576 C
 577 C                              N O T E !!!
 578 C
 579 C To save time, the factor of EXPON has been extracted from ALL components
 580 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 581 C use!
 582 C
 583 C******************************************************************************
 584       return
 585       end
 586 C-----------------------------------------------------------------------------
 587       subroutine eljk(evdw,evdw_t)
 588 C
 589 C This subroutine calculates the interaction energy of nonbonded side chains
 590 C assuming the LJK potential of interaction.
 591 C
 592       implicit real*8 (a-h,o-z)
 593       include 'DIMENSIONS'
 594       include 'DIMENSIONS.ZSCOPT'
 595       include "DIMENSIONS.COMPAR"
 596       include 'COMMON.GEO'
 597       include 'COMMON.VAR'
 598       include 'COMMON.LOCAL'
 599       include 'COMMON.CHAIN'
 600       include 'COMMON.DERIV'
 601       include 'COMMON.INTERACT'
 602       include 'COMMON.ENEPS'
 603       include 'COMMON.IOUNITS'
 604       include 'COMMON.NAMES'
 605       dimension gg(3)
 606       logical scheck
 607       integer icant
 608       external icant
 609 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 610       do i=1,210
 611         do j=1,2
 612           eneps_temp(j,i)=0.0d0
 613         enddo
 614       enddo
 615       evdw=0.0D0
 616       evdw_t=0.0d0
 617       do i=iatsc_s,iatsc_e
 618         itypi=itype(i)
 619         itypi1=itype(i+1)
 620         xi=c(1,nres+i)
 621         yi=c(2,nres+i)
 622         zi=c(3,nres+i)
 623 C
 624 C Calculate SC interaction energy.
 625 C
 626         do iint=1,nint_gr(i)
 627           do j=istart(i,iint),iend(i,iint)
 628             itypj=itype(j)
 629             xj=c(1,nres+j)-xi
 630             yj=c(2,nres+j)-yi
 631             zj=c(3,nres+j)-zi
 632             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 633             fac_augm=rrij**expon
 634             e_augm=augm(itypi,itypj)*fac_augm
 635             r_inv_ij=dsqrt(rrij)
 636             rij=1.0D0/r_inv_ij
 637             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 638             fac=r_shift_inv**expon
 639             e1=fac*fac*aa(itypi,itypj)
 640             e2=fac*bb(itypi,itypj)
 641             evdwij=e_augm+e1+e2
 642             ij=icant(itypi,itypj)
 643             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 644      &        /dabs(eps(itypi,itypj))
 645             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 646 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 647 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 648 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 649 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 650 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 651 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 652 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 653             if (bb(itypi,itypj).gt.0.0d0) then
 654               evdw=evdw+evdwij
 655             else
 656               evdw_t=evdw_t+evdwij
 657             endif
 658             if (calc_grad) then
 659 C
 660 C Calculate the components of the gradient in DC and X
 661 C
 662             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 663             gg(1)=xj*fac
 664             gg(2)=yj*fac
 665             gg(3)=zj*fac
 666             do k=1,3
 667               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 668               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 669             enddo
 670             do k=i,j-1
 671               do l=1,3
 672                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 673               enddo
 674             enddo
 675             endif
 676           enddo      ! j
 677         enddo        ! iint
 678       enddo          ! i
 679       if (calc_grad) then
 680       do i=1,nct
 681         do j=1,3
 682           gvdwc(j,i)=expon*gvdwc(j,i)
 683           gvdwx(j,i)=expon*gvdwx(j,i)
 684         enddo
 685       enddo
 686       endif
 687       return
 688       end
 689 C-----------------------------------------------------------------------------
 690       subroutine ebp(evdw,evdw_t)
 691 C
 692 C This subroutine calculates the interaction energy of nonbonded side chains
 693 C assuming the Berne-Pechukas potential of interaction.
 694 C
 695       implicit real*8 (a-h,o-z)
 696       include 'DIMENSIONS'
 697       include 'DIMENSIONS.ZSCOPT'
 698       include "DIMENSIONS.COMPAR"
 699       include 'COMMON.GEO'
 700       include 'COMMON.VAR'
 701       include 'COMMON.LOCAL'
 702       include 'COMMON.CHAIN'
 703       include 'COMMON.DERIV'
 704       include 'COMMON.NAMES'
 705       include 'COMMON.INTERACT'
 706       include 'COMMON.ENEPS'
 707       include 'COMMON.IOUNITS'
 708       include 'COMMON.CALC'
 709       common /srutu/ icall
 710 c     double precision rrsave(maxdim)
 711       logical lprn
 712       integer icant
 713       external icant
 714       do i=1,210
 715         do j=1,2
 716           eneps_temp(j,i)=0.0d0
 717         enddo
 718       enddo
 719       evdw=0.0D0
 720       evdw_t=0.0d0
 721 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 722 c     if (icall.eq.0) then
 723 c       lprn=.true.
 724 c     else
 725         lprn=.false.
 726 c     endif
 727       ind=0
 728       do i=iatsc_s,iatsc_e
 729         itypi=itype(i)
 730         itypi1=itype(i+1)
 731         xi=c(1,nres+i)
 732         yi=c(2,nres+i)
 733         zi=c(3,nres+i)
 734         dxi=dc_norm(1,nres+i)
 735         dyi=dc_norm(2,nres+i)
 736         dzi=dc_norm(3,nres+i)
 737         dsci_inv=vbld_inv(i+nres)
 738 C
 739 C Calculate SC interaction energy.
 740 C
 741         do iint=1,nint_gr(i)
 742           do j=istart(i,iint),iend(i,iint)
 743             ind=ind+1
 744             itypj=itype(j)
 745             dscj_inv=vbld_inv(j+nres)
 746             chi1=chi(itypi,itypj)
 747             chi2=chi(itypj,itypi)
 748             chi12=chi1*chi2
 749             chip1=chip(itypi)
 750             chip2=chip(itypj)
 751             chip12=chip1*chip2
 752             alf1=alp(itypi)
 753             alf2=alp(itypj)
 754             alf12=0.5D0*(alf1+alf2)
 755 C For diagnostics only!!!
 756 c           chi1=0.0D0
 757 c           chi2=0.0D0
 758 c           chi12=0.0D0
 759 c           chip1=0.0D0
 760 c           chip2=0.0D0
 761 c           chip12=0.0D0
 762 c           alf1=0.0D0
 763 c           alf2=0.0D0
 764 c           alf12=0.0D0
 765             xj=c(1,nres+j)-xi
 766             yj=c(2,nres+j)-yi
 767             zj=c(3,nres+j)-zi
 768             dxj=dc_norm(1,nres+j)
 769             dyj=dc_norm(2,nres+j)
 770             dzj=dc_norm(3,nres+j)
 771             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 772 cd          if (icall.eq.0) then
 773 cd            rrsave(ind)=rrij
 774 cd          else
 775 cd            rrij=rrsave(ind)
 776 cd          endif
 777             rij=dsqrt(rrij)
 778 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 779             call sc_angular
 780 C Calculate whole angle-dependent part of epsilon and contributions
 781 C to its derivatives
 782             fac=(rrij*sigsq)**expon2
 783             e1=fac*fac*aa(itypi,itypj)
 784             e2=fac*bb(itypi,itypj)
 785             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 786             eps2der=evdwij*eps3rt
 787             eps3der=evdwij*eps2rt
 788             evdwij=evdwij*eps2rt*eps3rt
 789             ij=icant(itypi,itypj)
 790             aux=eps1*eps2rt**2*eps3rt**2
 791             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 792      &        /dabs(eps(itypi,itypj))
 793             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 794             if (bb(itypi,itypj).gt.0.0d0) then
 795               evdw=evdw+evdwij
 796             else
 797               evdw_t=evdw_t+evdwij
 798             endif
 799             if (calc_grad) then
 800             if (lprn) then
 801             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 802             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 803 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 804 cd     &        restyp(itypi),i,restyp(itypj),j,
 805 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 806 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 807 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 808 cd     &        evdwij
 809             endif
 810 C Calculate gradient components.
 811             e1=e1*eps1*eps2rt**2*eps3rt**2
 812             fac=-expon*(e1+evdwij)
 813             sigder=fac/sigsq
 814             fac=rrij*fac
 815 C Calculate radial part of the gradient
 816             gg(1)=xj*fac
 817             gg(2)=yj*fac
 818             gg(3)=zj*fac
 819 C Calculate the angular part of the gradient and sum add the contributions
 820 C to the appropriate components of the Cartesian gradient.
 821             call sc_grad
 822             endif
 823           enddo      ! j
 824         enddo        ! iint
 825       enddo          ! i
 826 c     stop
 827       return
 828       end
 829 C-----------------------------------------------------------------------------
 830       subroutine egb(evdw,evdw_t)
 831 C
 832 C This subroutine calculates the interaction energy of nonbonded side chains
 833 C assuming the Gay-Berne potential of interaction.
 834 C
 835       implicit real*8 (a-h,o-z)
 836       include 'DIMENSIONS'
 837       include 'DIMENSIONS.ZSCOPT'
 838       include "DIMENSIONS.COMPAR"
 839       include 'COMMON.GEO'
 840       include 'COMMON.VAR'
 841       include 'COMMON.LOCAL'
 842       include 'COMMON.CHAIN'
 843       include 'COMMON.DERIV'
 844       include 'COMMON.NAMES'
 845       include 'COMMON.INTERACT'
 846       include 'COMMON.ENEPS'
 847       include 'COMMON.IOUNITS'
 848       include 'COMMON.CALC'
 849       include 'COMMON.SBRIDGE'
 850       logical lprn
 851       common /srutu/icall
 852       integer icant
 853       external icant
 854       do i=1,210
 855         do j=1,2
 856           eneps_temp(j,i)=0.0d0
 857         enddo
 858       enddo
 859 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 860       evdw=0.0D0
 861       evdw_t=0.0d0
 862       lprn=.false.
 863 c      if (icall.gt.0) lprn=.true.
 864       ind=0
 865       do i=iatsc_s,iatsc_e
 866         itypi=itype(i)
 867         itypi1=itype(i+1)
 868         xi=c(1,nres+i)
 869         yi=c(2,nres+i)
 870         zi=c(3,nres+i)
 871         dxi=dc_norm(1,nres+i)
 872         dyi=dc_norm(2,nres+i)
 873         dzi=dc_norm(3,nres+i)
 874         dsci_inv=vbld_inv(i+nres)
 875 C
 876 C Calculate SC interaction energy.
 877 C
 878         do iint=1,nint_gr(i)
 879           do j=istart(i,iint),iend(i,iint)
 880 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 881 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 882 C formation no electrostatic interactions should be calculated. If it
 883 C would be allowed NaN would appear
 884             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 885 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 886 C residue can or cannot form disulfide bond. There is still bug allowing
 887 C Cys...Cys...Cys bond formation
 888               call dyn_ssbond_ene(i,j,evdwij)
 889 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 890 C function in ssMD.F
 891               evdw=evdw+evdwij
 892 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 893 c     &                        'evdw',i,j,evdwij,' ss'
 894             ELSE
 895             ind=ind+1
 896             itypj=itype(j)
 897             dscj_inv=vbld_inv(j+nres)
 898             sig0ij=sigma(itypi,itypj)
 899             chi1=chi(itypi,itypj)
 900             chi2=chi(itypj,itypi)
 901             chi12=chi1*chi2
 902             chip1=chip(itypi)
 903             chip2=chip(itypj)
 904             chip12=chip1*chip2
 905             alf1=alp(itypi)
 906             alf2=alp(itypj)
 907             alf12=0.5D0*(alf1+alf2)
 908 C For diagnostics only!!!
 909 c           chi1=0.0D0
 910 c           chi2=0.0D0
 911 c           chi12=0.0D0
 912 c           chip1=0.0D0
 913 c           chip2=0.0D0
 914 c           chip12=0.0D0
 915 c           alf1=0.0D0
 916 c           alf2=0.0D0
 917 c           alf12=0.0D0
 918             xj=c(1,nres+j)-xi
 919             yj=c(2,nres+j)-yi
 920             zj=c(3,nres+j)-zi
 921             dxj=dc_norm(1,nres+j)
 922             dyj=dc_norm(2,nres+j)
 923             dzj=dc_norm(3,nres+j)
 924 c            write (iout,*) i,j,xj,yj,zj
 925             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 926             rij=dsqrt(rrij)
 927 C Calculate angle-dependent terms of energy and contributions to their
 928 C derivatives.
 929             call sc_angular
 930             sigsq=1.0D0/sigsq
 931             sig=sig0ij*dsqrt(sigsq)
 932             rij_shift=1.0D0/rij-sig+sig0ij
 933 C I hate to put IF's in the loops, but here don't have another choice!!!!
 934             if (rij_shift.le.0.0D0) then
 935               evdw=1.0D20
 936               return
 937             endif
 938             sigder=-sig*sigsq
 939 c---------------------------------------------------------------
 940             rij_shift=1.0D0/rij_shift
 941             fac=rij_shift**expon
 942             e1=fac*fac*aa(itypi,itypj)
 943             e2=fac*bb(itypi,itypj)
 944             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 945             eps2der=evdwij*eps3rt
 946             eps3der=evdwij*eps2rt
 947             evdwij=evdwij*eps2rt*eps3rt
 948             if (bb(itypi,itypj).gt.0) then
 949               evdw=evdw+evdwij
 950             else
 951               evdw_t=evdw_t+evdwij
 952             endif
 953             ij=icant(itypi,itypj)
 954             aux=eps1*eps2rt**2*eps3rt**2
 955             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 956      &        /dabs(eps(itypi,itypj))
 957             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 958 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 959 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 960 c     &         aux*e2/eps(itypi,itypj)
 961 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 962             if (lprn) then
 963             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 964             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 965             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 966      &        restyp(itypi),i,restyp(itypj),j,
 967      &        epsi,sigm,chi1,chi2,chip1,chip2,
 968      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 969      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 970      &        evdwij
 971             endif
 972             if (calc_grad) then
 973 C Calculate gradient components.
 974             e1=e1*eps1*eps2rt**2*eps3rt**2
 975             fac=-expon*(e1+evdwij)*rij_shift
 976             sigder=fac*sigder
 977             fac=rij*fac
 978 C Calculate the radial part of the gradient
 979             gg(1)=xj*fac
 980             gg(2)=yj*fac
 981             gg(3)=zj*fac
 982 C Calculate angular part of the gradient.
 983             call sc_grad
 984             endif
 985             ENDIF    ! dyn_ss
 986           enddo      ! j
 987         enddo        ! iint
 988       enddo          ! i
 989       return
 990       end
 991 C-----------------------------------------------------------------------------
 992       subroutine egbv(evdw,evdw_t)
 993 C
 994 C This subroutine calculates the interaction energy of nonbonded side chains
 995 C assuming the Gay-Berne-Vorobjev potential of interaction.
 996 C
 997       implicit real*8 (a-h,o-z)
 998       include 'DIMENSIONS'
 999       include 'DIMENSIONS.ZSCOPT'
1000       include "DIMENSIONS.COMPAR"
1001       include 'COMMON.GEO'
1002       include 'COMMON.VAR'
1003       include 'COMMON.LOCAL'
1004       include 'COMMON.CHAIN'
1005       include 'COMMON.DERIV'
1006       include 'COMMON.NAMES'
1007       include 'COMMON.INTERACT'
1008       include 'COMMON.ENEPS'
1009       include 'COMMON.IOUNITS'
1010       include 'COMMON.CALC'
1011       common /srutu/ icall
1012       logical lprn
1013       integer icant
1014       external icant
1015       do i=1,210
1016         do j=1,2
1017           eneps_temp(j,i)=0.0d0
1018         enddo
1019       enddo
1020       evdw=0.0D0
1021       evdw_t=0.0d0
1022 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1023       evdw=0.0D0
1024       lprn=.false.
1025 c      if (icall.gt.0) lprn=.true.
1026       ind=0
1027       do i=iatsc_s,iatsc_e
1028         itypi=itype(i)
1029         itypi1=itype(i+1)
1030         xi=c(1,nres+i)
1031         yi=c(2,nres+i)
1032         zi=c(3,nres+i)
1033         dxi=dc_norm(1,nres+i)
1034         dyi=dc_norm(2,nres+i)
1035         dzi=dc_norm(3,nres+i)
1036         dsci_inv=vbld_inv(i+nres)
1037 C
1038 C Calculate SC interaction energy.
1039 C
1040         do iint=1,nint_gr(i)
1041           do j=istart(i,iint),iend(i,iint)
1042             ind=ind+1
1043             itypj=itype(j)
1044             dscj_inv=vbld_inv(j+nres)
1045             sig0ij=sigma(itypi,itypj)
1046             r0ij=r0(itypi,itypj)
1047             chi1=chi(itypi,itypj)
1048             chi2=chi(itypj,itypi)
1049             chi12=chi1*chi2
1050             chip1=chip(itypi)
1051             chip2=chip(itypj)
1052             chip12=chip1*chip2
1053             alf1=alp(itypi)
1054             alf2=alp(itypj)
1055             alf12=0.5D0*(alf1+alf2)
1056 C For diagnostics only!!!
1057 c           chi1=0.0D0
1058 c           chi2=0.0D0
1059 c           chi12=0.0D0
1060 c           chip1=0.0D0
1061 c           chip2=0.0D0
1062 c           chip12=0.0D0
1063 c           alf1=0.0D0
1064 c           alf2=0.0D0
1065 c           alf12=0.0D0
1066             xj=c(1,nres+j)-xi
1067             yj=c(2,nres+j)-yi
1068             zj=c(3,nres+j)-zi
1069             dxj=dc_norm(1,nres+j)
1070             dyj=dc_norm(2,nres+j)
1071             dzj=dc_norm(3,nres+j)
1072             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1073             rij=dsqrt(rrij)
1074 C Calculate angle-dependent terms of energy and contributions to their
1075 C derivatives.
1076             call sc_angular
1077             sigsq=1.0D0/sigsq
1078             sig=sig0ij*dsqrt(sigsq)
1079             rij_shift=1.0D0/rij-sig+r0ij
1080 C I hate to put IF's in the loops, but here don't have another choice!!!!
1081             if (rij_shift.le.0.0D0) then
1082               evdw=1.0D20
1083               return
1084             endif
1085             sigder=-sig*sigsq
1086 c---------------------------------------------------------------
1087             rij_shift=1.0D0/rij_shift
1088             fac=rij_shift**expon
1089             e1=fac*fac*aa(itypi,itypj)
1090             e2=fac*bb(itypi,itypj)
1091             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1092             eps2der=evdwij*eps3rt
1093             eps3der=evdwij*eps2rt
1094             fac_augm=rrij**expon
1095             e_augm=augm(itypi,itypj)*fac_augm
1096             evdwij=evdwij*eps2rt*eps3rt
1097             if (bb(itypi,itypj).gt.0.0d0) then
1098               evdw=evdw+evdwij+e_augm
1099             else
1100               evdw_t=evdw_t+evdwij+e_augm
1101             endif
1102             ij=icant(itypi,itypj)
1103             aux=eps1*eps2rt**2*eps3rt**2
1104             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1105      &        /dabs(eps(itypi,itypj))
1106             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1107 c            eneps_temp(ij)=eneps_temp(ij)
1108 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1109 c            if (lprn) then
1110 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1111 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1112 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1113 c     &        restyp(itypi),i,restyp(itypj),j,
1114 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1115 c     &        chi1,chi2,chip1,chip2,
1116 c     &        eps1,eps2rt**2,eps3rt**2,
1117 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1118 c     &        evdwij+e_augm
1119 c            endif
1120             if (calc_grad) then
1121 C Calculate gradient components.
1122             e1=e1*eps1*eps2rt**2*eps3rt**2
1123             fac=-expon*(e1+evdwij)*rij_shift
1124             sigder=fac*sigder
1125             fac=rij*fac-2*expon*rrij*e_augm
1126 C Calculate the radial part of the gradient
1127             gg(1)=xj*fac
1128             gg(2)=yj*fac
1129             gg(3)=zj*fac
1130 C Calculate angular part of the gradient.
1131             call sc_grad
1132             endif
1133           enddo      ! j
1134         enddo        ! iint
1135       enddo          ! i
1136       return
1137       end
1138 C-----------------------------------------------------------------------------
1139       subroutine sc_angular
1140 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1141 C om12. Called by ebp, egb, and egbv.
1142       implicit none
1143       include 'COMMON.CALC'
1144       erij(1)=xj*rij
1145       erij(2)=yj*rij
1146       erij(3)=zj*rij
1147       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1148       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1149       om12=dxi*dxj+dyi*dyj+dzi*dzj
1150       chiom12=chi12*om12
1151 C Calculate eps1(om12) and its derivative in om12
1152       faceps1=1.0D0-om12*chiom12
1153       faceps1_inv=1.0D0/faceps1
1154       eps1=dsqrt(faceps1_inv)
1155 C Following variable is eps1*deps1/dom12
1156       eps1_om12=faceps1_inv*chiom12
1157 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1158 C and om12.
1159       om1om2=om1*om2
1160       chiom1=chi1*om1
1161       chiom2=chi2*om2
1162       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1163       sigsq=1.0D0-facsig*faceps1_inv
1164       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1165       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1166       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1167 C Calculate eps2 and its derivatives in om1, om2, and om12.
1168       chipom1=chip1*om1
1169       chipom2=chip2*om2
1170       chipom12=chip12*om12
1171       facp=1.0D0-om12*chipom12
1172       facp_inv=1.0D0/facp
1173       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1174 C Following variable is the square root of eps2
1175       eps2rt=1.0D0-facp1*facp_inv
1176 C Following three variables are the derivatives of the square root of eps
1177 C in om1, om2, and om12.
1178       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1179       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1180       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1181 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1182       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1183 C Calculate whole angle-dependent part of epsilon and contributions
1184 C to its derivatives
1185       return
1186       end
1187 C----------------------------------------------------------------------------
1188       subroutine sc_grad
1189       implicit real*8 (a-h,o-z)
1190       include 'DIMENSIONS'
1191       include 'DIMENSIONS.ZSCOPT'
1192       include 'COMMON.CHAIN'
1193       include 'COMMON.DERIV'
1194       include 'COMMON.CALC'
1195       double precision dcosom1(3),dcosom2(3)
1196       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1197       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1198       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1199      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1200       do k=1,3
1201         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1202         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1203       enddo
1204       do k=1,3
1205         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1206       enddo
1207       do k=1,3
1208         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1209      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1210      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1211         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1212      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1213      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1214       enddo
1215 C
1216 C Calculate the components of the gradient in DC and X
1217 C
1218       do k=i,j-1
1219         do l=1,3
1220           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1221         enddo
1222       enddo
1223       return
1224       end
1225 c------------------------------------------------------------------------------
1226       subroutine vec_and_deriv
1227       implicit real*8 (a-h,o-z)
1228       include 'DIMENSIONS'
1229       include 'DIMENSIONS.ZSCOPT'
1230       include 'COMMON.IOUNITS'
1231       include 'COMMON.GEO'
1232       include 'COMMON.VAR'
1233       include 'COMMON.LOCAL'
1234       include 'COMMON.CHAIN'
1235       include 'COMMON.VECTORS'
1236       include 'COMMON.DERIV'
1237       include 'COMMON.INTERACT'
1238       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1239 C Compute the local reference systems. For reference system (i), the
1240 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1241 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1242       do i=1,nres-1
1243 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1244           if (i.eq.nres-1) then
1245 C Case of the last full residue
1246 C Compute the Z-axis
1247             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1248             costh=dcos(pi-theta(nres))
1249             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1250             do k=1,3
1251               uz(k,i)=fac*uz(k,i)
1252             enddo
1253             if (calc_grad) then
1254 C Compute the derivatives of uz
1255             uzder(1,1,1)= 0.0d0
1256             uzder(2,1,1)=-dc_norm(3,i-1)
1257             uzder(3,1,1)= dc_norm(2,i-1)
1258             uzder(1,2,1)= dc_norm(3,i-1)
1259             uzder(2,2,1)= 0.0d0
1260             uzder(3,2,1)=-dc_norm(1,i-1)
1261             uzder(1,3,1)=-dc_norm(2,i-1)
1262             uzder(2,3,1)= dc_norm(1,i-1)
1263             uzder(3,3,1)= 0.0d0
1264             uzder(1,1,2)= 0.0d0
1265             uzder(2,1,2)= dc_norm(3,i)
1266             uzder(3,1,2)=-dc_norm(2,i)
1267             uzder(1,2,2)=-dc_norm(3,i)
1268             uzder(2,2,2)= 0.0d0
1269             uzder(3,2,2)= dc_norm(1,i)
1270             uzder(1,3,2)= dc_norm(2,i)
1271             uzder(2,3,2)=-dc_norm(1,i)
1272             uzder(3,3,2)= 0.0d0
1273             endif
1274 C Compute the Y-axis
1275             facy=fac
1276             do k=1,3
1277               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1278             enddo
1279             if (calc_grad) then
1280 C Compute the derivatives of uy
1281             do j=1,3
1282               do k=1,3
1283                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1284      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1285                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1286               enddo
1287               uyder(j,j,1)=uyder(j,j,1)-costh
1288               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1289             enddo
1290             do j=1,2
1291               do k=1,3
1292                 do l=1,3
1293                   uygrad(l,k,j,i)=uyder(l,k,j)
1294                   uzgrad(l,k,j,i)=uzder(l,k,j)
1295                 enddo
1296               enddo
1297             enddo
1298             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1299             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1300             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1301             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1302             endif
1303           else
1304 C Other residues
1305 C Compute the Z-axis
1306             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1307             costh=dcos(pi-theta(i+2))
1308             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1309             do k=1,3
1310               uz(k,i)=fac*uz(k,i)
1311             enddo
1312             if (calc_grad) then
1313 C Compute the derivatives of uz
1314             uzder(1,1,1)= 0.0d0
1315             uzder(2,1,1)=-dc_norm(3,i+1)
1316             uzder(3,1,1)= dc_norm(2,i+1)
1317             uzder(1,2,1)= dc_norm(3,i+1)
1318             uzder(2,2,1)= 0.0d0
1319             uzder(3,2,1)=-dc_norm(1,i+1)
1320             uzder(1,3,1)=-dc_norm(2,i+1)
1321             uzder(2,3,1)= dc_norm(1,i+1)
1322             uzder(3,3,1)= 0.0d0
1323             uzder(1,1,2)= 0.0d0
1324             uzder(2,1,2)= dc_norm(3,i)
1325             uzder(3,1,2)=-dc_norm(2,i)
1326             uzder(1,2,2)=-dc_norm(3,i)
1327             uzder(2,2,2)= 0.0d0
1328             uzder(3,2,2)= dc_norm(1,i)
1329             uzder(1,3,2)= dc_norm(2,i)
1330             uzder(2,3,2)=-dc_norm(1,i)
1331             uzder(3,3,2)= 0.0d0
1332             endif
1333 C Compute the Y-axis
1334             facy=fac
1335             do k=1,3
1336               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1337             enddo
1338             if (calc_grad) then
1339 C Compute the derivatives of uy
1340             do j=1,3
1341               do k=1,3
1342                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1343      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1344                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1345               enddo
1346               uyder(j,j,1)=uyder(j,j,1)-costh
1347               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1348             enddo
1349             do j=1,2
1350               do k=1,3
1351                 do l=1,3
1352                   uygrad(l,k,j,i)=uyder(l,k,j)
1353                   uzgrad(l,k,j,i)=uzder(l,k,j)
1354                 enddo
1355               enddo
1356             enddo
1357             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1358             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1359             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1360             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1361           endif
1362           endif
1363       enddo
1364       if (calc_grad) then
1365       do i=1,nres-1
1366         vbld_inv_temp(1)=vbld_inv(i+1)
1367         if (i.lt.nres-1) then
1368           vbld_inv_temp(2)=vbld_inv(i+2)
1369         else
1370           vbld_inv_temp(2)=vbld_inv(i)
1371         endif
1372         do j=1,2
1373           do k=1,3
1374             do l=1,3
1375               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1376               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1377             enddo
1378           enddo
1379         enddo
1380       enddo
1381       endif
1382       return
1383       end
1384 C-----------------------------------------------------------------------------
1385       subroutine vec_and_deriv_test
1386       implicit real*8 (a-h,o-z)
1387       include 'DIMENSIONS'
1388       include 'DIMENSIONS.ZSCOPT'
1389       include 'COMMON.IOUNITS'
1390       include 'COMMON.GEO'
1391       include 'COMMON.VAR'
1392       include 'COMMON.LOCAL'
1393       include 'COMMON.CHAIN'
1394       include 'COMMON.VECTORS'
1395       dimension uyder(3,3,2),uzder(3,3,2)
1396 C Compute the local reference systems. For reference system (i), the
1397 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1398 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1399       do i=1,nres-1
1400           if (i.eq.nres-1) then
1401 C Case of the last full residue
1402 C Compute the Z-axis
1403             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1404             costh=dcos(pi-theta(nres))
1405             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1406 c            write (iout,*) 'fac',fac,
1407 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1408             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1409             do k=1,3
1410               uz(k,i)=fac*uz(k,i)
1411             enddo
1412 C Compute the derivatives of uz
1413             uzder(1,1,1)= 0.0d0
1414             uzder(2,1,1)=-dc_norm(3,i-1)
1415             uzder(3,1,1)= dc_norm(2,i-1)
1416             uzder(1,2,1)= dc_norm(3,i-1)
1417             uzder(2,2,1)= 0.0d0
1418             uzder(3,2,1)=-dc_norm(1,i-1)
1419             uzder(1,3,1)=-dc_norm(2,i-1)
1420             uzder(2,3,1)= dc_norm(1,i-1)
1421             uzder(3,3,1)= 0.0d0
1422             uzder(1,1,2)= 0.0d0
1423             uzder(2,1,2)= dc_norm(3,i)
1424             uzder(3,1,2)=-dc_norm(2,i)
1425             uzder(1,2,2)=-dc_norm(3,i)
1426             uzder(2,2,2)= 0.0d0
1427             uzder(3,2,2)= dc_norm(1,i)
1428             uzder(1,3,2)= dc_norm(2,i)
1429             uzder(2,3,2)=-dc_norm(1,i)
1430             uzder(3,3,2)= 0.0d0
1431 C Compute the Y-axis
1432             do k=1,3
1433               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1434             enddo
1435             facy=fac
1436             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1437      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1438      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1439             do k=1,3
1440 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1441               uy(k,i)=
1442 c     &        facy*(
1443      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1444      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1445 c     &        )
1446             enddo
1447 c            write (iout,*) 'facy',facy,
1448 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1449             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1450             do k=1,3
1451               uy(k,i)=facy*uy(k,i)
1452             enddo
1453 C Compute the derivatives of uy
1454             do j=1,3
1455               do k=1,3
1456                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1457      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1458                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1459               enddo
1460 c              uyder(j,j,1)=uyder(j,j,1)-costh
1461 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1462               uyder(j,j,1)=uyder(j,j,1)
1463      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1464               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1465      &          +uyder(j,j,2)
1466             enddo
1467             do j=1,2
1468               do k=1,3
1469                 do l=1,3
1470                   uygrad(l,k,j,i)=uyder(l,k,j)
1471                   uzgrad(l,k,j,i)=uzder(l,k,j)
1472                 enddo
1473               enddo
1474             enddo
1475             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1476             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1477             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1478             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1479           else
1480 C Other residues
1481 C Compute the Z-axis
1482             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1483             costh=dcos(pi-theta(i+2))
1484             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1485             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1486             do k=1,3
1487               uz(k,i)=fac*uz(k,i)
1488             enddo
1489 C Compute the derivatives of uz
1490             uzder(1,1,1)= 0.0d0
1491             uzder(2,1,1)=-dc_norm(3,i+1)
1492             uzder(3,1,1)= dc_norm(2,i+1)
1493             uzder(1,2,1)= dc_norm(3,i+1)
1494             uzder(2,2,1)= 0.0d0
1495             uzder(3,2,1)=-dc_norm(1,i+1)
1496             uzder(1,3,1)=-dc_norm(2,i+1)
1497             uzder(2,3,1)= dc_norm(1,i+1)
1498             uzder(3,3,1)= 0.0d0
1499             uzder(1,1,2)= 0.0d0
1500             uzder(2,1,2)= dc_norm(3,i)
1501             uzder(3,1,2)=-dc_norm(2,i)
1502             uzder(1,2,2)=-dc_norm(3,i)
1503             uzder(2,2,2)= 0.0d0
1504             uzder(3,2,2)= dc_norm(1,i)
1505             uzder(1,3,2)= dc_norm(2,i)
1506             uzder(2,3,2)=-dc_norm(1,i)
1507             uzder(3,3,2)= 0.0d0
1508 C Compute the Y-axis
1509             facy=fac
1510             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1511      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1512      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1513             do k=1,3
1514 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1515               uy(k,i)=
1516 c     &        facy*(
1517      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1518      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1519 c     &        )
1520             enddo
1521 c            write (iout,*) 'facy',facy,
1522 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1523             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1524             do k=1,3
1525               uy(k,i)=facy*uy(k,i)
1526             enddo
1527 C Compute the derivatives of uy
1528             do j=1,3
1529               do k=1,3
1530                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1531      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1532                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1533               enddo
1534 c              uyder(j,j,1)=uyder(j,j,1)-costh
1535 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1536               uyder(j,j,1)=uyder(j,j,1)
1537      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1538               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1539      &          +uyder(j,j,2)
1540             enddo
1541             do j=1,2
1542               do k=1,3
1543                 do l=1,3
1544                   uygrad(l,k,j,i)=uyder(l,k,j)
1545                   uzgrad(l,k,j,i)=uzder(l,k,j)
1546                 enddo
1547               enddo
1548             enddo
1549             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1550             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1551             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1552             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1553           endif
1554       enddo
1555       do i=1,nres-1
1556         do j=1,2
1557           do k=1,3
1558             do l=1,3
1559               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1560               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1561             enddo
1562           enddo
1563         enddo
1564       enddo
1565       return
1566       end
1567 C-----------------------------------------------------------------------------
1568       subroutine check_vecgrad
1569       implicit real*8 (a-h,o-z)
1570       include 'DIMENSIONS'
1571       include 'DIMENSIONS.ZSCOPT'
1572       include 'COMMON.IOUNITS'
1573       include 'COMMON.GEO'
1574       include 'COMMON.VAR'
1575       include 'COMMON.LOCAL'
1576       include 'COMMON.CHAIN'
1577       include 'COMMON.VECTORS'
1578       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1579       dimension uyt(3,maxres),uzt(3,maxres)
1580       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1581       double precision delta /1.0d-7/
1582       call vec_and_deriv
1583 cd      do i=1,nres
1584 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1585 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1586 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1587 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1588 cd     &     (dc_norm(if90,i),if90=1,3)
1589 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1590 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1591 cd          write(iout,'(a)')
1592 cd      enddo
1593       do i=1,nres
1594         do j=1,2
1595           do k=1,3
1596             do l=1,3
1597               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1598               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1599             enddo
1600           enddo
1601         enddo
1602       enddo
1603       call vec_and_deriv
1604       do i=1,nres
1605         do j=1,3
1606           uyt(j,i)=uy(j,i)
1607           uzt(j,i)=uz(j,i)
1608         enddo
1609       enddo
1610       do i=1,nres
1611 cd        write (iout,*) 'i=',i
1612         do k=1,3
1613           erij(k)=dc_norm(k,i)
1614         enddo
1615         do j=1,3
1616           do k=1,3
1617             dc_norm(k,i)=erij(k)
1618           enddo
1619           dc_norm(j,i)=dc_norm(j,i)+delta
1620 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1621 c          do k=1,3
1622 c            dc_norm(k,i)=dc_norm(k,i)/fac
1623 c          enddo
1624 c          write (iout,*) (dc_norm(k,i),k=1,3)
1625 c          write (iout,*) (erij(k),k=1,3)
1626           call vec_and_deriv
1627           do k=1,3
1628             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1629             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1630             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1631             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1632           enddo
1633 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1634 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1635 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1636         enddo
1637         do k=1,3
1638           dc_norm(k,i)=erij(k)
1639         enddo
1640 cd        do k=1,3
1641 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1642 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1643 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1644 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1645 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1646 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1647 cd          write (iout,'(a)')
1648 cd        enddo
1649       enddo
1650       return
1651       end
1652 C--------------------------------------------------------------------------
1653       subroutine set_matrices
1654       implicit real*8 (a-h,o-z)
1655       include 'DIMENSIONS'
1656       include 'DIMENSIONS.ZSCOPT'
1657       include 'COMMON.IOUNITS'
1658       include 'COMMON.GEO'
1659       include 'COMMON.VAR'
1660       include 'COMMON.LOCAL'
1661       include 'COMMON.CHAIN'
1662       include 'COMMON.DERIV'
1663       include 'COMMON.INTERACT'
1664       include 'COMMON.CONTACTS'
1665       include 'COMMON.TORSION'
1666       include 'COMMON.VECTORS'
1667       include 'COMMON.FFIELD'
1668       double precision auxvec(2),auxmat(2,2)
1669 C
1670 C Compute the virtual-bond-torsional-angle dependent quantities needed
1671 C to calculate the el-loc multibody terms of various order.
1672 C
1673       do i=3,nres+1
1674         if (i .lt. nres+1) then
1675           sin1=dsin(phi(i))
1676           cos1=dcos(phi(i))
1677           sintab(i-2)=sin1
1678           costab(i-2)=cos1
1679           obrot(1,i-2)=cos1
1680           obrot(2,i-2)=sin1
1681           sin2=dsin(2*phi(i))
1682           cos2=dcos(2*phi(i))
1683           sintab2(i-2)=sin2
1684           costab2(i-2)=cos2
1685           obrot2(1,i-2)=cos2
1686           obrot2(2,i-2)=sin2
1687           Ug(1,1,i-2)=-cos1
1688           Ug(1,2,i-2)=-sin1
1689           Ug(2,1,i-2)=-sin1
1690           Ug(2,2,i-2)= cos1
1691           Ug2(1,1,i-2)=-cos2
1692           Ug2(1,2,i-2)=-sin2
1693           Ug2(2,1,i-2)=-sin2
1694           Ug2(2,2,i-2)= cos2
1695         else
1696           costab(i-2)=1.0d0
1697           sintab(i-2)=0.0d0
1698           obrot(1,i-2)=1.0d0
1699           obrot(2,i-2)=0.0d0
1700           obrot2(1,i-2)=0.0d0
1701           obrot2(2,i-2)=0.0d0
1702           Ug(1,1,i-2)=1.0d0
1703           Ug(1,2,i-2)=0.0d0
1704           Ug(2,1,i-2)=0.0d0
1705           Ug(2,2,i-2)=1.0d0
1706           Ug2(1,1,i-2)=0.0d0
1707           Ug2(1,2,i-2)=0.0d0
1708           Ug2(2,1,i-2)=0.0d0
1709           Ug2(2,2,i-2)=0.0d0
1710         endif
1711         if (i .gt. 3 .and. i .lt. nres+1) then
1712           obrot_der(1,i-2)=-sin1
1713           obrot_der(2,i-2)= cos1
1714           Ugder(1,1,i-2)= sin1
1715           Ugder(1,2,i-2)=-cos1
1716           Ugder(2,1,i-2)=-cos1
1717           Ugder(2,2,i-2)=-sin1
1718           dwacos2=cos2+cos2
1719           dwasin2=sin2+sin2
1720           obrot2_der(1,i-2)=-dwasin2
1721           obrot2_der(2,i-2)= dwacos2
1722           Ug2der(1,1,i-2)= dwasin2
1723           Ug2der(1,2,i-2)=-dwacos2
1724           Ug2der(2,1,i-2)=-dwacos2
1725           Ug2der(2,2,i-2)=-dwasin2
1726         else
1727           obrot_der(1,i-2)=0.0d0
1728           obrot_der(2,i-2)=0.0d0
1729           Ugder(1,1,i-2)=0.0d0
1730           Ugder(1,2,i-2)=0.0d0
1731           Ugder(2,1,i-2)=0.0d0
1732           Ugder(2,2,i-2)=0.0d0
1733           obrot2_der(1,i-2)=0.0d0
1734           obrot2_der(2,i-2)=0.0d0
1735           Ug2der(1,1,i-2)=0.0d0
1736           Ug2der(1,2,i-2)=0.0d0
1737           Ug2der(2,1,i-2)=0.0d0
1738           Ug2der(2,2,i-2)=0.0d0
1739         endif
1740         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1741           iti = itortyp(itype(i-2))
1742         else
1743           iti=ntortyp+1
1744         endif
1745         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1746           iti1 = itortyp(itype(i-1))
1747         else
1748           iti1=ntortyp+1
1749         endif
1750 cd        write (iout,*) '*******i',i,' iti1',iti
1751 cd        write (iout,*) 'b1',b1(:,iti)
1752 cd        write (iout,*) 'b2',b2(:,iti)
1753 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1754         if (i .gt. iatel_s+2) then
1755           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1756           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1757           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1758           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1759           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1760           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1761           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1762         else
1763           do k=1,2
1764             Ub2(k,i-2)=0.0d0
1765             Ctobr(k,i-2)=0.0d0
1766             Dtobr2(k,i-2)=0.0d0
1767             do l=1,2
1768               EUg(l,k,i-2)=0.0d0
1769               CUg(l,k,i-2)=0.0d0
1770               DUg(l,k,i-2)=0.0d0
1771               DtUg2(l,k,i-2)=0.0d0
1772             enddo
1773           enddo
1774         endif
1775         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1776         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1777         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1778         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1779         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1780         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1781         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1782         do k=1,2
1783           muder(k,i-2)=Ub2der(k,i-2)
1784         enddo
1785         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1786           iti1 = itortyp(itype(i-1))
1787         else
1788           iti1=ntortyp+1
1789         endif
1790         do k=1,2
1791           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1792         enddo
1793 C Vectors and matrices dependent on a single virtual-bond dihedral.
1794         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1795         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1796         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1797         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1798         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1799         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1800         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1801         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1802         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1803 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1804 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1805       enddo
1806 C Matrices dependent on two consecutive virtual-bond dihedrals.
1807 C The order of matrices is from left to right.
1808       do i=2,nres-1
1809         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1810         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1811         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1812         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1813         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1814         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1815         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1816         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1817       enddo
1818 cd      do i=1,nres
1819 cd        iti = itortyp(itype(i))
1820 cd        write (iout,*) i
1821 cd        do j=1,2
1822 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1823 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1824 cd        enddo
1825 cd      enddo
1826       return
1827       end
1828 C--------------------------------------------------------------------------
1829       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1830 C
1831 C This subroutine calculates the average interaction energy and its gradient
1832 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1833 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1834 C The potential depends both on the distance of peptide-group centers and on
1835 C the orientation of the CA-CA virtual bonds.
1836 C
1837       implicit real*8 (a-h,o-z)
1838       include 'DIMENSIONS'
1839       include 'DIMENSIONS.ZSCOPT'
1840       include 'DIMENSIONS.FREE'
1841       include 'COMMON.CONTROL'
1842       include 'COMMON.IOUNITS'
1843       include 'COMMON.GEO'
1844       include 'COMMON.VAR'
1845       include 'COMMON.LOCAL'
1846       include 'COMMON.CHAIN'
1847       include 'COMMON.DERIV'
1848       include 'COMMON.INTERACT'
1849       include 'COMMON.CONTACTS'
1850       include 'COMMON.TORSION'
1851       include 'COMMON.VECTORS'
1852       include 'COMMON.FFIELD'
1853       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1854      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1855       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1856      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1857       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1858 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1859       double precision scal_el /0.5d0/
1860 C 12/13/98
1861 C 13-go grudnia roku pamietnego...
1862       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1863      &                   0.0d0,1.0d0,0.0d0,
1864      &                   0.0d0,0.0d0,1.0d0/
1865 cd      write(iout,*) 'In EELEC'
1866 cd      do i=1,nloctyp
1867 cd        write(iout,*) 'Type',i
1868 cd        write(iout,*) 'B1',B1(:,i)
1869 cd        write(iout,*) 'B2',B2(:,i)
1870 cd        write(iout,*) 'CC',CC(:,:,i)
1871 cd        write(iout,*) 'DD',DD(:,:,i)
1872 cd        write(iout,*) 'EE',EE(:,:,i)
1873 cd      enddo
1874 cd      call check_vecgrad
1875 cd      stop
1876       if (icheckgrad.eq.1) then
1877         do i=1,nres-1
1878           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1879           do k=1,3
1880             dc_norm(k,i)=dc(k,i)*fac
1881           enddo
1882 c          write (iout,*) 'i',i,' fac',fac
1883         enddo
1884       endif
1885       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1886      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1887      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1888 cd      if (wel_loc.gt.0.0d0) then
1889         if (icheckgrad.eq.1) then
1890         call vec_and_deriv_test
1891         else
1892         call vec_and_deriv
1893         endif
1894         call set_matrices
1895       endif
1896 cd      do i=1,nres-1
1897 cd        write (iout,*) 'i=',i
1898 cd        do k=1,3
1899 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1900 cd        enddo
1901 cd        do k=1,3
1902 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1903 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1904 cd        enddo
1905 cd      enddo
1906       num_conti_hb=0
1907       ees=0.0D0
1908       evdw1=0.0D0
1909       eel_loc=0.0d0
1910       eello_turn3=0.0d0
1911       eello_turn4=0.0d0
1912       ind=0
1913       do i=1,nres
1914         num_cont_hb(i)=0
1915       enddo
1916 cd      print '(a)','Enter EELEC'
1917 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1918       do i=1,nres
1919         gel_loc_loc(i)=0.0d0
1920         gcorr_loc(i)=0.0d0
1921       enddo
1922       do i=iatel_s,iatel_e
1923         if (itel(i).eq.0) goto 1215
1924         dxi=dc(1,i)
1925         dyi=dc(2,i)
1926         dzi=dc(3,i)
1927         dx_normi=dc_norm(1,i)
1928         dy_normi=dc_norm(2,i)
1929         dz_normi=dc_norm(3,i)
1930         xmedi=c(1,i)+0.5d0*dxi
1931         ymedi=c(2,i)+0.5d0*dyi
1932         zmedi=c(3,i)+0.5d0*dzi
1933         num_conti=0
1934 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1935         do j=ielstart(i),ielend(i)
1936           if (itel(j).eq.0) goto 1216
1937           ind=ind+1
1938           iteli=itel(i)
1939           itelj=itel(j)
1940           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1941           aaa=app(iteli,itelj)
1942           bbb=bpp(iteli,itelj)
1943 C Diagnostics only!!!
1944 c         aaa=0.0D0
1945 c         bbb=0.0D0
1946 c         ael6i=0.0D0
1947 c         ael3i=0.0D0
1948 C End diagnostics
1949           ael6i=ael6(iteli,itelj)
1950           ael3i=ael3(iteli,itelj)
1951           dxj=dc(1,j)
1952           dyj=dc(2,j)
1953           dzj=dc(3,j)
1954           dx_normj=dc_norm(1,j)
1955           dy_normj=dc_norm(2,j)
1956           dz_normj=dc_norm(3,j)
1957           xj=c(1,j)+0.5D0*dxj-xmedi
1958           yj=c(2,j)+0.5D0*dyj-ymedi
1959           zj=c(3,j)+0.5D0*dzj-zmedi
1960           rij=xj*xj+yj*yj+zj*zj
1961           rrmij=1.0D0/rij
1962           rij=dsqrt(rij)
1963           rmij=1.0D0/rij
1964           r3ij=rrmij*rmij
1965           r6ij=r3ij*r3ij
1966           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1967           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1968           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1969           fac=cosa-3.0D0*cosb*cosg
1970           ev1=aaa*r6ij*r6ij
1971 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1972           if (j.eq.i+2) ev1=scal_el*ev1
1973           ev2=bbb*r6ij
1974           fac3=ael6i*r6ij
1975           fac4=ael3i*r3ij
1976           evdwij=ev1+ev2
1977           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1978           el2=fac4*fac
1979           eesij=el1+el2
1980 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1981 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1982           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1983           ees=ees+eesij
1984           evdw1=evdw1+evdwij
1985 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1986 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1987 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1988 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1989 C
1990 C Calculate contributions to the Cartesian gradient.
1991 C
1992 #ifdef SPLITELE
1993           facvdw=-6*rrmij*(ev1+evdwij)
1994           facel=-3*rrmij*(el1+eesij)
1995           fac1=fac
1996           erij(1)=xj*rmij
1997           erij(2)=yj*rmij
1998           erij(3)=zj*rmij
1999           if (calc_grad) then
2000 *
2001 * Radial derivatives. First process both termini of the fragment (i,j)
2002 *
2003           ggg(1)=facel*xj
2004           ggg(2)=facel*yj
2005           ggg(3)=facel*zj
2006           do k=1,3
2007             ghalf=0.5D0*ggg(k)
2008             gelc(k,i)=gelc(k,i)+ghalf
2009             gelc(k,j)=gelc(k,j)+ghalf
2010           enddo
2011 *
2012 * Loop over residues i+1 thru j-1.
2013 *
2014           do k=i+1,j-1
2015             do l=1,3
2016               gelc(l,k)=gelc(l,k)+ggg(l)
2017             enddo
2018           enddo
2019           ggg(1)=facvdw*xj
2020           ggg(2)=facvdw*yj
2021           ggg(3)=facvdw*zj
2022           do k=1,3
2023             ghalf=0.5D0*ggg(k)
2024             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2025             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2026           enddo
2027 *
2028 * Loop over residues i+1 thru j-1.
2029 *
2030           do k=i+1,j-1
2031             do l=1,3
2032               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2033             enddo
2034           enddo
2035 #else
2036           facvdw=ev1+evdwij
2037           facel=el1+eesij
2038           fac1=fac
2039           fac=-3*rrmij*(facvdw+facvdw+facel)
2040           erij(1)=xj*rmij
2041           erij(2)=yj*rmij
2042           erij(3)=zj*rmij
2043           if (calc_grad) then
2044 *
2045 * Radial derivatives. First process both termini of the fragment (i,j)
2046 *
2047           ggg(1)=fac*xj
2048           ggg(2)=fac*yj
2049           ggg(3)=fac*zj
2050           do k=1,3
2051             ghalf=0.5D0*ggg(k)
2052             gelc(k,i)=gelc(k,i)+ghalf
2053             gelc(k,j)=gelc(k,j)+ghalf
2054           enddo
2055 *
2056 * Loop over residues i+1 thru j-1.
2057 *
2058           do k=i+1,j-1
2059             do l=1,3
2060               gelc(l,k)=gelc(l,k)+ggg(l)
2061             enddo
2062           enddo
2063 #endif
2064 *
2065 * Angular part
2066 *
2067           ecosa=2.0D0*fac3*fac1+fac4
2068           fac4=-3.0D0*fac4
2069           fac3=-6.0D0*fac3
2070           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2071           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2072           do k=1,3
2073             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2074             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2075           enddo
2076 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2077 cd   &          (dcosg(k),k=1,3)
2078           do k=1,3
2079             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2080           enddo
2081           do k=1,3
2082             ghalf=0.5D0*ggg(k)
2083             gelc(k,i)=gelc(k,i)+ghalf
2084      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2085      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2086             gelc(k,j)=gelc(k,j)+ghalf
2087      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2088      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2089           enddo
2090           do k=i+1,j-1
2091             do l=1,3
2092               gelc(l,k)=gelc(l,k)+ggg(l)
2093             enddo
2094           enddo
2095           endif
2096
2097           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2098      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2099      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2100 C
2101 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2102 C   energy of a peptide unit is assumed in the form of a second-order
2103 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2104 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2105 C   are computed for EVERY pair of non-contiguous peptide groups.
2106 C
2107           if (j.lt.nres-1) then
2108             j1=j+1
2109             j2=j-1
2110           else
2111             j1=j-1
2112             j2=j-2
2113           endif
2114           kkk=0
2115           do k=1,2
2116             do l=1,2
2117               kkk=kkk+1
2118               muij(kkk)=mu(k,i)*mu(l,j)
2119             enddo
2120           enddo
2121 cd         write (iout,*) 'EELEC: i',i,' j',j
2122 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2123 cd          write(iout,*) 'muij',muij
2124           ury=scalar(uy(1,i),erij)
2125           urz=scalar(uz(1,i),erij)
2126           vry=scalar(uy(1,j),erij)
2127           vrz=scalar(uz(1,j),erij)
2128           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2129           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2130           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2131           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2132 C For diagnostics only
2133 cd          a22=1.0d0
2134 cd          a23=1.0d0
2135 cd          a32=1.0d0
2136 cd          a33=1.0d0
2137           fac=dsqrt(-ael6i)*r3ij
2138 cd          write (2,*) 'fac=',fac
2139 C For diagnostics only
2140 cd          fac=1.0d0
2141           a22=a22*fac
2142           a23=a23*fac
2143           a32=a32*fac
2144           a33=a33*fac
2145 cd          write (iout,'(4i5,4f10.5)')
2146 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2147 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2148 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2149 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2150 cd          write (iout,'(4f10.5)')
2151 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2152 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2153 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2154 cd           write (iout,'(2i3,9f10.5/)') i,j,
2155 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2156           if (calc_grad) then
2157 C Derivatives of the elements of A in virtual-bond vectors
2158           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2159 cd          do k=1,3
2160 cd            do l=1,3
2161 cd              erder(k,l)=0.0d0
2162 cd            enddo
2163 cd          enddo
2164           do k=1,3
2165             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2166             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2167             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2168             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2169             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2170             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2171             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2172             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2173             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2174             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2175             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2176             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2177           enddo
2178 cd          do k=1,3
2179 cd            do l=1,3
2180 cd              uryg(k,l)=0.0d0
2181 cd              urzg(k,l)=0.0d0
2182 cd              vryg(k,l)=0.0d0
2183 cd              vrzg(k,l)=0.0d0
2184 cd            enddo
2185 cd          enddo
2186 C Compute radial contributions to the gradient
2187           facr=-3.0d0*rrmij
2188           a22der=a22*facr
2189           a23der=a23*facr
2190           a32der=a32*facr
2191           a33der=a33*facr
2192 cd          a22der=0.0d0
2193 cd          a23der=0.0d0
2194 cd          a32der=0.0d0
2195 cd          a33der=0.0d0
2196           agg(1,1)=a22der*xj
2197           agg(2,1)=a22der*yj
2198           agg(3,1)=a22der*zj
2199           agg(1,2)=a23der*xj
2200           agg(2,2)=a23der*yj
2201           agg(3,2)=a23der*zj
2202           agg(1,3)=a32der*xj
2203           agg(2,3)=a32der*yj
2204           agg(3,3)=a32der*zj
2205           agg(1,4)=a33der*xj
2206           agg(2,4)=a33der*yj
2207           agg(3,4)=a33der*zj
2208 C Add the contributions coming from er
2209           fac3=-3.0d0*fac
2210           do k=1,3
2211             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2212             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2213             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2214             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2215           enddo
2216           do k=1,3
2217 C Derivatives in DC(i)
2218             ghalf1=0.5d0*agg(k,1)
2219             ghalf2=0.5d0*agg(k,2)
2220             ghalf3=0.5d0*agg(k,3)
2221             ghalf4=0.5d0*agg(k,4)
2222             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2223      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2224             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2225      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2226             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2227      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2228             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2229      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2230 C Derivatives in DC(i+1)
2231             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2232      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2233             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2234      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2235             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2236      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2237             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2238      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2239 C Derivatives in DC(j)
2240             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2241      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2242             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2243      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2244             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2245      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2246             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2247      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2248 C Derivatives in DC(j+1) or DC(nres-1)
2249             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2250      &      -3.0d0*vryg(k,3)*ury)
2251             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2252      &      -3.0d0*vrzg(k,3)*ury)
2253             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2254      &      -3.0d0*vryg(k,3)*urz)
2255             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2256      &      -3.0d0*vrzg(k,3)*urz)
2257 cd            aggi(k,1)=ghalf1
2258 cd            aggi(k,2)=ghalf2
2259 cd            aggi(k,3)=ghalf3
2260 cd            aggi(k,4)=ghalf4
2261 C Derivatives in DC(i+1)
2262 cd            aggi1(k,1)=agg(k,1)
2263 cd            aggi1(k,2)=agg(k,2)
2264 cd            aggi1(k,3)=agg(k,3)
2265 cd            aggi1(k,4)=agg(k,4)
2266 C Derivatives in DC(j)
2267 cd            aggj(k,1)=ghalf1
2268 cd            aggj(k,2)=ghalf2
2269 cd            aggj(k,3)=ghalf3
2270 cd            aggj(k,4)=ghalf4
2271 C Derivatives in DC(j+1)
2272 cd            aggj1(k,1)=0.0d0
2273 cd            aggj1(k,2)=0.0d0
2274 cd            aggj1(k,3)=0.0d0
2275 cd            aggj1(k,4)=0.0d0
2276             if (j.eq.nres-1 .and. i.lt.j-2) then
2277               do l=1,4
2278                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2279 cd                aggj1(k,l)=agg(k,l)
2280               enddo
2281             endif
2282           enddo
2283           endif
2284 c          goto 11111
2285 C Check the loc-el terms by numerical integration
2286           acipa(1,1)=a22
2287           acipa(1,2)=a23
2288           acipa(2,1)=a32
2289           acipa(2,2)=a33
2290           a22=-a22
2291           a23=-a23
2292           do l=1,2
2293             do k=1,3
2294               agg(k,l)=-agg(k,l)
2295               aggi(k,l)=-aggi(k,l)
2296               aggi1(k,l)=-aggi1(k,l)
2297               aggj(k,l)=-aggj(k,l)
2298               aggj1(k,l)=-aggj1(k,l)
2299             enddo
2300           enddo
2301           if (j.lt.nres-1) then
2302             a22=-a22
2303             a32=-a32
2304             do l=1,3,2
2305               do k=1,3
2306                 agg(k,l)=-agg(k,l)
2307                 aggi(k,l)=-aggi(k,l)
2308                 aggi1(k,l)=-aggi1(k,l)
2309                 aggj(k,l)=-aggj(k,l)
2310                 aggj1(k,l)=-aggj1(k,l)
2311               enddo
2312             enddo
2313           else
2314             a22=-a22
2315             a23=-a23
2316             a32=-a32
2317             a33=-a33
2318             do l=1,4
2319               do k=1,3
2320                 agg(k,l)=-agg(k,l)
2321                 aggi(k,l)=-aggi(k,l)
2322                 aggi1(k,l)=-aggi1(k,l)
2323                 aggj(k,l)=-aggj(k,l)
2324                 aggj1(k,l)=-aggj1(k,l)
2325               enddo
2326             enddo
2327           endif
2328           ENDIF ! WCORR
2329 11111     continue
2330           IF (wel_loc.gt.0.0d0) THEN
2331 C Contribution to the local-electrostatic energy coming from the i-j pair
2332           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2333      &     +a33*muij(4)
2334 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2335 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2336           eel_loc=eel_loc+eel_loc_ij
2337 C Partial derivatives in virtual-bond dihedral angles gamma
2338           if (calc_grad) then
2339           if (i.gt.1)
2340      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2341      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2342      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2343           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2344      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2345      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2346 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2347 cd          write(iout,*) 'agg  ',agg
2348 cd          write(iout,*) 'aggi ',aggi
2349 cd          write(iout,*) 'aggi1',aggi1
2350 cd          write(iout,*) 'aggj ',aggj
2351 cd          write(iout,*) 'aggj1',aggj1
2352
2353 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2354           do l=1,3
2355             ggg(l)=agg(l,1)*muij(1)+
2356      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2357           enddo
2358           do k=i+2,j2
2359             do l=1,3
2360               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2361             enddo
2362           enddo
2363 C Remaining derivatives of eello
2364           do l=1,3
2365             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2366      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2367             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2368      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2369             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2370      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2371             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2372      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2373           enddo
2374           endif
2375           ENDIF
2376           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2377 C Contributions from turns
2378             a_temp(1,1)=a22
2379             a_temp(1,2)=a23
2380             a_temp(2,1)=a32
2381             a_temp(2,2)=a33
2382             call eturn34(i,j,eello_turn3,eello_turn4)
2383           endif
2384 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2385           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2386 C
2387 C Calculate the contact function. The ith column of the array JCONT will
2388 C contain the numbers of atoms that make contacts with the atom I (of numbers
2389 C greater than I). The arrays FACONT and GACONT will contain the values of
2390 C the contact function and its derivative.
2391 c           r0ij=1.02D0*rpp(iteli,itelj)
2392 c           r0ij=1.11D0*rpp(iteli,itelj)
2393             r0ij=2.20D0*rpp(iteli,itelj)
2394 c           r0ij=1.55D0*rpp(iteli,itelj)
2395             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2396             if (fcont.gt.0.0D0) then
2397               num_conti=num_conti+1
2398               if (num_conti.gt.maxconts) then
2399                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2400      &                         ' will skip next contacts for this conf.'
2401               else
2402                 jcont_hb(num_conti,i)=j
2403                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2404      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2405 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2406 C  terms.
2407                 d_cont(num_conti,i)=rij
2408 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2409 C     --- Electrostatic-interaction matrix ---
2410                 a_chuj(1,1,num_conti,i)=a22
2411                 a_chuj(1,2,num_conti,i)=a23
2412                 a_chuj(2,1,num_conti,i)=a32
2413                 a_chuj(2,2,num_conti,i)=a33
2414 C     --- Gradient of rij
2415                 do kkk=1,3
2416                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2417                 enddo
2418 c             if (i.eq.1) then
2419 c                a_chuj(1,1,num_conti,i)=-0.61d0
2420 c                a_chuj(1,2,num_conti,i)= 0.4d0
2421 c                a_chuj(2,1,num_conti,i)= 0.65d0
2422 c                a_chuj(2,2,num_conti,i)= 0.50d0
2423 c             else if (i.eq.2) then
2424 c                a_chuj(1,1,num_conti,i)= 0.0d0
2425 c                a_chuj(1,2,num_conti,i)= 0.0d0
2426 c                a_chuj(2,1,num_conti,i)= 0.0d0
2427 c                a_chuj(2,2,num_conti,i)= 0.0d0
2428 c             endif
2429 C     --- and its gradients
2430 cd                write (iout,*) 'i',i,' j',j
2431 cd                do kkk=1,3
2432 cd                write (iout,*) 'iii 1 kkk',kkk
2433 cd                write (iout,*) agg(kkk,:)
2434 cd                enddo
2435 cd                do kkk=1,3
2436 cd                write (iout,*) 'iii 2 kkk',kkk
2437 cd                write (iout,*) aggi(kkk,:)
2438 cd                enddo
2439 cd                do kkk=1,3
2440 cd                write (iout,*) 'iii 3 kkk',kkk
2441 cd                write (iout,*) aggi1(kkk,:)
2442 cd                enddo
2443 cd                do kkk=1,3
2444 cd                write (iout,*) 'iii 4 kkk',kkk
2445 cd                write (iout,*) aggj(kkk,:)
2446 cd                enddo
2447 cd                do kkk=1,3
2448 cd                write (iout,*) 'iii 5 kkk',kkk
2449 cd                write (iout,*) aggj1(kkk,:)
2450 cd                enddo
2451                 kkll=0
2452                 do k=1,2
2453                   do l=1,2
2454                     kkll=kkll+1
2455                     do m=1,3
2456                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2457                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2458                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2459                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2460                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2461 c                      do mm=1,5
2462 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2463 c                      enddo
2464                     enddo
2465                   enddo
2466                 enddo
2467                 ENDIF
2468                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2469 C Calculate contact energies
2470                 cosa4=4.0D0*cosa
2471                 wij=cosa-3.0D0*cosb*cosg
2472                 cosbg1=cosb+cosg
2473                 cosbg2=cosb-cosg
2474 c               fac3=dsqrt(-ael6i)/r0ij**3
2475                 fac3=dsqrt(-ael6i)*r3ij
2476                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2477                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2478 c               ees0mij=0.0D0
2479                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2480                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2481 C Diagnostics. Comment out or remove after debugging!
2482 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2483 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2484 c               ees0m(num_conti,i)=0.0D0
2485 C End diagnostics.
2486 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2487 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2488                 facont_hb(num_conti,i)=fcont
2489                 if (calc_grad) then
2490 C Angular derivatives of the contact function
2491                 ees0pij1=fac3/ees0pij
2492                 ees0mij1=fac3/ees0mij
2493                 fac3p=-3.0D0*fac3*rrmij
2494                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2495                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2496 c               ees0mij1=0.0D0
2497                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2498                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2499                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2500                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2501                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2502                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2503                 ecosap=ecosa1+ecosa2
2504                 ecosbp=ecosb1+ecosb2
2505                 ecosgp=ecosg1+ecosg2
2506                 ecosam=ecosa1-ecosa2
2507                 ecosbm=ecosb1-ecosb2
2508                 ecosgm=ecosg1-ecosg2
2509 C Diagnostics
2510 c               ecosap=ecosa1
2511 c               ecosbp=ecosb1
2512 c               ecosgp=ecosg1
2513 c               ecosam=0.0D0
2514 c               ecosbm=0.0D0
2515 c               ecosgm=0.0D0
2516 C End diagnostics
2517                 fprimcont=fprimcont/rij
2518 cd              facont_hb(num_conti,i)=1.0D0
2519 C Following line is for diagnostics.
2520 cd              fprimcont=0.0D0
2521                 do k=1,3
2522                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2523                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2524                 enddo
2525                 do k=1,3
2526                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2527                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2528                 enddo
2529                 gggp(1)=gggp(1)+ees0pijp*xj
2530                 gggp(2)=gggp(2)+ees0pijp*yj
2531                 gggp(3)=gggp(3)+ees0pijp*zj
2532                 gggm(1)=gggm(1)+ees0mijp*xj
2533                 gggm(2)=gggm(2)+ees0mijp*yj
2534                 gggm(3)=gggm(3)+ees0mijp*zj
2535 C Derivatives due to the contact function
2536                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2537                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2538                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2539                 do k=1,3
2540                   ghalfp=0.5D0*gggp(k)
2541                   ghalfm=0.5D0*gggm(k)
2542                   gacontp_hb1(k,num_conti,i)=ghalfp
2543      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2544      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2545                   gacontp_hb2(k,num_conti,i)=ghalfp
2546      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2547      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2548                   gacontp_hb3(k,num_conti,i)=gggp(k)
2549                   gacontm_hb1(k,num_conti,i)=ghalfm
2550      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2551      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2552                   gacontm_hb2(k,num_conti,i)=ghalfm
2553      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2554      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2555                   gacontm_hb3(k,num_conti,i)=gggm(k)
2556                 enddo
2557                 endif
2558 C Diagnostics. Comment out or remove after debugging!
2559 cdiag           do k=1,3
2560 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2561 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2562 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2563 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2564 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2565 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2566 cdiag           enddo
2567               ENDIF ! wcorr
2568               endif  ! num_conti.le.maxconts
2569             endif  ! fcont.gt.0
2570           endif    ! j.gt.i+1
2571  1216     continue
2572         enddo ! j
2573         num_cont_hb(i)=num_conti
2574  1215   continue
2575       enddo   ! i
2576 cd      do i=1,nres
2577 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2578 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2579 cd      enddo
2580 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2581 ccc      eel_loc=eel_loc+eello_turn3
2582       return
2583       end
2584 C-----------------------------------------------------------------------------
2585       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2586 C Third- and fourth-order contributions from turns
2587       implicit real*8 (a-h,o-z)
2588       include 'DIMENSIONS'
2589       include 'DIMENSIONS.ZSCOPT'
2590       include 'COMMON.IOUNITS'
2591       include 'COMMON.GEO'
2592       include 'COMMON.VAR'
2593       include 'COMMON.LOCAL'
2594       include 'COMMON.CHAIN'
2595       include 'COMMON.DERIV'
2596       include 'COMMON.INTERACT'
2597       include 'COMMON.CONTACTS'
2598       include 'COMMON.TORSION'
2599       include 'COMMON.VECTORS'
2600       include 'COMMON.FFIELD'
2601       dimension ggg(3)
2602       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2603      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2604      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2605       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2606      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2607       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2608       if (j.eq.i+2) then
2609 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2610 C
2611 C               Third-order contributions
2612 C
2613 C                 (i+2)o----(i+3)
2614 C                      | |
2615 C                      | |
2616 C                 (i+1)o----i
2617 C
2618 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2619 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2620         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2621         call transpose2(auxmat(1,1),auxmat1(1,1))
2622         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2623         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2624 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2625 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2626 cd     &    ' eello_turn3_num',4*eello_turn3_num
2627         if (calc_grad) then
2628 C Derivatives in gamma(i)
2629         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2630         call transpose2(auxmat2(1,1),pizda(1,1))
2631         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2632         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2633 C Derivatives in gamma(i+1)
2634         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2635         call transpose2(auxmat2(1,1),pizda(1,1))
2636         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2637         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2638      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2639 C Cartesian derivatives
2640         do l=1,3
2641           a_temp(1,1)=aggi(l,1)
2642           a_temp(1,2)=aggi(l,2)
2643           a_temp(2,1)=aggi(l,3)
2644           a_temp(2,2)=aggi(l,4)
2645           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2646           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2647      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2648           a_temp(1,1)=aggi1(l,1)
2649           a_temp(1,2)=aggi1(l,2)
2650           a_temp(2,1)=aggi1(l,3)
2651           a_temp(2,2)=aggi1(l,4)
2652           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2653           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2654      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2655           a_temp(1,1)=aggj(l,1)
2656           a_temp(1,2)=aggj(l,2)
2657           a_temp(2,1)=aggj(l,3)
2658           a_temp(2,2)=aggj(l,4)
2659           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2660           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2661      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2662           a_temp(1,1)=aggj1(l,1)
2663           a_temp(1,2)=aggj1(l,2)
2664           a_temp(2,1)=aggj1(l,3)
2665           a_temp(2,2)=aggj1(l,4)
2666           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2667           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2668      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2669         enddo
2670         endif
2671       else if (j.eq.i+3) then
2672 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2673 C
2674 C               Fourth-order contributions
2675 C
2676 C                 (i+3)o----(i+4)
2677 C                     /  |
2678 C               (i+2)o   |
2679 C                     \  |
2680 C                 (i+1)o----i
2681 C
2682 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2683 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2684         iti1=itortyp(itype(i+1))
2685         iti2=itortyp(itype(i+2))
2686         iti3=itortyp(itype(i+3))
2687         call transpose2(EUg(1,1,i+1),e1t(1,1))
2688         call transpose2(Eug(1,1,i+2),e2t(1,1))
2689         call transpose2(Eug(1,1,i+3),e3t(1,1))
2690         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2691         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2692         s1=scalar2(b1(1,iti2),auxvec(1))
2693         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2694         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2695         s2=scalar2(b1(1,iti1),auxvec(1))
2696         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2697         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2698         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2699         eello_turn4=eello_turn4-(s1+s2+s3)
2700 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2701 cd     &    ' eello_turn4_num',8*eello_turn4_num
2702 C Derivatives in gamma(i)
2703         if (calc_grad) then
2704         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2705         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2706         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2707         s1=scalar2(b1(1,iti2),auxvec(1))
2708         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2709         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2710         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2711 C Derivatives in gamma(i+1)
2712         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2713         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2714         s2=scalar2(b1(1,iti1),auxvec(1))
2715         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2716         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2717         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2718         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2719 C Derivatives in gamma(i+2)
2720         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2721         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2722         s1=scalar2(b1(1,iti2),auxvec(1))
2723         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2724         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2725         s2=scalar2(b1(1,iti1),auxvec(1))
2726         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2727         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2728         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2729         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2730 C Cartesian derivatives
2731 C Derivatives of this turn contributions in DC(i+2)
2732         if (j.lt.nres-1) then
2733           do l=1,3
2734             a_temp(1,1)=agg(l,1)
2735             a_temp(1,2)=agg(l,2)
2736             a_temp(2,1)=agg(l,3)
2737             a_temp(2,2)=agg(l,4)
2738             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2739             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2740             s1=scalar2(b1(1,iti2),auxvec(1))
2741             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2742             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2743             s2=scalar2(b1(1,iti1),auxvec(1))
2744             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2745             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2746             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2747             ggg(l)=-(s1+s2+s3)
2748             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2749           enddo
2750         endif
2751 C Remaining derivatives of this turn contribution
2752         do l=1,3
2753           a_temp(1,1)=aggi(l,1)
2754           a_temp(1,2)=aggi(l,2)
2755           a_temp(2,1)=aggi(l,3)
2756           a_temp(2,2)=aggi(l,4)
2757           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2758           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2759           s1=scalar2(b1(1,iti2),auxvec(1))
2760           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2761           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2762           s2=scalar2(b1(1,iti1),auxvec(1))
2763           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2764           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2765           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2766           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2767           a_temp(1,1)=aggi1(l,1)
2768           a_temp(1,2)=aggi1(l,2)
2769           a_temp(2,1)=aggi1(l,3)
2770           a_temp(2,2)=aggi1(l,4)
2771           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2772           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2773           s1=scalar2(b1(1,iti2),auxvec(1))
2774           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2775           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2776           s2=scalar2(b1(1,iti1),auxvec(1))
2777           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2778           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2779           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2780           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2781           a_temp(1,1)=aggj(l,1)
2782           a_temp(1,2)=aggj(l,2)
2783           a_temp(2,1)=aggj(l,3)
2784           a_temp(2,2)=aggj(l,4)
2785           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2786           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2787           s1=scalar2(b1(1,iti2),auxvec(1))
2788           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2789           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2790           s2=scalar2(b1(1,iti1),auxvec(1))
2791           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2792           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2793           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2794           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2795           a_temp(1,1)=aggj1(l,1)
2796           a_temp(1,2)=aggj1(l,2)
2797           a_temp(2,1)=aggj1(l,3)
2798           a_temp(2,2)=aggj1(l,4)
2799           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2800           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2801           s1=scalar2(b1(1,iti2),auxvec(1))
2802           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2803           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2804           s2=scalar2(b1(1,iti1),auxvec(1))
2805           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2806           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2807           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2808           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2809         enddo
2810         endif
2811       endif
2812       return
2813       end
2814 C-----------------------------------------------------------------------------
2815       subroutine vecpr(u,v,w)
2816       implicit real*8(a-h,o-z)
2817       dimension u(3),v(3),w(3)
2818       w(1)=u(2)*v(3)-u(3)*v(2)
2819       w(2)=-u(1)*v(3)+u(3)*v(1)
2820       w(3)=u(1)*v(2)-u(2)*v(1)
2821       return
2822       end
2823 C-----------------------------------------------------------------------------
2824       subroutine unormderiv(u,ugrad,unorm,ungrad)
2825 C This subroutine computes the derivatives of a normalized vector u, given
2826 C the derivatives computed without normalization conditions, ugrad. Returns
2827 C ungrad.
2828       implicit none
2829       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2830       double precision vec(3)
2831       double precision scalar
2832       integer i,j
2833 c      write (2,*) 'ugrad',ugrad
2834 c      write (2,*) 'u',u
2835       do i=1,3
2836         vec(i)=scalar(ugrad(1,i),u(1))
2837       enddo
2838 c      write (2,*) 'vec',vec
2839       do i=1,3
2840         do j=1,3
2841           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2842         enddo
2843       enddo
2844 c      write (2,*) 'ungrad',ungrad
2845       return
2846       end
2847 C-----------------------------------------------------------------------------
2848       subroutine escp(evdw2,evdw2_14)
2849 C
2850 C This subroutine calculates the excluded-volume interaction energy between
2851 C peptide-group centers and side chains and its gradient in virtual-bond and
2852 C side-chain vectors.
2853 C
2854       implicit real*8 (a-h,o-z)
2855       include 'DIMENSIONS'
2856       include 'DIMENSIONS.ZSCOPT'
2857       include 'COMMON.GEO'
2858       include 'COMMON.VAR'
2859       include 'COMMON.LOCAL'
2860       include 'COMMON.CHAIN'
2861       include 'COMMON.DERIV'
2862       include 'COMMON.INTERACT'
2863       include 'COMMON.FFIELD'
2864       include 'COMMON.IOUNITS'
2865       dimension ggg(3)
2866       evdw2=0.0D0
2867       evdw2_14=0.0d0
2868 cd    print '(a)','Enter ESCP'
2869 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2870 c     &  ' scal14',scal14
2871       do i=iatscp_s,iatscp_e
2872         iteli=itel(i)
2873 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2874 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2875         if (iteli.eq.0) goto 1225
2876         xi=0.5D0*(c(1,i)+c(1,i+1))
2877         yi=0.5D0*(c(2,i)+c(2,i+1))
2878         zi=0.5D0*(c(3,i)+c(3,i+1))
2879
2880         do iint=1,nscp_gr(i)
2881
2882         do j=iscpstart(i,iint),iscpend(i,iint)
2883           itypj=itype(j)
2884 C Uncomment following three lines for SC-p interactions
2885 c         xj=c(1,nres+j)-xi
2886 c         yj=c(2,nres+j)-yi
2887 c         zj=c(3,nres+j)-zi
2888 C Uncomment following three lines for Ca-p interactions
2889           xj=c(1,j)-xi
2890           yj=c(2,j)-yi
2891           zj=c(3,j)-zi
2892           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2893           fac=rrij**expon2
2894           e1=fac*fac*aad(itypj,iteli)
2895           e2=fac*bad(itypj,iteli)
2896           if (iabs(j-i) .le. 2) then
2897             e1=scal14*e1
2898             e2=scal14*e2
2899             evdw2_14=evdw2_14+e1+e2
2900           endif
2901           evdwij=e1+e2
2902 c          write (iout,*) i,j,evdwij
2903           evdw2=evdw2+evdwij
2904           if (calc_grad) then
2905 C
2906 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2907 C
2908           fac=-(evdwij+e1)*rrij
2909           ggg(1)=xj*fac
2910           ggg(2)=yj*fac
2911           ggg(3)=zj*fac
2912           if (j.lt.i) then
2913 cd          write (iout,*) 'j<i'
2914 C Uncomment following three lines for SC-p interactions
2915 c           do k=1,3
2916 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2917 c           enddo
2918           else
2919 cd          write (iout,*) 'j>i'
2920             do k=1,3
2921               ggg(k)=-ggg(k)
2922 C Uncomment following line for SC-p interactions
2923 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2924             enddo
2925           endif
2926           do k=1,3
2927             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2928           enddo
2929           kstart=min0(i+1,j)
2930           kend=max0(i-1,j-1)
2931 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2932 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2933           do k=kstart,kend
2934             do l=1,3
2935               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2936             enddo
2937           enddo
2938           endif
2939         enddo
2940         enddo ! iint
2941  1225   continue
2942       enddo ! i
2943       do i=1,nct
2944         do j=1,3
2945           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2946           gradx_scp(j,i)=expon*gradx_scp(j,i)
2947         enddo
2948       enddo
2949 C******************************************************************************
2950 C
2951 C                              N O T E !!!
2952 C
2953 C To save time the factor EXPON has been extracted from ALL components
2954 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2955 C use!
2956 C
2957 C******************************************************************************
2958       return
2959       end
2960 C--------------------------------------------------------------------------
2961       subroutine edis(ehpb)
2962 C
2963 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2964 C
2965       implicit real*8 (a-h,o-z)
2966       include 'DIMENSIONS'
2967       include 'DIMENSIONS.FREE'
2968       include 'COMMON.SBRIDGE'
2969       include 'COMMON.CHAIN'
2970       include 'COMMON.DERIV'
2971       include 'COMMON.VAR'
2972       include 'COMMON.INTERACT'
2973       include 'COMMON.CONTROL'
2974       include 'COMMON.IOUNITS'
2975       dimension ggg(3)
2976       ehpb=0.0D0
2977       do i=1,3
2978        ggg(i)=0.0d0
2979       enddo
2980 C      write (iout,*) ,"link_end",link_end,constr_dist
2981 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2982 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
2983 c     &  " constr_dist",constr_dist
2984       if (link_end.eq.0) return
2985       do i=link_start,link_end
2986 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2987 C CA-CA distance used in regularization of structure.
2988         ii=ihpb(i)
2989         jj=jhpb(i)
2990 C iii and jjj point to the residues for which the distance is assigned.
2991         if (ii.gt.nres) then
2992           iii=ii-nres
2993           jjj=jj-nres
2994         else
2995           iii=ii
2996           jjj=jj
2997         endif
2998 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2999 c     &    dhpb(i),dhpb1(i),forcon(i)
3000 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3001 C    distance and angle dependent SS bond potential.
3002 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3003 C     & iabs(itype(jjj)).eq.1) then
3004 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3005 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3006         if (.not.dyn_ss .and. i.le.nss) then
3007 C 15/02/13 CC dynamic SSbond - additional check
3008           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3009      &        iabs(itype(jjj)).eq.1) then
3010            call ssbond_ene(iii,jjj,eij)
3011            ehpb=ehpb+2*eij
3012          endif
3013 cd          write (iout,*) "eij",eij
3014 cd   &   ' waga=',waga,' fac=',fac
3015 !        else if (ii.gt.nres .and. jj.gt.nres) then
3016         else
3017 C Calculate the distance between the two points and its difference from the
3018 C target distance.
3019           dd=dist(ii,jj)
3020           if (irestr_type(i).eq.11) then
3021             ehpb=ehpb+fordepth(i)!**4.0d0
3022      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3023             fac=fordepth(i)!**4.0d0
3024      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3025 c            if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
3026 c     &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3027 c     &        ehpb,irestr_type(i)
3028           else if (irestr_type(i).eq.10) then
3029 c AL 6//19/2018 cross-link restraints
3030             xdis = 0.5d0*(dd/forcon(i))**2
3031             expdis = dexp(-xdis)
3032 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
3033             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
3034 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
3035 c     &          " wboltzd",wboltzd
3036             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
3037 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
3038             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
3039      &           *expdis/(aux*forcon(i)**2)
3040 c            if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
3041 c     &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3042 c     &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
3043           else if (irestr_type(i).eq.2) then
3044 c Quartic restraints
3045             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3046 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3047 c     &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3048 c     &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
3049             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3050           else
3051 c Quadratic restraints
3052             rdis=dd-dhpb(i)
3053 C Get the force constant corresponding to this distance.
3054             waga=forcon(i)
3055 C Calculate the contribution to energy.
3056             ehpb=ehpb+0.5d0*waga*rdis*rdis
3057 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3058 c     &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3059 c     &       0.5d0*waga*rdis*rdis,irestr_type(i)
3060 C
3061 C Evaluate gradient.
3062 C
3063             fac=waga*rdis/dd
3064           endif
3065 c Calculate Cartesian gradient
3066           do j=1,3
3067             ggg(j)=fac*(c(j,jj)-c(j,ii))
3068           enddo
3069 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3070 C If this is a SC-SC distance, we need to calculate the contributions to the
3071 C Cartesian gradient in the SC vectors (ghpbx).
3072           if (iii.lt.ii) then
3073             do j=1,3
3074               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3075               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3076             enddo
3077           endif
3078           do k=1,3
3079             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3080             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3081           enddo
3082         endif
3083       enddo
3084       return
3085       end
3086 C--------------------------------------------------------------------------
3087       subroutine ssbond_ene(i,j,eij)
3088 C
3089 C Calculate the distance and angle dependent SS-bond potential energy
3090 C using a free-energy function derived based on RHF/6-31G** ab initio
3091 C calculations of diethyl disulfide.
3092 C
3093 C A. Liwo and U. Kozlowska, 11/24/03
3094 C
3095       implicit real*8 (a-h,o-z)
3096       include 'DIMENSIONS'
3097       include 'DIMENSIONS.ZSCOPT'
3098       include 'COMMON.SBRIDGE'
3099       include 'COMMON.CHAIN'
3100       include 'COMMON.DERIV'
3101       include 'COMMON.LOCAL'
3102       include 'COMMON.INTERACT'
3103       include 'COMMON.VAR'
3104       include 'COMMON.IOUNITS'
3105       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3106       itypi=itype(i)
3107       xi=c(1,nres+i)
3108       yi=c(2,nres+i)
3109       zi=c(3,nres+i)
3110       dxi=dc_norm(1,nres+i)
3111       dyi=dc_norm(2,nres+i)
3112       dzi=dc_norm(3,nres+i)
3113       dsci_inv=dsc_inv(itypi)
3114       itypj=itype(j)
3115       dscj_inv=dsc_inv(itypj)
3116       xj=c(1,nres+j)-xi
3117       yj=c(2,nres+j)-yi
3118       zj=c(3,nres+j)-zi
3119       dxj=dc_norm(1,nres+j)
3120       dyj=dc_norm(2,nres+j)
3121       dzj=dc_norm(3,nres+j)
3122       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3123       rij=dsqrt(rrij)
3124       erij(1)=xj*rij
3125       erij(2)=yj*rij
3126       erij(3)=zj*rij
3127       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3128       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3129       om12=dxi*dxj+dyi*dyj+dzi*dzj
3130       do k=1,3
3131         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3132         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3133       enddo
3134       rij=1.0d0/rij
3135       deltad=rij-d0cm
3136       deltat1=1.0d0-om1
3137       deltat2=1.0d0+om2
3138       deltat12=om2-om1+2.0d0
3139       cosphi=om12-om1*om2
3140       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3141      &  +akct*deltad*deltat12+ebr
3142 c     &  +akct*deltad*deltat12
3143      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3144       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3145      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3146      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3147       ed=2*akcm*deltad+akct*deltat12
3148       pom1=akct*deltad
3149       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3150       eom1=-2*akth*deltat1-pom1-om2*pom2
3151       eom2= 2*akth*deltat2+pom1-om1*pom2
3152       eom12=pom2
3153       do k=1,3
3154         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3155       enddo
3156       do k=1,3
3157         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3158      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3159         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3160      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3161       enddo
3162 C
3163 C Calculate the components of the gradient in DC and X
3164 C
3165       do k=i,j-1
3166         do l=1,3
3167           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3168         enddo
3169       enddo
3170       return
3171       end
3172 C--------------------------------------------------------------------------
3173 c MODELLER restraint function
3174       subroutine e_modeller(ehomology_constr)
3175       implicit real*8 (a-h,o-z)
3176       include 'DIMENSIONS'
3177       include 'DIMENSIONS.ZSCOPT'
3178       include 'DIMENSIONS.FREE'
3179       integer nnn, i, j, k, ki, irec, l
3180       integer katy, odleglosci, test7
3181       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3182       real*8 distance(max_template),distancek(max_template),
3183      &    min_odl,godl(max_template),dih_diff(max_template)
3184
3185 c
3186 c     FP - 30/10/2014 Temporary specifications for homology restraints
3187 c
3188       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3189      &                 sgtheta
3190       double precision, dimension (maxres) :: guscdiff,usc_diff
3191       double precision, dimension (max_template) ::
3192      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3193      &           theta_diff
3194
3195       include 'COMMON.SBRIDGE'
3196       include 'COMMON.CHAIN'
3197       include 'COMMON.GEO'
3198       include 'COMMON.DERIV'
3199       include 'COMMON.LOCAL'
3200       include 'COMMON.INTERACT'
3201       include 'COMMON.VAR'
3202       include 'COMMON.IOUNITS'
3203       include 'COMMON.CONTROL'
3204       include 'COMMON.HOMRESTR'
3205 c
3206       include 'COMMON.SETUP'
3207       include 'COMMON.NAMES'
3208
3209       do i=1,max_template
3210         distancek(i)=9999999.9
3211       enddo
3212
3213       odleg=0.0d0
3214
3215 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3216 c function)
3217 C AL 5/2/14 - Introduce list of restraints
3218 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3219 #ifdef DEBUG
3220       write(iout,*) "------- dist restrs start -------"
3221 #endif
3222       do ii = link_start_homo,link_end_homo
3223          i = ires_homo(ii)
3224          j = jres_homo(ii)
3225          dij=dist(i,j)
3226 c        write (iout,*) "dij(",i,j,") =",dij
3227          nexl=0
3228          do k=1,constr_homology
3229            if(.not.l_homo(k,ii)) then
3230               nexl=nexl+1
3231               cycle
3232            endif
3233            distance(k)=odl(k,ii)-dij
3234 c          write (iout,*) "distance(",k,") =",distance(k)
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3239 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3240 c          write (iout,*) "distancek(",k,") =",distancek(k)
3241 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3242 c
3243 c          For Lorentzian-type Urestr
3244 c
3245            if (waga_dist.lt.0.0d0) then
3246               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3247               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3248      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3249            endif
3250          enddo
3251
3252 c         min_odl=minval(distancek)
3253          do kk=1,constr_homology
3254           if(l_homo(kk,ii)) then
3255             min_odl=distancek(kk)
3256             exit
3257           endif
3258          enddo
3259          do kk=1,constr_homology
3260           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3261      &              min_odl=distancek(kk)
3262          enddo
3263 c        write (iout,* )"min_odl",min_odl
3264 #ifdef DEBUG
3265          write (iout,*) "ij dij",i,j,dij
3266          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3267          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3268          write (iout,* )"min_odl",min_odl
3269 #endif
3270 #ifdef OLDRESTR
3271          odleg2=0.0d0
3272 #else
3273          if (waga_dist.ge.0.0d0) then
3274            odleg2=nexl
3275          else
3276            odleg2=0.0d0
3277          endif
3278 #endif
3279          do k=1,constr_homology
3280 c Nie wiem po co to liczycie jeszcze raz!
3281 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3282 c     &              (2*(sigma_odl(i,j,k))**2))
3283            if(.not.l_homo(k,ii)) cycle
3284            if (waga_dist.ge.0.0d0) then
3285 c
3286 c          For Gaussian-type Urestr
3287 c
3288             godl(k)=dexp(-distancek(k)+min_odl)
3289             odleg2=odleg2+godl(k)
3290 c
3291 c          For Lorentzian-type Urestr
3292 c
3293            else
3294             odleg2=odleg2+distancek(k)
3295            endif
3296
3297 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3298 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3299 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3300 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3301
3302          enddo
3303 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3304 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3305 #ifdef DEBUG
3306          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3307          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3308 #endif
3309            if (waga_dist.ge.0.0d0) then
3310 c
3311 c          For Gaussian-type Urestr
3312 c
3313               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3314 c
3315 c          For Lorentzian-type Urestr
3316 c
3317            else
3318               odleg=odleg+odleg2/constr_homology
3319            endif
3320 c
3321 #ifdef GRAD
3322 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3323 c Gradient
3324 c
3325 c          For Gaussian-type Urestr
3326 c
3327          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3328          sum_sgodl=0.0d0
3329          do k=1,constr_homology
3330 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3331 c     &           *waga_dist)+min_odl
3332 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3333 c
3334          if(.not.l_homo(k,ii)) cycle
3335          if (waga_dist.ge.0.0d0) then
3336 c          For Gaussian-type Urestr
3337 c
3338            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3339 c
3340 c          For Lorentzian-type Urestr
3341 c
3342          else
3343            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3344      &           sigma_odlir(k,ii)**2)**2)
3345          endif
3346            sum_sgodl=sum_sgodl+sgodl
3347
3348 c            sgodl2=sgodl2+sgodl
3349 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3350 c      write(iout,*) "constr_homology=",constr_homology
3351 c      write(iout,*) i, j, k, "TEST K"
3352          enddo
3353          if (waga_dist.ge.0.0d0) then
3354 c
3355 c          For Gaussian-type Urestr
3356 c
3357             grad_odl3=waga_homology(iset)*waga_dist
3358      &                *sum_sgodl/(sum_godl*dij)
3359 c
3360 c          For Lorentzian-type Urestr
3361 c
3362          else
3363 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3364 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3365             grad_odl3=-waga_homology(iset)*waga_dist*
3366      &                sum_sgodl/(constr_homology*dij)
3367          endif
3368 c
3369 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3370
3371
3372 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3373 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3374 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3375
3376 ccc      write(iout,*) godl, sgodl, grad_odl3
3377
3378 c          grad_odl=grad_odl+grad_odl3
3379
3380          do jik=1,3
3381             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3382 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3383 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3384 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3385             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3386             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3387 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3388 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3389 c         if (i.eq.25.and.j.eq.27) then
3390 c         write(iout,*) "jik",jik,"i",i,"j",j
3391 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3392 c         write(iout,*) "grad_odl3",grad_odl3
3393 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3394 c         write(iout,*) "ggodl",ggodl
3395 c         write(iout,*) "ghpbc(",jik,i,")",
3396 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3397 c     &                 ghpbc(jik,j)
3398 c         endif
3399          enddo
3400 #endif
3401 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3402 ccc     & dLOG(odleg2),"-odleg=", -odleg
3403
3404       enddo ! ii-loop for dist
3405 #ifdef DEBUG
3406       write(iout,*) "------- dist restrs end -------"
3407 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3408 c    &     waga_d.eq.1.0d0) call sum_gradient
3409 #endif
3410 c Pseudo-energy and gradient from dihedral-angle restraints from
3411 c homology templates
3412 c      write (iout,*) "End of distance loop"
3413 c      call flush(iout)
3414       kat=0.0d0
3415 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3416 #ifdef DEBUG
3417       write(iout,*) "------- dih restrs start -------"
3418       do i=idihconstr_start_homo,idihconstr_end_homo
3419         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3420       enddo
3421 #endif
3422       do i=idihconstr_start_homo,idihconstr_end_homo
3423         kat2=0.0d0
3424 c        betai=beta(i,i+1,i+2,i+3)
3425         betai = phi(i)
3426 c       write (iout,*) "betai =",betai
3427         do k=1,constr_homology
3428           dih_diff(k)=pinorm(dih(k,i)-betai)
3429 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3430 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3431 c     &                                   -(6.28318-dih_diff(i,k))
3432 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3433 c     &                                   6.28318+dih_diff(i,k)
3434 #ifdef OLD_DIHED
3435           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3436 #else
3437           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3438 #endif
3439 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3440           gdih(k)=dexp(kat3)
3441           kat2=kat2+gdih(k)
3442 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3443 c          write(*,*)""
3444         enddo
3445 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3446 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3447 #ifdef DEBUG
3448         write (iout,*) "i",i," betai",betai," kat2",kat2
3449         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3450 #endif
3451         if (kat2.le.1.0d-14) cycle
3452         kat=kat-dLOG(kat2/constr_homology)
3453 c       write (iout,*) "kat",kat ! sum of -ln-s
3454
3455 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3456 ccc     & dLOG(kat2), "-kat=", -kat
3457
3458 #ifdef GRAD
3459 c ----------------------------------------------------------------------
3460 c Gradient
3461 c ----------------------------------------------------------------------
3462
3463         sum_gdih=kat2
3464         sum_sgdih=0.0d0
3465         do k=1,constr_homology
3466 #ifdef OLD_DIHED
3467           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3468 #else
3469           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3470 #endif
3471 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3472           sum_sgdih=sum_sgdih+sgdih
3473         enddo
3474 c       grad_dih3=sum_sgdih/sum_gdih
3475         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3476
3477 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3478 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3479 ccc     & gloc(nphi+i-3,icg)
3480         gloc(i,icg)=gloc(i,icg)+grad_dih3
3481 c        if (i.eq.25) then
3482 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3483 c        endif
3484 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3485 ccc     & gloc(nphi+i-3,icg)
3486 #endif
3487       enddo ! i-loop for dih
3488 #ifdef DEBUG
3489       write(iout,*) "------- dih restrs end -------"
3490 #endif
3491
3492 c Pseudo-energy and gradient for theta angle restraints from
3493 c homology templates
3494 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3495 c adapted
3496
3497 c
3498 c     For constr_homology reference structures (FP)
3499 c
3500 c     Uconst_back_tot=0.0d0
3501       Eval=0.0d0
3502       Erot=0.0d0
3503 c     Econstr_back legacy
3504 #ifdef GRAD
3505       do i=1,nres
3506 c     do i=ithet_start,ithet_end
3507        dutheta(i)=0.0d0
3508 c     enddo
3509 c     do i=loc_start,loc_end
3510         do j=1,3
3511           duscdiff(j,i)=0.0d0
3512           duscdiffx(j,i)=0.0d0
3513         enddo
3514       enddo
3515 #endif
3516 c
3517 c     do iref=1,nref
3518 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3519 c     write (iout,*) "waga_theta",waga_theta
3520       if (waga_theta.gt.0.0d0) then
3521 #ifdef DEBUG
3522       write (iout,*) "usampl",usampl
3523       write(iout,*) "------- theta restrs start -------"
3524 c     do i=ithet_start,ithet_end
3525 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3526 c     enddo
3527 #endif
3528 c     write (iout,*) "maxres",maxres,"nres",nres
3529
3530       do i=ithet_start,ithet_end
3531 c
3532 c     do i=1,nfrag_back
3533 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3534 c
3535 c Deviation of theta angles wrt constr_homology ref structures
3536 c
3537         utheta_i=0.0d0 ! argument of Gaussian for single k
3538         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3539 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3540 c       over residues in a fragment
3541 c       write (iout,*) "theta(",i,")=",theta(i)
3542         do k=1,constr_homology
3543 c
3544 c         dtheta_i=theta(j)-thetaref(j,iref)
3545 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3546           theta_diff(k)=thetatpl(k,i)-theta(i)
3547 c
3548           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3549 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3550           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3551           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3552 c         Gradient for single Gaussian restraint in subr Econstr_back
3553 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3554 c
3555         enddo
3556 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3557 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3558
3559 c
3560 #ifdef GRAD
3561 c         Gradient for multiple Gaussian restraint
3562         sum_gtheta=gutheta_i
3563         sum_sgtheta=0.0d0
3564         do k=1,constr_homology
3565 c        New generalized expr for multiple Gaussian from Econstr_back
3566          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3567 c
3568 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3569           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3570         enddo
3571 c
3572 c       Final value of gradient using same var as in Econstr_back
3573         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3574      &               *waga_homology(iset)
3575 c       dutheta(i)=sum_sgtheta/sum_gtheta
3576 c
3577 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3578 #endif
3579         Eval=Eval-dLOG(gutheta_i/constr_homology)
3580 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3581 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3582 c       Uconst_back=Uconst_back+utheta(i)
3583       enddo ! (i-loop for theta)
3584 #ifdef DEBUG
3585       write(iout,*) "------- theta restrs end -------"
3586 #endif
3587       endif
3588 c
3589 c Deviation of local SC geometry
3590 c
3591 c Separation of two i-loops (instructed by AL - 11/3/2014)
3592 c
3593 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3594 c     write (iout,*) "waga_d",waga_d
3595
3596 #ifdef DEBUG
3597       write(iout,*) "------- SC restrs start -------"
3598       write (iout,*) "Initial duscdiff,duscdiffx"
3599       do i=loc_start,loc_end
3600         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3601      &                 (duscdiffx(jik,i),jik=1,3)
3602       enddo
3603 #endif
3604       do i=loc_start,loc_end
3605         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3606         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3607 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3608 c       write(iout,*) "xxtab, yytab, zztab"
3609 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3610         do k=1,constr_homology
3611 c
3612           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3613 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3614           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3615           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3616 c         write(iout,*) "dxx, dyy, dzz"
3617 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3618 c
3619           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3620 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3621 c         uscdiffk(k)=usc_diff(i)
3622           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3623           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3624 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3625 c     &      xxref(j),yyref(j),zzref(j)
3626         enddo
3627 c
3628 c       Gradient
3629 c
3630 c       Generalized expression for multiple Gaussian acc to that for a single
3631 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3632 c
3633 c       Original implementation
3634 c       sum_guscdiff=guscdiff(i)
3635 c
3636 c       sum_sguscdiff=0.0d0
3637 c       do k=1,constr_homology
3638 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3639 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3640 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3641 c       enddo
3642 c
3643 c       Implementation of new expressions for gradient (Jan. 2015)
3644 c
3645 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3646 #ifdef GRAD
3647         do k=1,constr_homology
3648 c
3649 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3650 c       before. Now the drivatives should be correct
3651 c
3652           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3653 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3654           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3655           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3656 c
3657 c         New implementation
3658 c
3659           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3660      &                 sigma_d(k,i) ! for the grad wrt r'
3661 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3662 c
3663 c
3664 c        New implementation
3665          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3666          do jik=1,3
3667             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3668      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3669      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3670             duscdiff(jik,i)=duscdiff(jik,i)+
3671      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3672      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3673             duscdiffx(jik,i)=duscdiffx(jik,i)+
3674      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3675      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3676 c
3677 #ifdef DEBUG
3678              write(iout,*) "jik",jik,"i",i
3679              write(iout,*) "dxx, dyy, dzz"
3680              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3681              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3682 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3683 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3684 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3685 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3686 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3687 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3688 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3689 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3690 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3691 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3692 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3693 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3694 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3695 c            endif
3696 #endif
3697          enddo
3698         enddo
3699 #endif
3700 c
3701 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3702 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3703 c
3704 c        write (iout,*) i," uscdiff",uscdiff(i)
3705 c
3706 c Put together deviations from local geometry
3707
3708 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3709 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3710         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3711 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3712 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3713 c       Uconst_back=Uconst_back+usc_diff(i)
3714 c
3715 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3716 c
3717 c     New implment: multiplied by sum_sguscdiff
3718 c
3719
3720       enddo ! (i-loop for dscdiff)
3721
3722 c      endif
3723
3724 #ifdef DEBUG
3725       write(iout,*) "------- SC restrs end -------"
3726         write (iout,*) "------ After SC loop in e_modeller ------"
3727         do i=loc_start,loc_end
3728          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3729          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3730         enddo
3731       if (waga_theta.eq.1.0d0) then
3732       write (iout,*) "in e_modeller after SC restr end: dutheta"
3733       do i=ithet_start,ithet_end
3734         write (iout,*) i,dutheta(i)
3735       enddo
3736       endif
3737       if (waga_d.eq.1.0d0) then
3738       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3739       do i=1,nres
3740         write (iout,*) i,(duscdiff(j,i),j=1,3)
3741         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3742       enddo
3743       endif
3744 #endif
3745
3746 c Total energy from homology restraints
3747 #ifdef DEBUG
3748       write (iout,*) "odleg",odleg," kat",kat
3749       write (iout,*) "odleg",odleg," kat",kat
3750       write (iout,*) "Eval",Eval," Erot",Erot
3751       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3752       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3753       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3754 #endif
3755 c
3756 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3757 c
3758 c     ehomology_constr=odleg+kat
3759 c
3760 c     For Lorentzian-type Urestr
3761 c
3762
3763       if (waga_dist.ge.0.0d0) then
3764 c
3765 c          For Gaussian-type Urestr
3766 c
3767 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3768 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3769         ehomology_constr=waga_dist*odleg+waga_angle*kat+
3770      &              waga_theta*Eval+waga_d*Erot
3771 c     write (iout,*) "ehomology_constr=",ehomology_constr
3772       else
3773 c
3774 c          For Lorentzian-type Urestr
3775 c
3776 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3777 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3778         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
3779      &              waga_theta*Eval+waga_d*Erot
3780 c     write (iout,*) "ehomology_constr=",ehomology_constr
3781       endif
3782 #ifdef DEBUG
3783       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3784      & "Eval",waga_theta,eval,
3785      &   "Erot",waga_d,Erot
3786       write (iout,*) "ehomology_constr",ehomology_constr
3787 #endif
3788       return
3789
3790   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3791   747 format(a12,i4,i4,i4,f8.3,f8.3)
3792   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3793   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3794   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3795      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3796       end
3797 c-----------------------------------------------------------------------
3798       subroutine ebond(estr)
3799 c
3800 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3801 c
3802       implicit real*8 (a-h,o-z)
3803       include 'DIMENSIONS'
3804       include 'DIMENSIONS.ZSCOPT'
3805       include 'DIMENSIONS.FREE'
3806       include 'COMMON.LOCAL'
3807       include 'COMMON.GEO'
3808       include 'COMMON.INTERACT'
3809       include 'COMMON.DERIV'
3810       include 'COMMON.VAR'
3811       include 'COMMON.CHAIN'
3812       include 'COMMON.IOUNITS'
3813       include 'COMMON.NAMES'
3814       include 'COMMON.FFIELD'
3815       include 'COMMON.CONTROL'
3816       double precision u(3),ud(3)
3817       logical :: lprn=.false.
3818       estr=0.0d0
3819       do i=nnt+1,nct
3820         diff = vbld(i)-vbldp0
3821 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3822         estr=estr+diff*diff
3823         do j=1,3
3824           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3825         enddo
3826       enddo
3827       estr=0.5d0*AKP*estr
3828 c
3829 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3830 c
3831       do i=nnt,nct
3832         iti=itype(i)
3833         if (iti.ne.10) then
3834           nbi=nbondterm(iti)
3835           if (nbi.eq.1) then
3836             diff=vbld(i+nres)-vbldsc0(1,iti)
3837             if (lprn)
3838      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3839      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3840             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3841             do j=1,3
3842               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3843             enddo
3844           else
3845             do j=1,nbi
3846               diff=vbld(i+nres)-vbldsc0(j,iti)
3847               ud(j)=aksc(j,iti)*diff
3848               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3849             enddo
3850             uprod=u(1)
3851             do j=2,nbi
3852               uprod=uprod*u(j)
3853             enddo
3854             usum=0.0d0
3855             usumsqder=0.0d0
3856             do j=1,nbi
3857               uprod1=1.0d0
3858               uprod2=1.0d0
3859               do k=1,nbi
3860                 if (k.ne.j) then
3861                   uprod1=uprod1*u(k)
3862                   uprod2=uprod2*u(k)*u(k)
3863                 endif
3864               enddo
3865               usum=usum+uprod1
3866               usumsqder=usumsqder+ud(j)*uprod2
3867             enddo
3868             if (lprn)
3869      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3870      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3871             estr=estr+uprod/usum
3872             do j=1,3
3873              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3874             enddo
3875           endif
3876         endif
3877       enddo
3878       return
3879       end
3880 #ifdef CRYST_THETA
3881 C--------------------------------------------------------------------------
3882       subroutine ebend(etheta)
3883 C
3884 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3885 C angles gamma and its derivatives in consecutive thetas and gammas.
3886 C
3887       implicit real*8 (a-h,o-z)
3888       include 'DIMENSIONS'
3889       include 'DIMENSIONS.ZSCOPT'
3890       include 'COMMON.LOCAL'
3891       include 'COMMON.GEO'
3892       include 'COMMON.INTERACT'
3893       include 'COMMON.DERIV'
3894       include 'COMMON.VAR'
3895       include 'COMMON.CHAIN'
3896       include 'COMMON.IOUNITS'
3897       include 'COMMON.NAMES'
3898       include 'COMMON.FFIELD'
3899       common /calcthet/ term1,term2,termm,diffak,ratak,
3900      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3901      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3902       double precision y(2),z(2)
3903       delta=0.02d0*pi
3904       time11=dexp(-2*time)
3905       time12=1.0d0
3906       etheta=0.0D0
3907 c      write (iout,*) "nres",nres
3908 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3909 c      write (iout,*) ithet_start,ithet_end
3910       do i=ithet_start,ithet_end
3911 C Zero the energy function and its derivative at 0 or pi.
3912         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3913         it=itype(i-1)
3914 c        if (i.gt.ithet_start .and.
3915 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3916 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3917 c          phii=phi(i)
3918 c          y(1)=dcos(phii)
3919 c          y(2)=dsin(phii)
3920 c        else
3921 c          y(1)=0.0D0
3922 c          y(2)=0.0D0
3923 c        endif
3924 c        if (i.lt.nres .and. itel(i).ne.0) then
3925 c          phii1=phi(i+1)
3926 c          z(1)=dcos(phii1)
3927 c          z(2)=dsin(phii1)
3928 c        else
3929 c          z(1)=0.0D0
3930 c          z(2)=0.0D0
3931 c        endif
3932         if (i.gt.3) then
3933 #ifdef OSF
3934           phii=phi(i)
3935           icrc=0
3936           call proc_proc(phii,icrc)
3937           if (icrc.eq.1) phii=150.0
3938 #else
3939           phii=phi(i)
3940 #endif
3941           y(1)=dcos(phii)
3942           y(2)=dsin(phii)
3943         else
3944           y(1)=0.0D0
3945           y(2)=0.0D0
3946         endif
3947         if (i.lt.nres) then
3948 #ifdef OSF
3949           phii1=phi(i+1)
3950           icrc=0
3951           call proc_proc(phii1,icrc)
3952           if (icrc.eq.1) phii1=150.0
3953           phii1=pinorm(phii1)
3954           z(1)=cos(phii1)
3955 #else
3956           phii1=phi(i+1)
3957           z(1)=dcos(phii1)
3958 #endif
3959           z(2)=dsin(phii1)
3960         else
3961           z(1)=0.0D0
3962           z(2)=0.0D0
3963         endif
3964 C Calculate the "mean" value of theta from the part of the distribution
3965 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3966 C In following comments this theta will be referred to as t_c.
3967         thet_pred_mean=0.0d0
3968         do k=1,2
3969           athetk=athet(k,it)
3970           bthetk=bthet(k,it)
3971           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3972         enddo
3973 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3974         dthett=thet_pred_mean*ssd
3975         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3976 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3977 C Derivatives of the "mean" values in gamma1 and gamma2.
3978         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3979         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3980         if (theta(i).gt.pi-delta) then
3981           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3982      &         E_tc0)
3983           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3984           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3985           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3986      &        E_theta)
3987           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3988      &        E_tc)
3989         else if (theta(i).lt.delta) then
3990           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3991           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3992           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3993      &        E_theta)
3994           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3995           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3996      &        E_tc)
3997         else
3998           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3999      &        E_theta,E_tc)
4000         endif
4001         etheta=etheta+ethetai
4002 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4003 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4004         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4005         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4006         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4007  1215   continue
4008       enddo
4009 C Ufff.... We've done all this!!!
4010       return
4011       end
4012 C---------------------------------------------------------------------------
4013       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4014      &     E_tc)
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 C Calculate the contributions to both Gaussian lobes.
4023 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4024 C The "polynomial part" of the "standard deviation" of this part of
4025 C the distribution.
4026         sig=polthet(3,it)
4027         do j=2,0,-1
4028           sig=sig*thet_pred_mean+polthet(j,it)
4029         enddo
4030 C Derivative of the "interior part" of the "standard deviation of the"
4031 C gamma-dependent Gaussian lobe in t_c.
4032         sigtc=3*polthet(3,it)
4033         do j=2,1,-1
4034           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4035         enddo
4036         sigtc=sig*sigtc
4037 C Set the parameters of both Gaussian lobes of the distribution.
4038 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4039         fac=sig*sig+sigc0(it)
4040         sigcsq=fac+fac
4041         sigc=1.0D0/sigcsq
4042 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4043         sigsqtc=-4.0D0*sigcsq*sigtc
4044 c       print *,i,sig,sigtc,sigsqtc
4045 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4046         sigtc=-sigtc/(fac*fac)
4047 C Following variable is sigma(t_c)**(-2)
4048         sigcsq=sigcsq*sigcsq
4049         sig0i=sig0(it)
4050         sig0inv=1.0D0/sig0i**2
4051         delthec=thetai-thet_pred_mean
4052         delthe0=thetai-theta0i
4053         term1=-0.5D0*sigcsq*delthec*delthec
4054         term2=-0.5D0*sig0inv*delthe0*delthe0
4055 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4056 C NaNs in taking the logarithm. We extract the largest exponent which is added
4057 C to the energy (this being the log of the distribution) at the end of energy
4058 C term evaluation for this virtual-bond angle.
4059         if (term1.gt.term2) then
4060           termm=term1
4061           term2=dexp(term2-termm)
4062           term1=1.0d0
4063         else
4064           termm=term2
4065           term1=dexp(term1-termm)
4066           term2=1.0d0
4067         endif
4068 C The ratio between the gamma-independent and gamma-dependent lobes of
4069 C the distribution is a Gaussian function of thet_pred_mean too.
4070         diffak=gthet(2,it)-thet_pred_mean
4071         ratak=diffak/gthet(3,it)**2
4072         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4073 C Let's differentiate it in thet_pred_mean NOW.
4074         aktc=ak*ratak
4075 C Now put together the distribution terms to make complete distribution.
4076         termexp=term1+ak*term2
4077         termpre=sigc+ak*sig0i
4078 C Contribution of the bending energy from this theta is just the -log of
4079 C the sum of the contributions from the two lobes and the pre-exponential
4080 C factor. Simple enough, isn't it?
4081         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4082 C NOW the derivatives!!!
4083 C 6/6/97 Take into account the deformation.
4084         E_theta=(delthec*sigcsq*term1
4085      &       +ak*delthe0*sig0inv*term2)/termexp
4086         E_tc=((sigtc+aktc*sig0i)/termpre
4087      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4088      &       aktc*term2)/termexp)
4089       return
4090       end
4091 c-----------------------------------------------------------------------------
4092       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4093       implicit real*8 (a-h,o-z)
4094       include 'DIMENSIONS'
4095       include 'COMMON.LOCAL'
4096       include 'COMMON.IOUNITS'
4097       common /calcthet/ term1,term2,termm,diffak,ratak,
4098      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4099      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4100       delthec=thetai-thet_pred_mean
4101       delthe0=thetai-theta0i
4102 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4103       t3 = thetai-thet_pred_mean
4104       t6 = t3**2
4105       t9 = term1
4106       t12 = t3*sigcsq
4107       t14 = t12+t6*sigsqtc
4108       t16 = 1.0d0
4109       t21 = thetai-theta0i
4110       t23 = t21**2
4111       t26 = term2
4112       t27 = t21*t26
4113       t32 = termexp
4114       t40 = t32**2
4115       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4116      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4117      & *(-t12*t9-ak*sig0inv*t27)
4118       return
4119       end
4120 #else
4121 C--------------------------------------------------------------------------
4122       subroutine ebend(etheta)
4123 C
4124 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4125 C angles gamma and its derivatives in consecutive thetas and gammas.
4126 C ab initio-derived potentials from
4127 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4128 C
4129       implicit real*8 (a-h,o-z)
4130       include 'DIMENSIONS'
4131       include 'DIMENSIONS.ZSCOPT'
4132       include 'DIMENSIONS.FREE'
4133       include 'COMMON.LOCAL'
4134       include 'COMMON.GEO'
4135       include 'COMMON.INTERACT'
4136       include 'COMMON.DERIV'
4137       include 'COMMON.VAR'
4138       include 'COMMON.CHAIN'
4139       include 'COMMON.IOUNITS'
4140       include 'COMMON.NAMES'
4141       include 'COMMON.FFIELD'
4142       include 'COMMON.CONTROL'
4143       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4144      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4145      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4146      & sinph1ph2(maxdouble,maxdouble)
4147       logical lprn /.false./, lprn1 /.false./
4148       etheta=0.0D0
4149 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4150       do i=ithet_start,ithet_end
4151         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4152      &    (itype(i).eq.ntyp1)) cycle
4153         dethetai=0.0d0
4154         dephii=0.0d0
4155         dephii1=0.0d0
4156         theti2=0.5d0*theta(i)
4157         ityp2=ithetyp(itype(i-1))
4158         do k=1,nntheterm
4159           coskt(k)=dcos(k*theti2)
4160           sinkt(k)=dsin(k*theti2)
4161         enddo
4162         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4163 #ifdef OSF
4164           phii=phi(i)
4165           if (phii.ne.phii) phii=150.0
4166 #else
4167           phii=phi(i)
4168 #endif
4169           ityp1=ithetyp(itype(i-2))
4170           do k=1,nsingle
4171             cosph1(k)=dcos(k*phii)
4172             sinph1(k)=dsin(k*phii)
4173           enddo
4174         else
4175           phii=0.0d0
4176           ityp1=ithetyp(itype(i-2))
4177           do k=1,nsingle
4178             cosph1(k)=0.0d0
4179             sinph1(k)=0.0d0
4180           enddo
4181         endif
4182         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4183 #ifdef OSF
4184           phii1=phi(i+1)
4185           if (phii1.ne.phii1) phii1=150.0
4186           phii1=pinorm(phii1)
4187 #else
4188           phii1=phi(i+1)
4189 #endif
4190           ityp3=ithetyp(itype(i))
4191           do k=1,nsingle
4192             cosph2(k)=dcos(k*phii1)
4193             sinph2(k)=dsin(k*phii1)
4194           enddo
4195         else
4196           phii1=0.0d0
4197 c          ityp3=nthetyp+1
4198           ityp3=ithetyp(itype(i))
4199           do k=1,nsingle
4200             cosph2(k)=0.0d0
4201             sinph2(k)=0.0d0
4202           enddo
4203         endif
4204 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4205 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4206 c        call flush(iout)
4207         ethetai=aa0thet(ityp1,ityp2,ityp3)
4208         do k=1,ndouble
4209           do l=1,k-1
4210             ccl=cosph1(l)*cosph2(k-l)
4211             ssl=sinph1(l)*sinph2(k-l)
4212             scl=sinph1(l)*cosph2(k-l)
4213             csl=cosph1(l)*sinph2(k-l)
4214             cosph1ph2(l,k)=ccl-ssl
4215             cosph1ph2(k,l)=ccl+ssl
4216             sinph1ph2(l,k)=scl+csl
4217             sinph1ph2(k,l)=scl-csl
4218           enddo
4219         enddo
4220         if (lprn) then
4221         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4222      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4223         write (iout,*) "coskt and sinkt"
4224         do k=1,nntheterm
4225           write (iout,*) k,coskt(k),sinkt(k)
4226         enddo
4227         endif
4228         do k=1,ntheterm
4229           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4230           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4231      &      *coskt(k)
4232           if (lprn)
4233      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4234      &     " ethetai",ethetai
4235         enddo
4236         if (lprn) then
4237         write (iout,*) "cosph and sinph"
4238         do k=1,nsingle
4239           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4240         enddo
4241         write (iout,*) "cosph1ph2 and sinph2ph2"
4242         do k=2,ndouble
4243           do l=1,k-1
4244             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4245      &         sinph1ph2(l,k),sinph1ph2(k,l)
4246           enddo
4247         enddo
4248         write(iout,*) "ethetai",ethetai
4249         endif
4250         do m=1,ntheterm2
4251           do k=1,nsingle
4252             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4253      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4254      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4255      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4256             ethetai=ethetai+sinkt(m)*aux
4257             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4258             dephii=dephii+k*sinkt(m)*(
4259      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4260      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4261             dephii1=dephii1+k*sinkt(m)*(
4262      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4263      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4264             if (lprn)
4265      &      write (iout,*) "m",m," k",k," bbthet",
4266      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4267      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4268      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4269      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4270           enddo
4271         enddo
4272         if (lprn)
4273      &  write(iout,*) "ethetai",ethetai
4274         do m=1,ntheterm3
4275           do k=2,ndouble
4276             do l=1,k-1
4277               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4278      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4279      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4280      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4281               ethetai=ethetai+sinkt(m)*aux
4282               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4283               dephii=dephii+l*sinkt(m)*(
4284      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4285      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4286      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4287      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4288               dephii1=dephii1+(k-l)*sinkt(m)*(
4289      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4290      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4291      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4292      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4293               if (lprn) then
4294               write (iout,*) "m",m," k",k," l",l," ffthet",
4295      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4296      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4297      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4298      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4299               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4300      &            cosph1ph2(k,l)*sinkt(m),
4301      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4302               endif
4303             enddo
4304           enddo
4305         enddo
4306 10      continue
4307 c        lprn1=.true.
4308         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4309      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4310      &   phii1*rad2deg,ethetai
4311 c        lprn1=.false.
4312         etheta=etheta+ethetai
4313
4314         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4315         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4316         gloc(nphi+i-2,icg)=wang*dethetai
4317       enddo
4318       return
4319       end
4320 #endif
4321 #ifdef CRYST_SC
4322 c-----------------------------------------------------------------------------
4323       subroutine esc(escloc)
4324 C Calculate the local energy of a side chain and its derivatives in the
4325 C corresponding virtual-bond valence angles THETA and the spherical angles
4326 C ALPHA and OMEGA.
4327       implicit real*8 (a-h,o-z)
4328       include 'DIMENSIONS'
4329       include 'DIMENSIONS.ZSCOPT'
4330       include 'COMMON.GEO'
4331       include 'COMMON.LOCAL'
4332       include 'COMMON.VAR'
4333       include 'COMMON.INTERACT'
4334       include 'COMMON.DERIV'
4335       include 'COMMON.CHAIN'
4336       include 'COMMON.IOUNITS'
4337       include 'COMMON.NAMES'
4338       include 'COMMON.FFIELD'
4339       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4340      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4341       common /sccalc/ time11,time12,time112,theti,it,nlobit
4342       delta=0.02d0*pi
4343       escloc=0.0D0
4344 c     write (iout,'(a)') 'ESC'
4345       do i=loc_start,loc_end
4346         it=itype(i)
4347         if (it.eq.10) goto 1
4348         nlobit=nlob(it)
4349 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4350 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4351         theti=theta(i+1)-pipol
4352         x(1)=dtan(theti)
4353         x(2)=alph(i)
4354         x(3)=omeg(i)
4355 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4356
4357         if (x(2).gt.pi-delta) then
4358           xtemp(1)=x(1)
4359           xtemp(2)=pi-delta
4360           xtemp(3)=x(3)
4361           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4362           xtemp(2)=pi
4363           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4364           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4365      &        escloci,dersc(2))
4366           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4367      &        ddersc0(1),dersc(1))
4368           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4369      &        ddersc0(3),dersc(3))
4370           xtemp(2)=pi-delta
4371           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4372           xtemp(2)=pi
4373           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4374           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4375      &            dersc0(2),esclocbi,dersc02)
4376           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4377      &            dersc12,dersc01)
4378           call splinthet(x(2),0.5d0*delta,ss,ssd)
4379           dersc0(1)=dersc01
4380           dersc0(2)=dersc02
4381           dersc0(3)=0.0d0
4382           do k=1,3
4383             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4384           enddo
4385           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4386 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4387 c    &             esclocbi,ss,ssd
4388           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4389 c         escloci=esclocbi
4390 c         write (iout,*) escloci
4391         else if (x(2).lt.delta) then
4392           xtemp(1)=x(1)
4393           xtemp(2)=delta
4394           xtemp(3)=x(3)
4395           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4396           xtemp(2)=0.0d0
4397           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4398           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4399      &        escloci,dersc(2))
4400           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4401      &        ddersc0(1),dersc(1))
4402           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4403      &        ddersc0(3),dersc(3))
4404           xtemp(2)=delta
4405           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4406           xtemp(2)=0.0d0
4407           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4408           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4409      &            dersc0(2),esclocbi,dersc02)
4410           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4411      &            dersc12,dersc01)
4412           dersc0(1)=dersc01
4413           dersc0(2)=dersc02
4414           dersc0(3)=0.0d0
4415           call splinthet(x(2),0.5d0*delta,ss,ssd)
4416           do k=1,3
4417             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4418           enddo
4419           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4420 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4421 c    &             esclocbi,ss,ssd
4422           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4423 c         write (iout,*) escloci
4424         else
4425           call enesc(x,escloci,dersc,ddummy,.false.)
4426         endif
4427
4428         escloc=escloc+escloci
4429 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4430
4431         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4432      &   wscloc*dersc(1)
4433         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4434         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4435     1   continue
4436       enddo
4437       return
4438       end
4439 C---------------------------------------------------------------------------
4440       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4441       implicit real*8 (a-h,o-z)
4442       include 'DIMENSIONS'
4443       include 'COMMON.GEO'
4444       include 'COMMON.LOCAL'
4445       include 'COMMON.IOUNITS'
4446       common /sccalc/ time11,time12,time112,theti,it,nlobit
4447       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4448       double precision contr(maxlob,-1:1)
4449       logical mixed
4450 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4451         escloc_i=0.0D0
4452         do j=1,3
4453           dersc(j)=0.0D0
4454           if (mixed) ddersc(j)=0.0d0
4455         enddo
4456         x3=x(3)
4457
4458 C Because of periodicity of the dependence of the SC energy in omega we have
4459 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4460 C To avoid underflows, first compute & store the exponents.
4461
4462         do iii=-1,1
4463
4464           x(3)=x3+iii*dwapi
4465
4466           do j=1,nlobit
4467             do k=1,3
4468               z(k)=x(k)-censc(k,j,it)
4469             enddo
4470             do k=1,3
4471               Axk=0.0D0
4472               do l=1,3
4473                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4474               enddo
4475               Ax(k,j,iii)=Axk
4476             enddo
4477             expfac=0.0D0
4478             do k=1,3
4479               expfac=expfac+Ax(k,j,iii)*z(k)
4480             enddo
4481             contr(j,iii)=expfac
4482           enddo ! j
4483
4484         enddo ! iii
4485
4486         x(3)=x3
4487 C As in the case of ebend, we want to avoid underflows in exponentiation and
4488 C subsequent NaNs and INFs in energy calculation.
4489 C Find the largest exponent
4490         emin=contr(1,-1)
4491         do iii=-1,1
4492           do j=1,nlobit
4493             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4494           enddo
4495         enddo
4496         emin=0.5D0*emin
4497 cd      print *,'it=',it,' emin=',emin
4498
4499 C Compute the contribution to SC energy and derivatives
4500         do iii=-1,1
4501
4502           do j=1,nlobit
4503             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4504 cd          print *,'j=',j,' expfac=',expfac
4505             escloc_i=escloc_i+expfac
4506             do k=1,3
4507               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4508             enddo
4509             if (mixed) then
4510               do k=1,3,2
4511                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4512      &            +gaussc(k,2,j,it))*expfac
4513               enddo
4514             endif
4515           enddo
4516
4517         enddo ! iii
4518
4519         dersc(1)=dersc(1)/cos(theti)**2
4520         ddersc(1)=ddersc(1)/cos(theti)**2
4521         ddersc(3)=ddersc(3)
4522
4523         escloci=-(dlog(escloc_i)-emin)
4524         do j=1,3
4525           dersc(j)=dersc(j)/escloc_i
4526         enddo
4527         if (mixed) then
4528           do j=1,3,2
4529             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4530           enddo
4531         endif
4532       return
4533       end
4534 C------------------------------------------------------------------------------
4535       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4536       implicit real*8 (a-h,o-z)
4537       include 'DIMENSIONS'
4538       include 'COMMON.GEO'
4539       include 'COMMON.LOCAL'
4540       include 'COMMON.IOUNITS'
4541       common /sccalc/ time11,time12,time112,theti,it,nlobit
4542       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4543       double precision contr(maxlob)
4544       logical mixed
4545
4546       escloc_i=0.0D0
4547
4548       do j=1,3
4549         dersc(j)=0.0D0
4550       enddo
4551
4552       do j=1,nlobit
4553         do k=1,2
4554           z(k)=x(k)-censc(k,j,it)
4555         enddo
4556         z(3)=dwapi
4557         do k=1,3
4558           Axk=0.0D0
4559           do l=1,3
4560             Axk=Axk+gaussc(l,k,j,it)*z(l)
4561           enddo
4562           Ax(k,j)=Axk
4563         enddo
4564         expfac=0.0D0
4565         do k=1,3
4566           expfac=expfac+Ax(k,j)*z(k)
4567         enddo
4568         contr(j)=expfac
4569       enddo ! j
4570
4571 C As in the case of ebend, we want to avoid underflows in exponentiation and
4572 C subsequent NaNs and INFs in energy calculation.
4573 C Find the largest exponent
4574       emin=contr(1)
4575       do j=1,nlobit
4576         if (emin.gt.contr(j)) emin=contr(j)
4577       enddo
4578       emin=0.5D0*emin
4579
4580 C Compute the contribution to SC energy and derivatives
4581
4582       dersc12=0.0d0
4583       do j=1,nlobit
4584         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4585         escloc_i=escloc_i+expfac
4586         do k=1,2
4587           dersc(k)=dersc(k)+Ax(k,j)*expfac
4588         enddo
4589         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4590      &            +gaussc(1,2,j,it))*expfac
4591         dersc(3)=0.0d0
4592       enddo
4593
4594       dersc(1)=dersc(1)/cos(theti)**2
4595       dersc12=dersc12/cos(theti)**2
4596       escloci=-(dlog(escloc_i)-emin)
4597       do j=1,2
4598         dersc(j)=dersc(j)/escloc_i
4599       enddo
4600       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4601       return
4602       end
4603 #else
4604 c----------------------------------------------------------------------------------
4605       subroutine esc(escloc)
4606 C Calculate the local energy of a side chain and its derivatives in the
4607 C corresponding virtual-bond valence angles THETA and the spherical angles
4608 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4609 C added by Urszula Kozlowska. 07/11/2007
4610 C
4611       implicit real*8 (a-h,o-z)
4612       include 'DIMENSIONS'
4613       include 'DIMENSIONS.ZSCOPT'
4614       include 'DIMENSIONS.FREE'
4615       include 'COMMON.GEO'
4616       include 'COMMON.LOCAL'
4617       include 'COMMON.VAR'
4618       include 'COMMON.SCROT'
4619       include 'COMMON.INTERACT'
4620       include 'COMMON.DERIV'
4621       include 'COMMON.CHAIN'
4622       include 'COMMON.IOUNITS'
4623       include 'COMMON.NAMES'
4624       include 'COMMON.FFIELD'
4625       include 'COMMON.CONTROL'
4626       include 'COMMON.VECTORS'
4627       double precision x_prime(3),y_prime(3),z_prime(3)
4628      &    , sumene,dsc_i,dp2_i,x(65),
4629      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4630      &    de_dxx,de_dyy,de_dzz,de_dt
4631       double precision s1_t,s1_6_t,s2_t,s2_6_t
4632       double precision
4633      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4634      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4635      & dt_dCi(3),dt_dCi1(3)
4636       common /sccalc/ time11,time12,time112,theti,it,nlobit
4637       delta=0.02d0*pi
4638       escloc=0.0D0
4639       do i=loc_start,loc_end
4640         costtab(i+1) =dcos(theta(i+1))
4641         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4642         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4643         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4644         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4645         cosfac=dsqrt(cosfac2)
4646         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4647         sinfac=dsqrt(sinfac2)
4648         it=itype(i)
4649         if (it.eq.10) goto 1
4650 c
4651 C  Compute the axes of tghe local cartesian coordinates system; store in
4652 c   x_prime, y_prime and z_prime
4653 c
4654         do j=1,3
4655           x_prime(j) = 0.00
4656           y_prime(j) = 0.00
4657           z_prime(j) = 0.00
4658         enddo
4659 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4660 C     &   dc_norm(3,i+nres)
4661         do j = 1,3
4662           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4663           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4664         enddo
4665         do j = 1,3
4666           z_prime(j) = -uz(j,i-1)
4667         enddo
4668 c       write (2,*) "i",i
4669 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4670 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4671 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4672 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4673 c      & " xy",scalar(x_prime(1),y_prime(1)),
4674 c      & " xz",scalar(x_prime(1),z_prime(1)),
4675 c      & " yy",scalar(y_prime(1),y_prime(1)),
4676 c      & " yz",scalar(y_prime(1),z_prime(1)),
4677 c      & " zz",scalar(z_prime(1),z_prime(1))
4678 c
4679 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4680 C to local coordinate system. Store in xx, yy, zz.
4681 c
4682         xx=0.0d0
4683         yy=0.0d0
4684         zz=0.0d0
4685         do j = 1,3
4686           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4687           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4688           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4689         enddo
4690
4691         xxtab(i)=xx
4692         yytab(i)=yy
4693         zztab(i)=zz
4694 C
4695 C Compute the energy of the ith side cbain
4696 C
4697 c        write (2,*) "xx",xx," yy",yy," zz",zz
4698         it=itype(i)
4699         do j = 1,65
4700           x(j) = sc_parmin(j,it)
4701         enddo
4702 #ifdef CHECK_COORD
4703 Cc diagnostics - remove later
4704         xx1 = dcos(alph(2))
4705         yy1 = dsin(alph(2))*dcos(omeg(2))
4706         zz1 = -dsin(alph(2))*dsin(omeg(2))
4707         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4708      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4709      &    xx1,yy1,zz1
4710 C,"  --- ", xx_w,yy_w,zz_w
4711 c end diagnostics
4712 #endif
4713         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4714      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4715      &   + x(10)*yy*zz
4716         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4717      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4718      & + x(20)*yy*zz
4719         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4720      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4721      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4722      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4723      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4724      &  +x(40)*xx*yy*zz
4725         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4726      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4727      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4728      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4729      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4730      &  +x(60)*xx*yy*zz
4731         dsc_i   = 0.743d0+x(61)
4732         dp2_i   = 1.9d0+x(62)
4733         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4734      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4735         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4736      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4737         s1=(1+x(63))/(0.1d0 + dscp1)
4738         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4739         s2=(1+x(65))/(0.1d0 + dscp2)
4740         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4741         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4742      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4743 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4744 c     &   sumene4,
4745 c     &   dscp1,dscp2,sumene
4746 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4747         escloc = escloc + sumene
4748 c        write (2,*) "escloc",escloc
4749         if (.not. calc_grad) goto 1
4750
4751 #ifdef DEBUG2
4752 C
4753 C This section to check the numerical derivatives of the energy of ith side
4754 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4755 C #define DEBUG in the code to turn it on.
4756 C
4757         write (2,*) "sumene               =",sumene
4758         aincr=1.0d-7
4759         xxsave=xx
4760         xx=xx+aincr
4761         write (2,*) xx,yy,zz
4762         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4763         de_dxx_num=(sumenep-sumene)/aincr
4764         xx=xxsave
4765         write (2,*) "xx+ sumene from enesc=",sumenep
4766         yysave=yy
4767         yy=yy+aincr
4768         write (2,*) xx,yy,zz
4769         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4770         de_dyy_num=(sumenep-sumene)/aincr
4771         yy=yysave
4772         write (2,*) "yy+ sumene from enesc=",sumenep
4773         zzsave=zz
4774         zz=zz+aincr
4775         write (2,*) xx,yy,zz
4776         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4777         de_dzz_num=(sumenep-sumene)/aincr
4778         zz=zzsave
4779         write (2,*) "zz+ sumene from enesc=",sumenep
4780         costsave=cost2tab(i+1)
4781         sintsave=sint2tab(i+1)
4782         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4783         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4784         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4785         de_dt_num=(sumenep-sumene)/aincr
4786         write (2,*) " t+ sumene from enesc=",sumenep
4787         cost2tab(i+1)=costsave
4788         sint2tab(i+1)=sintsave
4789 C End of diagnostics section.
4790 #endif
4791 C
4792 C Compute the gradient of esc
4793 C
4794         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4795         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4796         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4797         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4798         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4799         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4800         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4801         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4802         pom1=(sumene3*sint2tab(i+1)+sumene1)
4803      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4804         pom2=(sumene4*cost2tab(i+1)+sumene2)
4805      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4806         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4807         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4808      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4809      &  +x(40)*yy*zz
4810         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4811         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4812      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4813      &  +x(60)*yy*zz
4814         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4815      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4816      &        +(pom1+pom2)*pom_dx
4817 #ifdef DEBUG
4818         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4819 #endif
4820 C
4821         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4822         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4823      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4824      &  +x(40)*xx*zz
4825         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4826         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4827      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4828      &  +x(59)*zz**2 +x(60)*xx*zz
4829         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4830      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4831      &        +(pom1-pom2)*pom_dy
4832 #ifdef DEBUG
4833         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4834 #endif
4835 C
4836         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4837      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4838      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4839      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4840      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4841      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4842      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4843      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4844 #ifdef DEBUG
4845         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4846 #endif
4847 C
4848         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4849      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4850      &  +pom1*pom_dt1+pom2*pom_dt2
4851 #ifdef DEBUG
4852         write(2,*), "de_dt = ", de_dt,de_dt_num
4853 #endif
4854 c
4855 C
4856        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4857        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4858        cosfac2xx=cosfac2*xx
4859        sinfac2yy=sinfac2*yy
4860        do k = 1,3
4861          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4862      &      vbld_inv(i+1)
4863          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4864      &      vbld_inv(i)
4865          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4866          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4867 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4868 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4869 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4870 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4871          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4872          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4873          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4874          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4875          dZZ_Ci1(k)=0.0d0
4876          dZZ_Ci(k)=0.0d0
4877          do j=1,3
4878            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4879            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4880          enddo
4881
4882          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4883          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4884          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4885 c
4886          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4887          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4888        enddo
4889
4890        do k=1,3
4891          dXX_Ctab(k,i)=dXX_Ci(k)
4892          dXX_C1tab(k,i)=dXX_Ci1(k)
4893          dYY_Ctab(k,i)=dYY_Ci(k)
4894          dYY_C1tab(k,i)=dYY_Ci1(k)
4895          dZZ_Ctab(k,i)=dZZ_Ci(k)
4896          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4897          dXX_XYZtab(k,i)=dXX_XYZ(k)
4898          dYY_XYZtab(k,i)=dYY_XYZ(k)
4899          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4900        enddo
4901
4902        do k = 1,3
4903 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4904 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4905 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4906 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4907 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4908 c     &    dt_dci(k)
4909 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4910 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4911          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4912      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4913          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4914      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4915          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4916      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4917        enddo
4918 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4919 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4920
4921 C to check gradient call subroutine check_grad
4922
4923     1 continue
4924       enddo
4925       return
4926       end
4927 #endif
4928 c------------------------------------------------------------------------------
4929       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4930 C
4931 C This procedure calculates two-body contact function g(rij) and its derivative:
4932 C
4933 C           eps0ij                                     !       x < -1
4934 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4935 C            0                                         !       x > 1
4936 C
4937 C where x=(rij-r0ij)/delta
4938 C
4939 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4940 C
4941       implicit none
4942       double precision rij,r0ij,eps0ij,fcont,fprimcont
4943       double precision x,x2,x4,delta
4944 c     delta=0.02D0*r0ij
4945 c      delta=0.2D0*r0ij
4946       x=(rij-r0ij)/delta
4947       if (x.lt.-1.0D0) then
4948         fcont=eps0ij
4949         fprimcont=0.0D0
4950       else if (x.le.1.0D0) then
4951         x2=x*x
4952         x4=x2*x2
4953         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4954         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4955       else
4956         fcont=0.0D0
4957         fprimcont=0.0D0
4958       endif
4959       return
4960       end
4961 c------------------------------------------------------------------------------
4962       subroutine splinthet(theti,delta,ss,ssder)
4963       implicit real*8 (a-h,o-z)
4964       include 'DIMENSIONS'
4965       include 'DIMENSIONS.ZSCOPT'
4966       include 'COMMON.VAR'
4967       include 'COMMON.GEO'
4968       thetup=pi-delta
4969       thetlow=delta
4970       if (theti.gt.pipol) then
4971         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4972       else
4973         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4974         ssder=-ssder
4975       endif
4976       return
4977       end
4978 c------------------------------------------------------------------------------
4979       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4980       implicit none
4981       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4982       double precision ksi,ksi2,ksi3,a1,a2,a3
4983       a1=fprim0*delta/(f1-f0)
4984       a2=3.0d0-2.0d0*a1
4985       a3=a1-2.0d0
4986       ksi=(x-x0)/delta
4987       ksi2=ksi*ksi
4988       ksi3=ksi2*ksi
4989       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4990       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4991       return
4992       end
4993 c------------------------------------------------------------------------------
4994       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4995       implicit none
4996       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4997       double precision ksi,ksi2,ksi3,a1,a2,a3
4998       ksi=(x-x0)/delta
4999       ksi2=ksi*ksi
5000       ksi3=ksi2*ksi
5001       a1=fprim0x*delta
5002       a2=3*(f1x-f0x)-2*fprim0x*delta
5003       a3=fprim0x*delta-2*(f1x-f0x)
5004       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5005       return
5006       end
5007 C-----------------------------------------------------------------------------
5008 #ifdef CRYST_TOR
5009 C-----------------------------------------------------------------------------
5010       subroutine etor(etors,edihcnstr,fact)
5011       implicit real*8 (a-h,o-z)
5012       include 'DIMENSIONS'
5013       include 'DIMENSIONS.ZSCOPT'
5014       include 'COMMON.VAR'
5015       include 'COMMON.GEO'
5016       include 'COMMON.LOCAL'
5017       include 'COMMON.TORSION'
5018       include 'COMMON.INTERACT'
5019       include 'COMMON.DERIV'
5020       include 'COMMON.CHAIN'
5021       include 'COMMON.NAMES'
5022       include 'COMMON.IOUNITS'
5023       include 'COMMON.FFIELD'
5024       include 'COMMON.TORCNSTR'
5025       logical lprn
5026 C Set lprn=.true. for debugging
5027       lprn=.false.
5028 c      lprn=.true.
5029       etors=0.0D0
5030       do i=iphi_start,iphi_end
5031         itori=itortyp(itype(i-2))
5032         itori1=itortyp(itype(i-1))
5033         phii=phi(i)
5034         gloci=0.0D0
5035 C Proline-Proline pair is a special case...
5036         if (itori.eq.3 .and. itori1.eq.3) then
5037           if (phii.gt.-dwapi3) then
5038             cosphi=dcos(3*phii)
5039             fac=1.0D0/(1.0D0-cosphi)
5040             etorsi=v1(1,3,3)*fac
5041             etorsi=etorsi+etorsi
5042             etors=etors+etorsi-v1(1,3,3)
5043             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5044           endif
5045           do j=1,3
5046             v1ij=v1(j+1,itori,itori1)
5047             v2ij=v2(j+1,itori,itori1)
5048             cosphi=dcos(j*phii)
5049             sinphi=dsin(j*phii)
5050             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5051             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5052           enddo
5053         else
5054           do j=1,nterm_old
5055             v1ij=v1(j,itori,itori1)
5056             v2ij=v2(j,itori,itori1)
5057             cosphi=dcos(j*phii)
5058             sinphi=dsin(j*phii)
5059             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5060             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5061           enddo
5062         endif
5063         if (lprn)
5064      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5065      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5066      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5067         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5068 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5069       enddo
5070 ! 6/20/98 - dihedral angle constraints
5071       edihcnstr=0.0d0
5072       do i=1,ndih_constr
5073         itori=idih_constr(i)
5074         phii=phi(itori)
5075         difi=phii-phi0(i)
5076         if (difi.gt.drange(i)) then
5077           difi=difi-drange(i)
5078           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5079           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5080         else if (difi.lt.-drange(i)) then
5081           difi=difi+drange(i)
5082           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5083           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5084         endif
5085 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5086 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5087       enddo
5088 !      write (iout,*) 'edihcnstr',edihcnstr
5089       return
5090       end
5091 c------------------------------------------------------------------------------
5092 #else
5093       subroutine etor(etors,edihcnstr,fact)
5094       implicit real*8 (a-h,o-z)
5095       include 'DIMENSIONS'
5096       include 'DIMENSIONS.ZSCOPT'
5097       include 'COMMON.VAR'
5098       include 'COMMON.GEO'
5099       include 'COMMON.LOCAL'
5100       include 'COMMON.TORSION'
5101       include 'COMMON.INTERACT'
5102       include 'COMMON.DERIV'
5103       include 'COMMON.CHAIN'
5104       include 'COMMON.NAMES'
5105       include 'COMMON.IOUNITS'
5106       include 'COMMON.FFIELD'
5107       include 'COMMON.TORCNSTR'
5108       logical lprn
5109 C Set lprn=.true. for debugging
5110       lprn=.false.
5111 c      lprn=.true.
5112       etors=0.0D0
5113       do i=iphi_start,iphi_end
5114         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5115         itori=itortyp(itype(i-2))
5116         itori1=itortyp(itype(i-1))
5117         phii=phi(i)
5118         gloci=0.0D0
5119 C Regular cosine and sine terms
5120         do j=1,nterm(itori,itori1)
5121           v1ij=v1(j,itori,itori1)
5122           v2ij=v2(j,itori,itori1)
5123           cosphi=dcos(j*phii)
5124           sinphi=dsin(j*phii)
5125           etors=etors+v1ij*cosphi+v2ij*sinphi
5126           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5127         enddo
5128 C Lorentz terms
5129 C                         v1
5130 C  E = SUM ----------------------------------- - v1
5131 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5132 C
5133         cosphi=dcos(0.5d0*phii)
5134         sinphi=dsin(0.5d0*phii)
5135         do j=1,nlor(itori,itori1)
5136           vl1ij=vlor1(j,itori,itori1)
5137           vl2ij=vlor2(j,itori,itori1)
5138           vl3ij=vlor3(j,itori,itori1)
5139           pom=vl2ij*cosphi+vl3ij*sinphi
5140           pom1=1.0d0/(pom*pom+1.0d0)
5141           etors=etors+vl1ij*pom1
5142           pom=-pom*pom1*pom1
5143           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5144         enddo
5145 C Subtract the constant term
5146         etors=etors-v0(itori,itori1)
5147         if (lprn)
5148      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5149      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5150      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5151         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5152 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5153  1215   continue
5154       enddo
5155 ! 6/20/98 - dihedral angle constraints
5156       edihcnstr=0.0d0
5157       do i=1,ndih_constr
5158         itori=idih_constr(i)
5159         phii=phi(itori)
5160         difi=pinorm(phii-phi0(i))
5161         edihi=0.0d0
5162         if (difi.gt.drange(i)) then
5163           difi=difi-drange(i)
5164           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5165           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5166           edihi=0.25d0*ftors*difi**4
5167         else if (difi.lt.-drange(i)) then
5168           difi=difi+drange(i)
5169           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5170           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5171           edihi=0.25d0*ftors*difi**4
5172         else
5173           difi=0.0d0
5174         endif
5175 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5176 c     &    drange(i),edihi
5177 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5178 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5179       enddo
5180 !      write (iout,*) 'edihcnstr',edihcnstr
5181       return
5182       end
5183 c----------------------------------------------------------------------------
5184       subroutine etor_d(etors_d,fact2)
5185 C 6/23/01 Compute double torsional energy
5186       implicit real*8 (a-h,o-z)
5187       include 'DIMENSIONS'
5188       include 'DIMENSIONS.ZSCOPT'
5189       include 'COMMON.VAR'
5190       include 'COMMON.GEO'
5191       include 'COMMON.LOCAL'
5192       include 'COMMON.TORSION'
5193       include 'COMMON.INTERACT'
5194       include 'COMMON.DERIV'
5195       include 'COMMON.CHAIN'
5196       include 'COMMON.NAMES'
5197       include 'COMMON.IOUNITS'
5198       include 'COMMON.FFIELD'
5199       include 'COMMON.TORCNSTR'
5200       logical lprn
5201 C Set lprn=.true. for debugging
5202       lprn=.false.
5203 c     lprn=.true.
5204       etors_d=0.0D0
5205       do i=iphi_start,iphi_end-1
5206         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5207      &     goto 1215
5208         itori=itortyp(itype(i-2))
5209         itori1=itortyp(itype(i-1))
5210         itori2=itortyp(itype(i))
5211         phii=phi(i)
5212         phii1=phi(i+1)
5213         gloci1=0.0D0
5214         gloci2=0.0D0
5215 C Regular cosine and sine terms
5216         do j=1,ntermd_1(itori,itori1,itori2)
5217           v1cij=v1c(1,j,itori,itori1,itori2)
5218           v1sij=v1s(1,j,itori,itori1,itori2)
5219           v2cij=v1c(2,j,itori,itori1,itori2)
5220           v2sij=v1s(2,j,itori,itori1,itori2)
5221           cosphi1=dcos(j*phii)
5222           sinphi1=dsin(j*phii)
5223           cosphi2=dcos(j*phii1)
5224           sinphi2=dsin(j*phii1)
5225           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5226      &     v2cij*cosphi2+v2sij*sinphi2
5227           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5228           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5229         enddo
5230         do k=2,ntermd_2(itori,itori1,itori2)
5231           do l=1,k-1
5232             v1cdij = v2c(k,l,itori,itori1,itori2)
5233             v2cdij = v2c(l,k,itori,itori1,itori2)
5234             v1sdij = v2s(k,l,itori,itori1,itori2)
5235             v2sdij = v2s(l,k,itori,itori1,itori2)
5236             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5237             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5238             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5239             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5240             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5241      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5242             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5243      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5244             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5245      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5246           enddo
5247         enddo
5248         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5249         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5250  1215   continue
5251       enddo
5252       return
5253       end
5254 #endif
5255 c------------------------------------------------------------------------------
5256       subroutine eback_sc_corr(esccor)
5257 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5258 c        conformational states; temporarily implemented as differences
5259 c        between UNRES torsional potentials (dependent on three types of
5260 c        residues) and the torsional potentials dependent on all 20 types
5261 c        of residues computed from AM1 energy surfaces of terminally-blocked
5262 c        amino-acid residues.
5263       implicit real*8 (a-h,o-z)
5264       include 'DIMENSIONS'
5265       include 'DIMENSIONS.ZSCOPT'
5266       include 'DIMENSIONS.FREE'
5267       include 'COMMON.VAR'
5268       include 'COMMON.GEO'
5269       include 'COMMON.LOCAL'
5270       include 'COMMON.TORSION'
5271       include 'COMMON.SCCOR'
5272       include 'COMMON.INTERACT'
5273       include 'COMMON.DERIV'
5274       include 'COMMON.CHAIN'
5275       include 'COMMON.NAMES'
5276       include 'COMMON.IOUNITS'
5277       include 'COMMON.FFIELD'
5278       include 'COMMON.CONTROL'
5279       logical lprn
5280 C Set lprn=.true. for debugging
5281       lprn=.false.
5282 c      lprn=.true.
5283 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5284       esccor=0.0D0
5285       do i=itau_start,itau_end
5286         esccor_ii=0.0D0
5287         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5288         isccori=isccortyp(itype(i-2))
5289         isccori1=isccortyp(itype(i-1))
5290         phii=phi(i)
5291 cccc  Added 9 May 2012
5292 cc Tauangle is torsional engle depending on the value of first digit
5293 c(see comment below)
5294 cc Omicron is flat angle depending on the value of first digit
5295 c(see comment below)
5296
5297
5298         do intertyp=1,3 !intertyp
5299 cc Added 09 May 2012 (Adasko)
5300 cc  Intertyp means interaction type of backbone mainchain correlation:
5301 c   1 = SC...Ca...Ca...Ca
5302 c   2 = Ca...Ca...Ca...SC
5303 c   3 = SC...Ca...Ca...SCi
5304         gloci=0.0D0
5305         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5306      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5307      &      (itype(i-1).eq.21)))
5308      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5309      &     .or.(itype(i-2).eq.21)))
5310      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5311      &      (itype(i-1).eq.21)))) cycle
5312         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5313         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5314      & cycle
5315         do j=1,nterm_sccor(isccori,isccori1)
5316           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5317           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5318           cosphi=dcos(j*tauangle(intertyp,i))
5319           sinphi=dsin(j*tauangle(intertyp,i))
5320           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5321 #ifdef DEBUG
5322           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5323 #endif
5324           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5325         enddo
5326         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5327 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5328 c     &gloc_sc(intertyp,i-3,icg)
5329         if (lprn)
5330      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5331      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5332      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5333      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5334         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5335        enddo !intertyp
5336 #ifdef DEBUG
5337        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5338 #endif
5339       enddo
5340 c        do i=1,nres
5341 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5342 c        enddo
5343       return
5344       end
5345 c------------------------------------------------------------------------------
5346       subroutine multibody(ecorr)
5347 C This subroutine calculates multi-body contributions to energy following
5348 C the idea of Skolnick et al. If side chains I and J make a contact and
5349 C at the same time side chains I+1 and J+1 make a contact, an extra
5350 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5351       implicit real*8 (a-h,o-z)
5352       include 'DIMENSIONS'
5353       include 'COMMON.IOUNITS'
5354       include 'COMMON.DERIV'
5355       include 'COMMON.INTERACT'
5356       include 'COMMON.CONTACTS'
5357       double precision gx(3),gx1(3)
5358       logical lprn
5359
5360 C Set lprn=.true. for debugging
5361       lprn=.false.
5362
5363       if (lprn) then
5364         write (iout,'(a)') 'Contact function values:'
5365         do i=nnt,nct-2
5366           write (iout,'(i2,20(1x,i2,f10.5))')
5367      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5368         enddo
5369       endif
5370       ecorr=0.0D0
5371       do i=nnt,nct
5372         do j=1,3
5373           gradcorr(j,i)=0.0D0
5374           gradxorr(j,i)=0.0D0
5375         enddo
5376       enddo
5377       do i=nnt,nct-2
5378
5379         DO ISHIFT = 3,4
5380
5381         i1=i+ishift
5382         num_conti=num_cont(i)
5383         num_conti1=num_cont(i1)
5384         do jj=1,num_conti
5385           j=jcont(jj,i)
5386           do kk=1,num_conti1
5387             j1=jcont(kk,i1)
5388             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5389 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5390 cd   &                   ' ishift=',ishift
5391 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5392 C The system gains extra energy.
5393               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5394             endif   ! j1==j+-ishift
5395           enddo     ! kk
5396         enddo       ! jj
5397
5398         ENDDO ! ISHIFT
5399
5400       enddo         ! i
5401       return
5402       end
5403 c------------------------------------------------------------------------------
5404       double precision function esccorr(i,j,k,l,jj,kk)
5405       implicit real*8 (a-h,o-z)
5406       include 'DIMENSIONS'
5407       include 'COMMON.IOUNITS'
5408       include 'COMMON.DERIV'
5409       include 'COMMON.INTERACT'
5410       include 'COMMON.CONTACTS'
5411       double precision gx(3),gx1(3)
5412       logical lprn
5413       lprn=.false.
5414       eij=facont(jj,i)
5415       ekl=facont(kk,k)
5416 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5417 C Calculate the multi-body contribution to energy.
5418 C Calculate multi-body contributions to the gradient.
5419 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5420 cd   & k,l,(gacont(m,kk,k),m=1,3)
5421       do m=1,3
5422         gx(m) =ekl*gacont(m,jj,i)
5423         gx1(m)=eij*gacont(m,kk,k)
5424         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5425         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5426         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5427         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5428       enddo
5429       do m=i,j-1
5430         do ll=1,3
5431           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5432         enddo
5433       enddo
5434       do m=k,l-1
5435         do ll=1,3
5436           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5437         enddo
5438       enddo
5439       esccorr=-eij*ekl
5440       return
5441       end
5442 c------------------------------------------------------------------------------
5443 #ifdef MPL
5444       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5445       implicit real*8 (a-h,o-z)
5446       include 'DIMENSIONS'
5447       integer dimen1,dimen2,atom,indx
5448       double precision buffer(dimen1,dimen2)
5449       double precision zapas
5450       common /contacts_hb/ zapas(3,20,maxres,7),
5451      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5452      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5453       num_kont=num_cont_hb(atom)
5454       do i=1,num_kont
5455         do k=1,7
5456           do j=1,3
5457             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5458           enddo ! j
5459         enddo ! k
5460         buffer(i,indx+22)=facont_hb(i,atom)
5461         buffer(i,indx+23)=ees0p(i,atom)
5462         buffer(i,indx+24)=ees0m(i,atom)
5463         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5464       enddo ! i
5465       buffer(1,indx+26)=dfloat(num_kont)
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5470       implicit real*8 (a-h,o-z)
5471       include 'DIMENSIONS'
5472       integer dimen1,dimen2,atom,indx
5473       double precision buffer(dimen1,dimen2)
5474       double precision zapas
5475       common /contacts_hb/ zapas(3,20,maxres,7),
5476      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5477      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5478       num_kont=buffer(1,indx+26)
5479       num_kont_old=num_cont_hb(atom)
5480       num_cont_hb(atom)=num_kont+num_kont_old
5481       do i=1,num_kont
5482         ii=i+num_kont_old
5483         do k=1,7
5484           do j=1,3
5485             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5486           enddo ! j
5487         enddo ! k
5488         facont_hb(ii,atom)=buffer(i,indx+22)
5489         ees0p(ii,atom)=buffer(i,indx+23)
5490         ees0m(ii,atom)=buffer(i,indx+24)
5491         jcont_hb(ii,atom)=buffer(i,indx+25)
5492       enddo ! i
5493       return
5494       end
5495 c------------------------------------------------------------------------------
5496 #endif
5497       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5498 C This subroutine calculates multi-body contributions to hydrogen-bonding
5499       implicit real*8 (a-h,o-z)
5500       include 'DIMENSIONS'
5501       include 'DIMENSIONS.ZSCOPT'
5502       include 'COMMON.IOUNITS'
5503 #ifdef MPL
5504       include 'COMMON.INFO'
5505 #endif
5506       include 'COMMON.FFIELD'
5507       include 'COMMON.DERIV'
5508       include 'COMMON.INTERACT'
5509       include 'COMMON.CONTACTS'
5510 #ifdef MPL
5511       parameter (max_cont=maxconts)
5512       parameter (max_dim=2*(8*3+2))
5513       parameter (msglen1=max_cont*max_dim*4)
5514       parameter (msglen2=2*msglen1)
5515       integer source,CorrelType,CorrelID,Error
5516       double precision buffer(max_cont,max_dim)
5517 #endif
5518       double precision gx(3),gx1(3)
5519       logical lprn,ldone
5520
5521 C Set lprn=.true. for debugging
5522       lprn=.false.
5523 #ifdef MPL
5524       n_corr=0
5525       n_corr1=0
5526       if (fgProcs.le.1) goto 30
5527       if (lprn) then
5528         write (iout,'(a)') 'Contact function values:'
5529         do i=nnt,nct-2
5530           write (iout,'(2i3,50(1x,i2,f5.2))')
5531      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5532      &    j=1,num_cont_hb(i))
5533         enddo
5534       endif
5535 C Caution! Following code assumes that electrostatic interactions concerning
5536 C a given atom are split among at most two processors!
5537       CorrelType=477
5538       CorrelID=MyID+1
5539       ldone=.false.
5540       do i=1,max_cont
5541         do j=1,max_dim
5542           buffer(i,j)=0.0D0
5543         enddo
5544       enddo
5545       mm=mod(MyRank,2)
5546 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5547       if (mm) 20,20,10
5548    10 continue
5549 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5550       if (MyRank.gt.0) then
5551 C Send correlation contributions to the preceding processor
5552         msglen=msglen1
5553         nn=num_cont_hb(iatel_s)
5554         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5555 cd      write (iout,*) 'The BUFFER array:'
5556 cd      do i=1,nn
5557 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5558 cd      enddo
5559         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5560           msglen=msglen2
5561             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5562 C Clear the contacts of the atom passed to the neighboring processor
5563         nn=num_cont_hb(iatel_s+1)
5564 cd      do i=1,nn
5565 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5566 cd      enddo
5567             num_cont_hb(iatel_s)=0
5568         endif
5569 cd      write (iout,*) 'Processor ',MyID,MyRank,
5570 cd   & ' is sending correlation contribution to processor',MyID-1,
5571 cd   & ' msglen=',msglen
5572 cd      write (*,*) 'Processor ',MyID,MyRank,
5573 cd   & ' is sending correlation contribution to processor',MyID-1,
5574 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5575         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5576 cd      write (iout,*) 'Processor ',MyID,
5577 cd   & ' has sent correlation contribution to processor',MyID-1,
5578 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5579 cd      write (*,*) 'Processor ',MyID,
5580 cd   & ' has sent correlation contribution to processor',MyID-1,
5581 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5582         msglen=msglen1
5583       endif ! (MyRank.gt.0)
5584       if (ldone) goto 30
5585       ldone=.true.
5586    20 continue
5587 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5588       if (MyRank.lt.fgProcs-1) then
5589 C Receive correlation contributions from the next processor
5590         msglen=msglen1
5591         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5592 cd      write (iout,*) 'Processor',MyID,
5593 cd   & ' is receiving correlation contribution from processor',MyID+1,
5594 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5595 cd      write (*,*) 'Processor',MyID,
5596 cd   & ' is receiving correlation contribution from processor',MyID+1,
5597 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5598         nbytes=-1
5599         do while (nbytes.le.0)
5600           call mp_probe(MyID+1,CorrelType,nbytes)
5601         enddo
5602 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5603         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5604 cd      write (iout,*) 'Processor',MyID,
5605 cd   & ' has received correlation contribution from processor',MyID+1,
5606 cd   & ' msglen=',msglen,' nbytes=',nbytes
5607 cd      write (iout,*) 'The received BUFFER array:'
5608 cd      do i=1,max_cont
5609 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5610 cd      enddo
5611         if (msglen.eq.msglen1) then
5612           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5613         else if (msglen.eq.msglen2)  then
5614           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5615           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5616         else
5617           write (iout,*)
5618      & 'ERROR!!!! message length changed while processing correlations.'
5619           write (*,*)
5620      & 'ERROR!!!! message length changed while processing correlations.'
5621           call mp_stopall(Error)
5622         endif ! msglen.eq.msglen1
5623       endif ! MyRank.lt.fgProcs-1
5624       if (ldone) goto 30
5625       ldone=.true.
5626       goto 10
5627    30 continue
5628 #endif
5629       if (lprn) then
5630         write (iout,'(a)') 'Contact function values:'
5631         do i=nnt,nct-2
5632           write (iout,'(2i3,50(1x,i2,f5.2))')
5633      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5634      &    j=1,num_cont_hb(i))
5635         enddo
5636       endif
5637       ecorr=0.0D0
5638 C Remove the loop below after debugging !!!
5639       do i=nnt,nct
5640         do j=1,3
5641           gradcorr(j,i)=0.0D0
5642           gradxorr(j,i)=0.0D0
5643         enddo
5644       enddo
5645 C Calculate the local-electrostatic correlation terms
5646       do i=iatel_s,iatel_e+1
5647         i1=i+1
5648         num_conti=num_cont_hb(i)
5649         num_conti1=num_cont_hb(i+1)
5650         do jj=1,num_conti
5651           j=jcont_hb(jj,i)
5652           do kk=1,num_conti1
5653             j1=jcont_hb(kk,i1)
5654 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5655 c     &         ' jj=',jj,' kk=',kk
5656             if (j1.eq.j+1 .or. j1.eq.j-1) then
5657 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5658 C The system gains extra energy.
5659               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5660 #ifdef DEBUG
5661               write (iout,*) "ecorr",i,j,i+1,j1,
5662      &               ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5663 #endif
5664               n_corr=n_corr+1
5665             else if (j1.eq.j) then
5666 C Contacts I-J and I-(J+1) occur simultaneously.
5667 C The system loses extra energy.
5668 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5669             endif
5670           enddo ! kk
5671           do kk=1,num_conti
5672             j1=jcont_hb(kk,i)
5673 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5674 c    &         ' jj=',jj,' kk=',kk
5675             if (j1.eq.j+1) then
5676 C Contacts I-J and (I+1)-J occur simultaneously.
5677 C The system loses extra energy.
5678 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5679             endif ! j1==j+1
5680           enddo ! kk
5681         enddo ! jj
5682       enddo ! i
5683       return
5684       end
5685 c------------------------------------------------------------------------------
5686       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5687      &  n_corr1)
5688 C This subroutine calculates multi-body contributions to hydrogen-bonding
5689       implicit real*8 (a-h,o-z)
5690       include 'DIMENSIONS'
5691       include 'DIMENSIONS.ZSCOPT'
5692       include 'COMMON.IOUNITS'
5693 #ifdef MPL
5694       include 'COMMON.INFO'
5695 #endif
5696       include 'COMMON.FFIELD'
5697       include 'COMMON.DERIV'
5698       include 'COMMON.INTERACT'
5699       include 'COMMON.CONTACTS'
5700 #ifdef MPL
5701       parameter (max_cont=maxconts)
5702       parameter (max_dim=2*(8*3+2))
5703       parameter (msglen1=max_cont*max_dim*4)
5704       parameter (msglen2=2*msglen1)
5705       integer source,CorrelType,CorrelID,Error
5706       double precision buffer(max_cont,max_dim)
5707 #endif
5708       double precision gx(3),gx1(3)
5709       logical lprn,ldone
5710
5711 C Set lprn=.true. for debugging
5712       lprn=.false.
5713       eturn6=0.0d0
5714 #ifdef MPL
5715       n_corr=0
5716       n_corr1=0
5717       if (fgProcs.le.1) goto 30
5718       if (lprn) then
5719         write (iout,'(a)') 'Contact function values:'
5720         do i=nnt,nct-2
5721           write (iout,'(2i3,50(1x,i2,f5.2))')
5722      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5723      &    j=1,num_cont_hb(i))
5724         enddo
5725       endif
5726 C Caution! Following code assumes that electrostatic interactions concerning
5727 C a given atom are split among at most two processors!
5728       CorrelType=477
5729       CorrelID=MyID+1
5730       ldone=.false.
5731       do i=1,max_cont
5732         do j=1,max_dim
5733           buffer(i,j)=0.0D0
5734         enddo
5735       enddo
5736       mm=mod(MyRank,2)
5737 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5738       if (mm) 20,20,10
5739    10 continue
5740 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5741       if (MyRank.gt.0) then
5742 C Send correlation contributions to the preceding processor
5743         msglen=msglen1
5744         nn=num_cont_hb(iatel_s)
5745         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5746 cd      write (iout,*) 'The BUFFER array:'
5747 cd      do i=1,nn
5748 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5749 cd      enddo
5750         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5751           msglen=msglen2
5752             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5753 C Clear the contacts of the atom passed to the neighboring processor
5754         nn=num_cont_hb(iatel_s+1)
5755 cd      do i=1,nn
5756 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5757 cd      enddo
5758             num_cont_hb(iatel_s)=0
5759         endif
5760 cd      write (iout,*) 'Processor ',MyID,MyRank,
5761 cd   & ' is sending correlation contribution to processor',MyID-1,
5762 cd   & ' msglen=',msglen
5763 cd      write (*,*) 'Processor ',MyID,MyRank,
5764 cd   & ' is sending correlation contribution to processor',MyID-1,
5765 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5766         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5767 cd      write (iout,*) 'Processor ',MyID,
5768 cd   & ' has sent correlation contribution to processor',MyID-1,
5769 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5770 cd      write (*,*) 'Processor ',MyID,
5771 cd   & ' has sent correlation contribution to processor',MyID-1,
5772 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5773         msglen=msglen1
5774       endif ! (MyRank.gt.0)
5775       if (ldone) goto 30
5776       ldone=.true.
5777    20 continue
5778 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5779       if (MyRank.lt.fgProcs-1) then
5780 C Receive correlation contributions from the next processor
5781         msglen=msglen1
5782         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5783 cd      write (iout,*) 'Processor',MyID,
5784 cd   & ' is receiving correlation contribution from processor',MyID+1,
5785 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5786 cd      write (*,*) 'Processor',MyID,
5787 cd   & ' is receiving correlation contribution from processor',MyID+1,
5788 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5789         nbytes=-1
5790         do while (nbytes.le.0)
5791           call mp_probe(MyID+1,CorrelType,nbytes)
5792         enddo
5793 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5794         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5795 cd      write (iout,*) 'Processor',MyID,
5796 cd   & ' has received correlation contribution from processor',MyID+1,
5797 cd   & ' msglen=',msglen,' nbytes=',nbytes
5798 cd      write (iout,*) 'The received BUFFER array:'
5799 cd      do i=1,max_cont
5800 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5801 cd      enddo
5802         if (msglen.eq.msglen1) then
5803           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5804         else if (msglen.eq.msglen2)  then
5805           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5806           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5807         else
5808           write (iout,*)
5809      & 'ERROR!!!! message length changed while processing correlations.'
5810           write (*,*)
5811      & 'ERROR!!!! message length changed while processing correlations.'
5812           call mp_stopall(Error)
5813         endif ! msglen.eq.msglen1
5814       endif ! MyRank.lt.fgProcs-1
5815       if (ldone) goto 30
5816       ldone=.true.
5817       goto 10
5818    30 continue
5819 #endif
5820       if (lprn) then
5821         write (iout,'(a)') 'Contact function values:'
5822         do i=nnt,nct-2
5823           write (iout,'(2i3,50(1x,i2,f5.2))')
5824      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5825      &    j=1,num_cont_hb(i))
5826         enddo
5827       endif
5828       ecorr=0.0D0
5829       ecorr5=0.0d0
5830       ecorr6=0.0d0
5831 C Remove the loop below after debugging !!!
5832       do i=nnt,nct
5833         do j=1,3
5834           gradcorr(j,i)=0.0D0
5835           gradxorr(j,i)=0.0D0
5836         enddo
5837       enddo
5838 C Calculate the dipole-dipole interaction energies
5839       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5840       do i=iatel_s,iatel_e+1
5841         num_conti=num_cont_hb(i)
5842         do jj=1,num_conti
5843           j=jcont_hb(jj,i)
5844           call dipole(i,j,jj)
5845         enddo
5846       enddo
5847       endif
5848 C Calculate the local-electrostatic correlation terms
5849       do i=iatel_s,iatel_e+1
5850         i1=i+1
5851         num_conti=num_cont_hb(i)
5852         num_conti1=num_cont_hb(i+1)
5853         do jj=1,num_conti
5854           j=jcont_hb(jj,i)
5855           do kk=1,num_conti1
5856             j1=jcont_hb(kk,i1)
5857 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5858 c     &         ' jj=',jj,' kk=',kk
5859             if (j1.eq.j+1 .or. j1.eq.j-1) then
5860 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5861 C The system gains extra energy.
5862               n_corr=n_corr+1
5863               sqd1=dsqrt(d_cont(jj,i))
5864               sqd2=dsqrt(d_cont(kk,i1))
5865               sred_geom = sqd1*sqd2
5866               IF (sred_geom.lt.cutoff_corr) THEN
5867                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5868      &            ekont,fprimcont)
5869 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5870 c     &         ' jj=',jj,' kk=',kk
5871                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5872                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5873                 do l=1,3
5874                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5875                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5876                 enddo
5877                 n_corr1=n_corr1+1
5878 cd               write (iout,*) 'sred_geom=',sred_geom,
5879 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5880                 call calc_eello(i,j,i+1,j1,jj,kk)
5881                 if (wcorr4.gt.0.0d0)
5882      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5883                 if (wcorr5.gt.0.0d0)
5884      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5885 c                print *,"wcorr5",ecorr5
5886 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5887 cd                write(2,*)'ijkl',i,j,i+1,j1
5888                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5889      &               .or. wturn6.eq.0.0d0))then
5890 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5891                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5892 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5893 cd     &            'ecorr6=',ecorr6
5894 cd                write (iout,'(4e15.5)') sred_geom,
5895 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5896 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5897 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5898                 else if (wturn6.gt.0.0d0
5899      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5900 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5901                   eturn6=eturn6+eello_turn6(i,jj,kk)
5902 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5903                 endif
5904               ENDIF
5905 1111          continue
5906             else if (j1.eq.j) then
5907 C Contacts I-J and I-(J+1) occur simultaneously.
5908 C The system loses extra energy.
5909 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5910             endif
5911           enddo ! kk
5912           do kk=1,num_conti
5913             j1=jcont_hb(kk,i)
5914 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5915 c    &         ' jj=',jj,' kk=',kk
5916             if (j1.eq.j+1) then
5917 C Contacts I-J and (I+1)-J occur simultaneously.
5918 C The system loses extra energy.
5919 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5920             endif ! j1==j+1
5921           enddo ! kk
5922         enddo ! jj
5923       enddo ! i
5924       return
5925       end
5926 c------------------------------------------------------------------------------
5927       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5928       implicit real*8 (a-h,o-z)
5929       include 'DIMENSIONS'
5930       include 'COMMON.IOUNITS'
5931       include 'COMMON.DERIV'
5932       include 'COMMON.INTERACT'
5933       include 'COMMON.CONTACTS'
5934       double precision gx(3),gx1(3)
5935       logical lprn
5936       lprn=.false.
5937       eij=facont_hb(jj,i)
5938       ekl=facont_hb(kk,k)
5939       ees0pij=ees0p(jj,i)
5940       ees0pkl=ees0p(kk,k)
5941       ees0mij=ees0m(jj,i)
5942       ees0mkl=ees0m(kk,k)
5943       ekont=eij*ekl
5944       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5945 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5946 C Following 4 lines for diagnostics.
5947 cd    ees0pkl=0.0D0
5948 cd    ees0pij=1.0D0
5949 cd    ees0mkl=0.0D0
5950 cd    ees0mij=1.0D0
5951 cd      write (iout,*)'Contacts have occurred for peptide groups',i,j,
5952 cd     &   ' and',k,l
5953 cd      write (iout,*)'Contacts have occurred for peptide groups',
5954 cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5955 cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5956 C Calculate the multi-body contribution to energy.
5957       ecorr=ecorr+ekont*ees
5958       if (calc_grad) then
5959 C Calculate multi-body contributions to the gradient.
5960       do ll=1,3
5961         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5962         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5963      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5964      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5965         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5966      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5967      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5968         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5969         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5970      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5971      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5972         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5973      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5974      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5975       enddo
5976       do m=i+1,j-1
5977         do ll=1,3
5978           gradcorr(ll,m)=gradcorr(ll,m)+
5979      &     ees*ekl*gacont_hbr(ll,jj,i)-
5980      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5981      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5982         enddo
5983       enddo
5984       do m=k+1,l-1
5985         do ll=1,3
5986           gradcorr(ll,m)=gradcorr(ll,m)+
5987      &     ees*eij*gacont_hbr(ll,kk,k)-
5988      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5989      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5990         enddo
5991       enddo
5992       endif
5993       ehbcorr=ekont*ees
5994       return
5995       end
5996 C---------------------------------------------------------------------------
5997       subroutine dipole(i,j,jj)
5998       implicit real*8 (a-h,o-z)
5999       include 'DIMENSIONS'
6000       include 'DIMENSIONS.ZSCOPT'
6001       include 'COMMON.IOUNITS'
6002       include 'COMMON.CHAIN'
6003       include 'COMMON.FFIELD'
6004       include 'COMMON.DERIV'
6005       include 'COMMON.INTERACT'
6006       include 'COMMON.CONTACTS'
6007       include 'COMMON.TORSION'
6008       include 'COMMON.VAR'
6009       include 'COMMON.GEO'
6010       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6011      &  auxmat(2,2)
6012       iti1 = itortyp(itype(i+1))
6013       if (j.lt.nres-1) then
6014         itj1 = itortyp(itype(j+1))
6015       else
6016         itj1=ntortyp+1
6017       endif
6018       do iii=1,2
6019         dipi(iii,1)=Ub2(iii,i)
6020         dipderi(iii)=Ub2der(iii,i)
6021         dipi(iii,2)=b1(iii,iti1)
6022         dipj(iii,1)=Ub2(iii,j)
6023         dipderj(iii)=Ub2der(iii,j)
6024         dipj(iii,2)=b1(iii,itj1)
6025       enddo
6026       kkk=0
6027       do iii=1,2
6028         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6029         do jjj=1,2
6030           kkk=kkk+1
6031           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6032         enddo
6033       enddo
6034       if (.not.calc_grad) return
6035       do kkk=1,5
6036         do lll=1,3
6037           mmm=0
6038           do iii=1,2
6039             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6040      &        auxvec(1))
6041             do jjj=1,2
6042               mmm=mmm+1
6043               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6044             enddo
6045           enddo
6046         enddo
6047       enddo
6048       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6049       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6050       do iii=1,2
6051         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6052       enddo
6053       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6054       do iii=1,2
6055         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6056       enddo
6057       return
6058       end
6059 C---------------------------------------------------------------------------
6060       subroutine calc_eello(i,j,k,l,jj,kk)
6061 C
6062 C This subroutine computes matrices and vectors needed to calculate
6063 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6064 C
6065       implicit real*8 (a-h,o-z)
6066       include 'DIMENSIONS'
6067       include 'DIMENSIONS.ZSCOPT'
6068       include 'COMMON.IOUNITS'
6069       include 'COMMON.CHAIN'
6070       include 'COMMON.DERIV'
6071       include 'COMMON.INTERACT'
6072       include 'COMMON.CONTACTS'
6073       include 'COMMON.TORSION'
6074       include 'COMMON.VAR'
6075       include 'COMMON.GEO'
6076       include 'COMMON.FFIELD'
6077       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6078      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6079       logical lprn
6080       common /kutas/ lprn
6081 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6082 cd     & ' jj=',jj,' kk=',kk
6083 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6084       do iii=1,2
6085         do jjj=1,2
6086           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6087           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6088         enddo
6089       enddo
6090       call transpose2(aa1(1,1),aa1t(1,1))
6091       call transpose2(aa2(1,1),aa2t(1,1))
6092       do kkk=1,5
6093         do lll=1,3
6094           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6095      &      aa1tder(1,1,lll,kkk))
6096           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6097      &      aa2tder(1,1,lll,kkk))
6098         enddo
6099       enddo
6100       if (l.eq.j+1) then
6101 C parallel orientation of the two CA-CA-CA frames.
6102         if (i.gt.1) then
6103           iti=itortyp(itype(i))
6104         else
6105           iti=ntortyp+1
6106         endif
6107         itk1=itortyp(itype(k+1))
6108         itj=itortyp(itype(j))
6109         if (l.lt.nres-1) then
6110           itl1=itortyp(itype(l+1))
6111         else
6112           itl1=ntortyp+1
6113         endif
6114 C A1 kernel(j+1) A2T
6115 cd        do iii=1,2
6116 cd          write (iout,'(3f10.5,5x,3f10.5)')
6117 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6118 cd        enddo
6119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6120      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6121      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6122 C Following matrices are needed only for 6-th order cumulants
6123         IF (wcorr6.gt.0.0d0) THEN
6124         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6125      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6126      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6128      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6129      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6130      &   ADtEAderx(1,1,1,1,1,1))
6131         lprn=.false.
6132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6133      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6134      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6135      &   ADtEA1derx(1,1,1,1,1,1))
6136         ENDIF
6137 C End 6-th order cumulants
6138 cd        lprn=.false.
6139 cd        if (lprn) then
6140 cd        write (2,*) 'In calc_eello6'
6141 cd        do iii=1,2
6142 cd          write (2,*) 'iii=',iii
6143 cd          do kkk=1,5
6144 cd            write (2,*) 'kkk=',kkk
6145 cd            do jjj=1,2
6146 cd              write (2,'(3(2f10.5),5x)')
6147 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6148 cd            enddo
6149 cd          enddo
6150 cd        enddo
6151 cd        endif
6152         call transpose2(EUgder(1,1,k),auxmat(1,1))
6153         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6154         call transpose2(EUg(1,1,k),auxmat(1,1))
6155         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6156         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6157         do iii=1,2
6158           do kkk=1,5
6159             do lll=1,3
6160               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6161      &          EAEAderx(1,1,lll,kkk,iii,1))
6162             enddo
6163           enddo
6164         enddo
6165 C A1T kernel(i+1) A2
6166         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6167      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6168      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6169 C Following matrices are needed only for 6-th order cumulants
6170         IF (wcorr6.gt.0.0d0) THEN
6171         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6172      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6173      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6174         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6175      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6176      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6177      &   ADtEAderx(1,1,1,1,1,2))
6178         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6179      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6180      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6181      &   ADtEA1derx(1,1,1,1,1,2))
6182         ENDIF
6183 C End 6-th order cumulants
6184         call transpose2(EUgder(1,1,l),auxmat(1,1))
6185         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6186         call transpose2(EUg(1,1,l),auxmat(1,1))
6187         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6188         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6189         do iii=1,2
6190           do kkk=1,5
6191             do lll=1,3
6192               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6193      &          EAEAderx(1,1,lll,kkk,iii,2))
6194             enddo
6195           enddo
6196         enddo
6197 C AEAb1 and AEAb2
6198 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6199 C They are needed only when the fifth- or the sixth-order cumulants are
6200 C indluded.
6201         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6202         call transpose2(AEA(1,1,1),auxmat(1,1))
6203         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6204         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6205         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6206         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6207         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6208         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6209         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6210         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6211         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6212         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6213         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6214         call transpose2(AEA(1,1,2),auxmat(1,1))
6215         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6216         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6217         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6218         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6219         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6220         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6221         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6222         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6223         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6224         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6225         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6226 C Calculate the Cartesian derivatives of the vectors.
6227         do iii=1,2
6228           do kkk=1,5
6229             do lll=1,3
6230               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6231               call matvec2(auxmat(1,1),b1(1,iti),
6232      &          AEAb1derx(1,lll,kkk,iii,1,1))
6233               call matvec2(auxmat(1,1),Ub2(1,i),
6234      &          AEAb2derx(1,lll,kkk,iii,1,1))
6235               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6236      &          AEAb1derx(1,lll,kkk,iii,2,1))
6237               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6238      &          AEAb2derx(1,lll,kkk,iii,2,1))
6239               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6240               call matvec2(auxmat(1,1),b1(1,itj),
6241      &          AEAb1derx(1,lll,kkk,iii,1,2))
6242               call matvec2(auxmat(1,1),Ub2(1,j),
6243      &          AEAb2derx(1,lll,kkk,iii,1,2))
6244               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6245      &          AEAb1derx(1,lll,kkk,iii,2,2))
6246               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6247      &          AEAb2derx(1,lll,kkk,iii,2,2))
6248             enddo
6249           enddo
6250         enddo
6251         ENDIF
6252 C End vectors
6253       else
6254 C Antiparallel orientation of the two CA-CA-CA frames.
6255         if (i.gt.1) then
6256           iti=itortyp(itype(i))
6257         else
6258           iti=ntortyp+1
6259         endif
6260         itk1=itortyp(itype(k+1))
6261         itl=itortyp(itype(l))
6262         itj=itortyp(itype(j))
6263         if (j.lt.nres-1) then
6264           itj1=itortyp(itype(j+1))
6265         else
6266           itj1=ntortyp+1
6267         endif
6268 C A2 kernel(j-1)T A1T
6269         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6270      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6271      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6272 C Following matrices are needed only for 6-th order cumulants
6273         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6274      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6275         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6276      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6277      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6278         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6279      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6280      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6281      &   ADtEAderx(1,1,1,1,1,1))
6282         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6283      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6284      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6285      &   ADtEA1derx(1,1,1,1,1,1))
6286         ENDIF
6287 C End 6-th order cumulants
6288         call transpose2(EUgder(1,1,k),auxmat(1,1))
6289         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6290         call transpose2(EUg(1,1,k),auxmat(1,1))
6291         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6292         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6293         do iii=1,2
6294           do kkk=1,5
6295             do lll=1,3
6296               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6297      &          EAEAderx(1,1,lll,kkk,iii,1))
6298             enddo
6299           enddo
6300         enddo
6301 C A2T kernel(i+1)T A1
6302         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6303      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6304      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6305 C Following matrices are needed only for 6-th order cumulants
6306         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6307      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6308         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6309      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6310      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6311         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6312      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6313      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6314      &   ADtEAderx(1,1,1,1,1,2))
6315         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6316      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6317      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6318      &   ADtEA1derx(1,1,1,1,1,2))
6319         ENDIF
6320 C End 6-th order cumulants
6321         call transpose2(EUgder(1,1,j),auxmat(1,1))
6322         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6323         call transpose2(EUg(1,1,j),auxmat(1,1))
6324         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6325         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6326         do iii=1,2
6327           do kkk=1,5
6328             do lll=1,3
6329               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6330      &          EAEAderx(1,1,lll,kkk,iii,2))
6331             enddo
6332           enddo
6333         enddo
6334 C AEAb1 and AEAb2
6335 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6336 C They are needed only when the fifth- or the sixth-order cumulants are
6337 C indluded.
6338         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6339      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6340         call transpose2(AEA(1,1,1),auxmat(1,1))
6341         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6342         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6343         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6344         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6345         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6346         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6347         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6348         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6349         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6350         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6351         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6352         call transpose2(AEA(1,1,2),auxmat(1,1))
6353         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6354         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6355         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6356         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6357         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6358         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6359         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6360         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6361         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6362         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6363         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6364 C Calculate the Cartesian derivatives of the vectors.
6365         do iii=1,2
6366           do kkk=1,5
6367             do lll=1,3
6368               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6369               call matvec2(auxmat(1,1),b1(1,iti),
6370      &          AEAb1derx(1,lll,kkk,iii,1,1))
6371               call matvec2(auxmat(1,1),Ub2(1,i),
6372      &          AEAb2derx(1,lll,kkk,iii,1,1))
6373               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6374      &          AEAb1derx(1,lll,kkk,iii,2,1))
6375               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6376      &          AEAb2derx(1,lll,kkk,iii,2,1))
6377               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6378               call matvec2(auxmat(1,1),b1(1,itl),
6379      &          AEAb1derx(1,lll,kkk,iii,1,2))
6380               call matvec2(auxmat(1,1),Ub2(1,l),
6381      &          AEAb2derx(1,lll,kkk,iii,1,2))
6382               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6383      &          AEAb1derx(1,lll,kkk,iii,2,2))
6384               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6385      &          AEAb2derx(1,lll,kkk,iii,2,2))
6386             enddo
6387           enddo
6388         enddo
6389         ENDIF
6390 C End vectors
6391       endif
6392       return
6393       end
6394 C---------------------------------------------------------------------------
6395       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6396      &  KK,KKderg,AKA,AKAderg,AKAderx)
6397       implicit none
6398       integer nderg
6399       logical transp
6400       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6401      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6402      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6403       integer iii,kkk,lll
6404       integer jjj,mmm
6405       logical lprn
6406       common /kutas/ lprn
6407       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6408       do iii=1,nderg
6409         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6410      &    AKAderg(1,1,iii))
6411       enddo
6412 cd      if (lprn) write (2,*) 'In kernel'
6413       do kkk=1,5
6414 cd        if (lprn) write (2,*) 'kkk=',kkk
6415         do lll=1,3
6416           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6417      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6418 cd          if (lprn) then
6419 cd            write (2,*) 'lll=',lll
6420 cd            write (2,*) 'iii=1'
6421 cd            do jjj=1,2
6422 cd              write (2,'(3(2f10.5),5x)')
6423 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6424 cd            enddo
6425 cd          endif
6426           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6427      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6428 cd          if (lprn) then
6429 cd            write (2,*) 'lll=',lll
6430 cd            write (2,*) 'iii=2'
6431 cd            do jjj=1,2
6432 cd              write (2,'(3(2f10.5),5x)')
6433 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6434 cd            enddo
6435 cd          endif
6436         enddo
6437       enddo
6438       return
6439       end
6440 C---------------------------------------------------------------------------
6441       double precision function eello4(i,j,k,l,jj,kk)
6442       implicit real*8 (a-h,o-z)
6443       include 'DIMENSIONS'
6444       include 'DIMENSIONS.ZSCOPT'
6445       include 'COMMON.IOUNITS'
6446       include 'COMMON.CHAIN'
6447       include 'COMMON.DERIV'
6448       include 'COMMON.INTERACT'
6449       include 'COMMON.CONTACTS'
6450       include 'COMMON.TORSION'
6451       include 'COMMON.VAR'
6452       include 'COMMON.GEO'
6453       double precision pizda(2,2),ggg1(3),ggg2(3)
6454 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6455 cd        eello4=0.0d0
6456 cd        return
6457 cd      endif
6458 cd      print *,'eello4:',i,j,k,l,jj,kk
6459 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6460 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6461 cold      eij=facont_hb(jj,i)
6462 cold      ekl=facont_hb(kk,k)
6463 cold      ekont=eij*ekl
6464       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6465       if (calc_grad) then
6466 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6467       gcorr_loc(k-1)=gcorr_loc(k-1)
6468      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6469       if (l.eq.j+1) then
6470         gcorr_loc(l-1)=gcorr_loc(l-1)
6471      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6472       else
6473         gcorr_loc(j-1)=gcorr_loc(j-1)
6474      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6475       endif
6476       do iii=1,2
6477         do kkk=1,5
6478           do lll=1,3
6479             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6480      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6481 cd            derx(lll,kkk,iii)=0.0d0
6482           enddo
6483         enddo
6484       enddo
6485 cd      gcorr_loc(l-1)=0.0d0
6486 cd      gcorr_loc(j-1)=0.0d0
6487 cd      gcorr_loc(k-1)=0.0d0
6488 cd      eel4=1.0d0
6489 cd      write (iout,*)'Contacts have occurred for peptide groups',
6490 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6491 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6492       if (j.lt.nres-1) then
6493         j1=j+1
6494         j2=j-1
6495       else
6496         j1=j-1
6497         j2=j-2
6498       endif
6499       if (l.lt.nres-1) then
6500         l1=l+1
6501         l2=l-1
6502       else
6503         l1=l-1
6504         l2=l-2
6505       endif
6506       do ll=1,3
6507 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6508         ggg1(ll)=eel4*g_contij(ll,1)
6509         ggg2(ll)=eel4*g_contij(ll,2)
6510         ghalf=0.5d0*ggg1(ll)
6511 cd        ghalf=0.0d0
6512         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6513         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6514         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6515         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6516 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6517         ghalf=0.5d0*ggg2(ll)
6518 cd        ghalf=0.0d0
6519         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6520         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6521         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6522         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6523       enddo
6524 cd      goto 1112
6525       do m=i+1,j-1
6526         do ll=1,3
6527 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6528           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6529         enddo
6530       enddo
6531       do m=k+1,l-1
6532         do ll=1,3
6533 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6534           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6535         enddo
6536       enddo
6537 1112  continue
6538       do m=i+2,j2
6539         do ll=1,3
6540           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6541         enddo
6542       enddo
6543       do m=k+2,l2
6544         do ll=1,3
6545           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6546         enddo
6547       enddo
6548 cd      do iii=1,nres-3
6549 cd        write (2,*) iii,gcorr_loc(iii)
6550 cd      enddo
6551       endif
6552       eello4=ekont*eel4
6553 cd      write (2,*) 'ekont',ekont
6554 cd      write (iout,*) 'eello4',ekont*eel4
6555       return
6556       end
6557 C---------------------------------------------------------------------------
6558       double precision function eello5(i,j,k,l,jj,kk)
6559       implicit real*8 (a-h,o-z)
6560       include 'DIMENSIONS'
6561       include 'DIMENSIONS.ZSCOPT'
6562       include 'COMMON.IOUNITS'
6563       include 'COMMON.CHAIN'
6564       include 'COMMON.DERIV'
6565       include 'COMMON.INTERACT'
6566       include 'COMMON.CONTACTS'
6567       include 'COMMON.TORSION'
6568       include 'COMMON.VAR'
6569       include 'COMMON.GEO'
6570       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6571       double precision ggg1(3),ggg2(3)
6572 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6573 C                                                                              C
6574 C                            Parallel chains                                   C
6575 C                                                                              C
6576 C          o             o                   o             o                   C
6577 C         /l\           / \             \   / \           / \   /              C
6578 C        /   \         /   \             \ /   \         /   \ /               C
6579 C       j| o |l1       | o |              o| o |         | o |o                C
6580 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6581 C      \i/   \         /   \ /             /   \         /   \                 C
6582 C       o    k1             o                                                  C
6583 C         (I)          (II)                (III)          (IV)                 C
6584 C                                                                              C
6585 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6586 C                                                                              C
6587 C                            Antiparallel chains                               C
6588 C                                                                              C
6589 C          o             o                   o             o                   C
6590 C         /j\           / \             \   / \           / \   /              C
6591 C        /   \         /   \             \ /   \         /   \ /               C
6592 C      j1| o |l        | o |              o| o |         | o |o                C
6593 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6594 C      \i/   \         /   \ /             /   \         /   \                 C
6595 C       o     k1            o                                                  C
6596 C         (I)          (II)                (III)          (IV)                 C
6597 C                                                                              C
6598 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6599 C                                                                              C
6600 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6601 C                                                                              C
6602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6603 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6604 cd        eello5=0.0d0
6605 cd        return
6606 cd      endif
6607 cd      write (iout,*)
6608 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6609 cd     &   ' and',k,l
6610       itk=itortyp(itype(k))
6611       itl=itortyp(itype(l))
6612       itj=itortyp(itype(j))
6613       eello5_1=0.0d0
6614       eello5_2=0.0d0
6615       eello5_3=0.0d0
6616       eello5_4=0.0d0
6617 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6618 cd     &   eel5_3_num,eel5_4_num)
6619       do iii=1,2
6620         do kkk=1,5
6621           do lll=1,3
6622             derx(lll,kkk,iii)=0.0d0
6623           enddo
6624         enddo
6625       enddo
6626 cd      eij=facont_hb(jj,i)
6627 cd      ekl=facont_hb(kk,k)
6628 cd      ekont=eij*ekl
6629 cd      write (iout,*)'Contacts have occurred for peptide groups',
6630 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6631 cd      goto 1111
6632 C Contribution from the graph I.
6633 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6634 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6635       call transpose2(EUg(1,1,k),auxmat(1,1))
6636       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6637       vv(1)=pizda(1,1)-pizda(2,2)
6638       vv(2)=pizda(1,2)+pizda(2,1)
6639       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6640      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6641       if (calc_grad) then
6642 C Explicit gradient in virtual-dihedral angles.
6643       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6644      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6645      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6646       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6647       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6648       vv(1)=pizda(1,1)-pizda(2,2)
6649       vv(2)=pizda(1,2)+pizda(2,1)
6650       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6651      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6652      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6653       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6654       vv(1)=pizda(1,1)-pizda(2,2)
6655       vv(2)=pizda(1,2)+pizda(2,1)
6656       if (l.eq.j+1) then
6657         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6658      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6659      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6660       else
6661         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6662      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6664       endif
6665 C Cartesian gradient
6666       do iii=1,2
6667         do kkk=1,5
6668           do lll=1,3
6669             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6670      &        pizda(1,1))
6671             vv(1)=pizda(1,1)-pizda(2,2)
6672             vv(2)=pizda(1,2)+pizda(2,1)
6673             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6674      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6675      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6676           enddo
6677         enddo
6678       enddo
6679 c      goto 1112
6680       endif
6681 c1111  continue
6682 C Contribution from graph II
6683       call transpose2(EE(1,1,itk),auxmat(1,1))
6684       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6685       vv(1)=pizda(1,1)+pizda(2,2)
6686       vv(2)=pizda(2,1)-pizda(1,2)
6687       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6688      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6689       if (calc_grad) then
6690 C Explicit gradient in virtual-dihedral angles.
6691       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6692      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6693       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6694       vv(1)=pizda(1,1)+pizda(2,2)
6695       vv(2)=pizda(2,1)-pizda(1,2)
6696       if (l.eq.j+1) then
6697         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6698      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6699      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6700       else
6701         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6702      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6703      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6704       endif
6705 C Cartesian gradient
6706       do iii=1,2
6707         do kkk=1,5
6708           do lll=1,3
6709             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6710      &        pizda(1,1))
6711             vv(1)=pizda(1,1)+pizda(2,2)
6712             vv(2)=pizda(2,1)-pizda(1,2)
6713             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6714      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6715      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6716           enddo
6717         enddo
6718       enddo
6719 cd      goto 1112
6720       endif
6721 cd1111  continue
6722       if (l.eq.j+1) then
6723 cd        goto 1110
6724 C Parallel orientation
6725 C Contribution from graph III
6726         call transpose2(EUg(1,1,l),auxmat(1,1))
6727         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6728         vv(1)=pizda(1,1)-pizda(2,2)
6729         vv(2)=pizda(1,2)+pizda(2,1)
6730         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6731      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6732         if (calc_grad) then
6733 C Explicit gradient in virtual-dihedral angles.
6734         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6735      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6736      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6737         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6738         vv(1)=pizda(1,1)-pizda(2,2)
6739         vv(2)=pizda(1,2)+pizda(2,1)
6740         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6741      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6742      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6743         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6744         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6745         vv(1)=pizda(1,1)-pizda(2,2)
6746         vv(2)=pizda(1,2)+pizda(2,1)
6747         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6748      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6749      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6750 C Cartesian gradient
6751         do iii=1,2
6752           do kkk=1,5
6753             do lll=1,3
6754               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6755      &          pizda(1,1))
6756               vv(1)=pizda(1,1)-pizda(2,2)
6757               vv(2)=pizda(1,2)+pizda(2,1)
6758               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6759      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6760      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6761             enddo
6762           enddo
6763         enddo
6764 cd        goto 1112
6765         endif
6766 C Contribution from graph IV
6767 cd1110    continue
6768         call transpose2(EE(1,1,itl),auxmat(1,1))
6769         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6770         vv(1)=pizda(1,1)+pizda(2,2)
6771         vv(2)=pizda(2,1)-pizda(1,2)
6772         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6773      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6774         if (calc_grad) then
6775 C Explicit gradient in virtual-dihedral angles.
6776         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6777      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6778         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6779         vv(1)=pizda(1,1)+pizda(2,2)
6780         vv(2)=pizda(2,1)-pizda(1,2)
6781         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6782      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6783      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6784 C Cartesian gradient
6785         do iii=1,2
6786           do kkk=1,5
6787             do lll=1,3
6788               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6789      &          pizda(1,1))
6790               vv(1)=pizda(1,1)+pizda(2,2)
6791               vv(2)=pizda(2,1)-pizda(1,2)
6792               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6793      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6794      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6795             enddo
6796           enddo
6797         enddo
6798         endif
6799       else
6800 C Antiparallel orientation
6801 C Contribution from graph III
6802 c        goto 1110
6803         call transpose2(EUg(1,1,j),auxmat(1,1))
6804         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6805         vv(1)=pizda(1,1)-pizda(2,2)
6806         vv(2)=pizda(1,2)+pizda(2,1)
6807         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6808      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6809         if (calc_grad) then
6810 C Explicit gradient in virtual-dihedral angles.
6811         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6812      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6813      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6814         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6815         vv(1)=pizda(1,1)-pizda(2,2)
6816         vv(2)=pizda(1,2)+pizda(2,1)
6817         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6818      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6820         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6821         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6822         vv(1)=pizda(1,1)-pizda(2,2)
6823         vv(2)=pizda(1,2)+pizda(2,1)
6824         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6825      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6826      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6827 C Cartesian gradient
6828         do iii=1,2
6829           do kkk=1,5
6830             do lll=1,3
6831               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6832      &          pizda(1,1))
6833               vv(1)=pizda(1,1)-pizda(2,2)
6834               vv(2)=pizda(1,2)+pizda(2,1)
6835               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6836      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6837      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6838             enddo
6839           enddo
6840         enddo
6841 cd        goto 1112
6842         endif
6843 C Contribution from graph IV
6844 1110    continue
6845         call transpose2(EE(1,1,itj),auxmat(1,1))
6846         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6847         vv(1)=pizda(1,1)+pizda(2,2)
6848         vv(2)=pizda(2,1)-pizda(1,2)
6849         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6850      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6851         if (calc_grad) then
6852 C Explicit gradient in virtual-dihedral angles.
6853         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6854      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6855         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6856         vv(1)=pizda(1,1)+pizda(2,2)
6857         vv(2)=pizda(2,1)-pizda(1,2)
6858         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6859      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6860      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6861 C Cartesian gradient
6862         do iii=1,2
6863           do kkk=1,5
6864             do lll=1,3
6865               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6866      &          pizda(1,1))
6867               vv(1)=pizda(1,1)+pizda(2,2)
6868               vv(2)=pizda(2,1)-pizda(1,2)
6869               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6870      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6871      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6872             enddo
6873           enddo
6874         enddo
6875       endif
6876       endif
6877 1112  continue
6878       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6879 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6880 cd        write (2,*) 'ijkl',i,j,k,l
6881 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6882 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6883 cd      endif
6884 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6885 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6886 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6887 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6888       if (calc_grad) then
6889       if (j.lt.nres-1) then
6890         j1=j+1
6891         j2=j-1
6892       else
6893         j1=j-1
6894         j2=j-2
6895       endif
6896       if (l.lt.nres-1) then
6897         l1=l+1
6898         l2=l-1
6899       else
6900         l1=l-1
6901         l2=l-2
6902       endif
6903 cd      eij=1.0d0
6904 cd      ekl=1.0d0
6905 cd      ekont=1.0d0
6906 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6907       do ll=1,3
6908         ggg1(ll)=eel5*g_contij(ll,1)
6909         ggg2(ll)=eel5*g_contij(ll,2)
6910 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6911         ghalf=0.5d0*ggg1(ll)
6912 cd        ghalf=0.0d0
6913         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6914         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6915         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6916         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6917 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6918         ghalf=0.5d0*ggg2(ll)
6919 cd        ghalf=0.0d0
6920         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6921         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6922         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6923         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6924       enddo
6925 cd      goto 1112
6926       do m=i+1,j-1
6927         do ll=1,3
6928 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6929           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6930         enddo
6931       enddo
6932       do m=k+1,l-1
6933         do ll=1,3
6934 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6935           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6936         enddo
6937       enddo
6938 c1112  continue
6939       do m=i+2,j2
6940         do ll=1,3
6941           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6942         enddo
6943       enddo
6944       do m=k+2,l2
6945         do ll=1,3
6946           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6947         enddo
6948       enddo
6949 cd      do iii=1,nres-3
6950 cd        write (2,*) iii,g_corr5_loc(iii)
6951 cd      enddo
6952       endif
6953       eello5=ekont*eel5
6954 cd      write (2,*) 'ekont',ekont
6955 cd      write (iout,*) 'eello5',ekont*eel5
6956       return
6957       end
6958 c--------------------------------------------------------------------------
6959       double precision function eello6(i,j,k,l,jj,kk)
6960       implicit real*8 (a-h,o-z)
6961       include 'DIMENSIONS'
6962       include 'DIMENSIONS.ZSCOPT'
6963       include 'COMMON.IOUNITS'
6964       include 'COMMON.CHAIN'
6965       include 'COMMON.DERIV'
6966       include 'COMMON.INTERACT'
6967       include 'COMMON.CONTACTS'
6968       include 'COMMON.TORSION'
6969       include 'COMMON.VAR'
6970       include 'COMMON.GEO'
6971       include 'COMMON.FFIELD'
6972       double precision ggg1(3),ggg2(3)
6973 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6974 cd        eello6=0.0d0
6975 cd        return
6976 cd      endif
6977 cd      write (iout,*)
6978 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6979 cd     &   ' and',k,l
6980       eello6_1=0.0d0
6981       eello6_2=0.0d0
6982       eello6_3=0.0d0
6983       eello6_4=0.0d0
6984       eello6_5=0.0d0
6985       eello6_6=0.0d0
6986 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6987 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6988       do iii=1,2
6989         do kkk=1,5
6990           do lll=1,3
6991             derx(lll,kkk,iii)=0.0d0
6992           enddo
6993         enddo
6994       enddo
6995 cd      eij=facont_hb(jj,i)
6996 cd      ekl=facont_hb(kk,k)
6997 cd      ekont=eij*ekl
6998 cd      eij=1.0d0
6999 cd      ekl=1.0d0
7000 cd      ekont=1.0d0
7001       if (l.eq.j+1) then
7002         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7003         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7004         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7005         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7006         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7007         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7008       else
7009         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7010         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7011         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7012         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7013         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7014           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7015         else
7016           eello6_5=0.0d0
7017         endif
7018         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7019       endif
7020 C If turn contributions are considered, they will be handled separately.
7021       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7022 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7023 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7024 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7025 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7026 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7027 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7028 cd      goto 1112
7029       if (calc_grad) then
7030       if (j.lt.nres-1) then
7031         j1=j+1
7032         j2=j-1
7033       else
7034         j1=j-1
7035         j2=j-2
7036       endif
7037       if (l.lt.nres-1) then
7038         l1=l+1
7039         l2=l-1
7040       else
7041         l1=l-1
7042         l2=l-2
7043       endif
7044       do ll=1,3
7045         ggg1(ll)=eel6*g_contij(ll,1)
7046         ggg2(ll)=eel6*g_contij(ll,2)
7047 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7048         ghalf=0.5d0*ggg1(ll)
7049 cd        ghalf=0.0d0
7050         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7051         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7052         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7053         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7054         ghalf=0.5d0*ggg2(ll)
7055 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7056 cd        ghalf=0.0d0
7057         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7058         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7059         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7060         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7061       enddo
7062 cd      goto 1112
7063       do m=i+1,j-1
7064         do ll=1,3
7065 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7066           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7067         enddo
7068       enddo
7069       do m=k+1,l-1
7070         do ll=1,3
7071 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7072           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7073         enddo
7074       enddo
7075 1112  continue
7076       do m=i+2,j2
7077         do ll=1,3
7078           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7079         enddo
7080       enddo
7081       do m=k+2,l2
7082         do ll=1,3
7083           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7084         enddo
7085       enddo
7086 cd      do iii=1,nres-3
7087 cd        write (2,*) iii,g_corr6_loc(iii)
7088 cd      enddo
7089       endif
7090       eello6=ekont*eel6
7091 cd      write (2,*) 'ekont',ekont
7092 cd      write (iout,*) 'eello6',ekont*eel6
7093       return
7094       end
7095 c--------------------------------------------------------------------------
7096       double precision function eello6_graph1(i,j,k,l,imat,swap)
7097       implicit real*8 (a-h,o-z)
7098       include 'DIMENSIONS'
7099       include 'DIMENSIONS.ZSCOPT'
7100       include 'COMMON.IOUNITS'
7101       include 'COMMON.CHAIN'
7102       include 'COMMON.DERIV'
7103       include 'COMMON.INTERACT'
7104       include 'COMMON.CONTACTS'
7105       include 'COMMON.TORSION'
7106       include 'COMMON.VAR'
7107       include 'COMMON.GEO'
7108       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7109       logical swap
7110       logical lprn
7111       common /kutas/ lprn
7112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7113 C                                                                              C
7114 C      Parallel       Antiparallel                                             C
7115 C                                                                              C
7116 C          o             o                                                     C
7117 C         /l\           /j\                                                    C
7118 C        /   \         /   \                                                   C
7119 C       /| o |         | o |\                                                  C
7120 C     \ j|/k\|  /   \  |/k\|l /                                                C
7121 C      \ /   \ /     \ /   \ /                                                 C
7122 C       o     o       o     o                                                  C
7123 C       i             i                                                        C
7124 C                                                                              C
7125 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7126       itk=itortyp(itype(k))
7127       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7128       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7129       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7130       call transpose2(EUgC(1,1,k),auxmat(1,1))
7131       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7132       vv1(1)=pizda1(1,1)-pizda1(2,2)
7133       vv1(2)=pizda1(1,2)+pizda1(2,1)
7134       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7135       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7136       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7137       s5=scalar2(vv(1),Dtobr2(1,i))
7138 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7139       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7140       if (.not. calc_grad) return
7141       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7142      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7143      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7144      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7145      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7146      & +scalar2(vv(1),Dtobr2der(1,i)))
7147       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7148       vv1(1)=pizda1(1,1)-pizda1(2,2)
7149       vv1(2)=pizda1(1,2)+pizda1(2,1)
7150       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7151       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7152       if (l.eq.j+1) then
7153         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7154      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7155      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7156      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7157      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7158       else
7159         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7160      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7161      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7162      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7163      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7164       endif
7165       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7166       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7167       vv1(1)=pizda1(1,1)-pizda1(2,2)
7168       vv1(2)=pizda1(1,2)+pizda1(2,1)
7169       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7170      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7171      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7172      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7173       do iii=1,2
7174         if (swap) then
7175           ind=3-iii
7176         else
7177           ind=iii
7178         endif
7179         do kkk=1,5
7180           do lll=1,3
7181             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7182             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7183             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7184             call transpose2(EUgC(1,1,k),auxmat(1,1))
7185             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7186      &        pizda1(1,1))
7187             vv1(1)=pizda1(1,1)-pizda1(2,2)
7188             vv1(2)=pizda1(1,2)+pizda1(2,1)
7189             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7190             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7191      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7192             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7193      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7194             s5=scalar2(vv(1),Dtobr2(1,i))
7195             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7196           enddo
7197         enddo
7198       enddo
7199       return
7200       end
7201 c----------------------------------------------------------------------------
7202       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7203       implicit real*8 (a-h,o-z)
7204       include 'DIMENSIONS'
7205       include 'DIMENSIONS.ZSCOPT'
7206       include 'COMMON.IOUNITS'
7207       include 'COMMON.CHAIN'
7208       include 'COMMON.DERIV'
7209       include 'COMMON.INTERACT'
7210       include 'COMMON.CONTACTS'
7211       include 'COMMON.TORSION'
7212       include 'COMMON.VAR'
7213       include 'COMMON.GEO'
7214       logical swap
7215       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7216      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7217       logical lprn
7218       common /kutas/ lprn
7219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7220 C                                                                              C
7221 C      Parallel       Antiparallel                                             C
7222 C                                                                              C
7223 C          o             o                                                     C
7224 C     \   /l\           /j\   /                                                C
7225 C      \ /   \         /   \ /                                                 C
7226 C       o| o |         | o |o                                                  C
7227 C     \ j|/k\|      \  |/k\|l                                                  C
7228 C      \ /   \       \ /   \                                                   C
7229 C       o             o                                                        C
7230 C       i             i                                                        C
7231 C                                                                              C
7232 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7233 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7234 C AL 7/4/01 s1 would occur in the sixth-order moment,
7235 C           but not in a cluster cumulant
7236 #ifdef MOMENT
7237       s1=dip(1,jj,i)*dip(1,kk,k)
7238 #endif
7239       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7240       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7241       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7242       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7243       call transpose2(EUg(1,1,k),auxmat(1,1))
7244       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7245       vv(1)=pizda(1,1)-pizda(2,2)
7246       vv(2)=pizda(1,2)+pizda(2,1)
7247       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7248 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7249 #ifdef MOMENT
7250       eello6_graph2=-(s1+s2+s3+s4)
7251 #else
7252       eello6_graph2=-(s2+s3+s4)
7253 #endif
7254 c      eello6_graph2=-s3
7255       if (.not. calc_grad) return
7256 C Derivatives in gamma(i-1)
7257       if (i.gt.1) then
7258 #ifdef MOMENT
7259         s1=dipderg(1,jj,i)*dip(1,kk,k)
7260 #endif
7261         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7262         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7263         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7264         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7265 #ifdef MOMENT
7266         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7267 #else
7268         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7269 #endif
7270 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7271       endif
7272 C Derivatives in gamma(k-1)
7273 #ifdef MOMENT
7274       s1=dip(1,jj,i)*dipderg(1,kk,k)
7275 #endif
7276       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7277       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7278       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7279       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7280       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7281       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7282       vv(1)=pizda(1,1)-pizda(2,2)
7283       vv(2)=pizda(1,2)+pizda(2,1)
7284       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7285 #ifdef MOMENT
7286       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7287 #else
7288       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7289 #endif
7290 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7291 C Derivatives in gamma(j-1) or gamma(l-1)
7292       if (j.gt.1) then
7293 #ifdef MOMENT
7294         s1=dipderg(3,jj,i)*dip(1,kk,k)
7295 #endif
7296         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7297         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7298         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7299         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7300         vv(1)=pizda(1,1)-pizda(2,2)
7301         vv(2)=pizda(1,2)+pizda(2,1)
7302         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7303 #ifdef MOMENT
7304         if (swap) then
7305           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7306         else
7307           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7308         endif
7309 #endif
7310         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7311 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7312       endif
7313 C Derivatives in gamma(l-1) or gamma(j-1)
7314       if (l.gt.1) then
7315 #ifdef MOMENT
7316         s1=dip(1,jj,i)*dipderg(3,kk,k)
7317 #endif
7318         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7319         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7320         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7321         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7322         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7323         vv(1)=pizda(1,1)-pizda(2,2)
7324         vv(2)=pizda(1,2)+pizda(2,1)
7325         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7326 #ifdef MOMENT
7327         if (swap) then
7328           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7329         else
7330           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7331         endif
7332 #endif
7333         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7334 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7335       endif
7336 C Cartesian derivatives.
7337       if (lprn) then
7338         write (2,*) 'In eello6_graph2'
7339         do iii=1,2
7340           write (2,*) 'iii=',iii
7341           do kkk=1,5
7342             write (2,*) 'kkk=',kkk
7343             do jjj=1,2
7344               write (2,'(3(2f10.5),5x)')
7345      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7346             enddo
7347           enddo
7348         enddo
7349       endif
7350       do iii=1,2
7351         do kkk=1,5
7352           do lll=1,3
7353 #ifdef MOMENT
7354             if (iii.eq.1) then
7355               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7356             else
7357               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7358             endif
7359 #endif
7360             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7361      &        auxvec(1))
7362             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7363             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7364      &        auxvec(1))
7365             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7366             call transpose2(EUg(1,1,k),auxmat(1,1))
7367             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7368      &        pizda(1,1))
7369             vv(1)=pizda(1,1)-pizda(2,2)
7370             vv(2)=pizda(1,2)+pizda(2,1)
7371             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7372 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7373 #ifdef MOMENT
7374             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7375 #else
7376             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7377 #endif
7378             if (swap) then
7379               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7380             else
7381               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7382             endif
7383           enddo
7384         enddo
7385       enddo
7386       return
7387       end
7388 c----------------------------------------------------------------------------
7389       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7390       implicit real*8 (a-h,o-z)
7391       include 'DIMENSIONS'
7392       include 'DIMENSIONS.ZSCOPT'
7393       include 'COMMON.IOUNITS'
7394       include 'COMMON.CHAIN'
7395       include 'COMMON.DERIV'
7396       include 'COMMON.INTERACT'
7397       include 'COMMON.CONTACTS'
7398       include 'COMMON.TORSION'
7399       include 'COMMON.VAR'
7400       include 'COMMON.GEO'
7401       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7402       logical swap
7403 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7404 C                                                                              C
7405 C      Parallel       Antiparallel                                             C
7406 C                                                                              C
7407 C          o             o                                                     C
7408 C         /l\   /   \   /j\                                                    C
7409 C        /   \ /     \ /   \                                                   C
7410 C       /| o |o       o| o |\                                                  C
7411 C       j|/k\|  /      |/k\|l /                                                C
7412 C        /   \ /       /   \ /                                                 C
7413 C       /     o       /     o                                                  C
7414 C       i             i                                                        C
7415 C                                                                              C
7416 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7417 C
7418 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7419 C           energy moment and not to the cluster cumulant.
7420       iti=itortyp(itype(i))
7421       if (j.lt.nres-1) then
7422         itj1=itortyp(itype(j+1))
7423       else
7424         itj1=ntortyp+1
7425       endif
7426       itk=itortyp(itype(k))
7427       itk1=itortyp(itype(k+1))
7428       if (l.lt.nres-1) then
7429         itl1=itortyp(itype(l+1))
7430       else
7431         itl1=ntortyp+1
7432       endif
7433 #ifdef MOMENT
7434       s1=dip(4,jj,i)*dip(4,kk,k)
7435 #endif
7436       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7437       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7438       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7439       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7440       call transpose2(EE(1,1,itk),auxmat(1,1))
7441       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7442       vv(1)=pizda(1,1)+pizda(2,2)
7443       vv(2)=pizda(2,1)-pizda(1,2)
7444       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7445 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7446 #ifdef MOMENT
7447       eello6_graph3=-(s1+s2+s3+s4)
7448 #else
7449       eello6_graph3=-(s2+s3+s4)
7450 #endif
7451 c      eello6_graph3=-s4
7452       if (.not. calc_grad) return
7453 C Derivatives in gamma(k-1)
7454       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7455       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7456       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7457       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7458 C Derivatives in gamma(l-1)
7459       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7460       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7461       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7462       vv(1)=pizda(1,1)+pizda(2,2)
7463       vv(2)=pizda(2,1)-pizda(1,2)
7464       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7465       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7466 C Cartesian derivatives.
7467       do iii=1,2
7468         do kkk=1,5
7469           do lll=1,3
7470 #ifdef MOMENT
7471             if (iii.eq.1) then
7472               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7473             else
7474               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7475             endif
7476 #endif
7477             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7478      &        auxvec(1))
7479             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7480             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7481      &        auxvec(1))
7482             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7483             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7484      &        pizda(1,1))
7485             vv(1)=pizda(1,1)+pizda(2,2)
7486             vv(2)=pizda(2,1)-pizda(1,2)
7487             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7488 #ifdef MOMENT
7489             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7490 #else
7491             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7492 #endif
7493             if (swap) then
7494               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7495             else
7496               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7497             endif
7498 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7499           enddo
7500         enddo
7501       enddo
7502       return
7503       end
7504 c----------------------------------------------------------------------------
7505       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7506       implicit real*8 (a-h,o-z)
7507       include 'DIMENSIONS'
7508       include 'DIMENSIONS.ZSCOPT'
7509       include 'COMMON.IOUNITS'
7510       include 'COMMON.CHAIN'
7511       include 'COMMON.DERIV'
7512       include 'COMMON.INTERACT'
7513       include 'COMMON.CONTACTS'
7514       include 'COMMON.TORSION'
7515       include 'COMMON.VAR'
7516       include 'COMMON.GEO'
7517       include 'COMMON.FFIELD'
7518       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7519      & auxvec1(2),auxmat1(2,2)
7520       logical swap
7521 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7522 C                                                                              C
7523 C      Parallel       Antiparallel                                             C
7524 C                                                                              C
7525 C          o             o                                                     C
7526 C         /l\   /   \   /j\                                                    C
7527 C        /   \ /     \ /   \                                                   C
7528 C       /| o |o       o| o |\                                                  C
7529 C     \ j|/k\|      \  |/k\|l                                                  C
7530 C      \ /   \       \ /   \                                                   C
7531 C       o     \       o     \                                                  C
7532 C       i             i                                                        C
7533 C                                                                              C
7534 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7535 C
7536 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7537 C           energy moment and not to the cluster cumulant.
7538 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7539       iti=itortyp(itype(i))
7540       itj=itortyp(itype(j))
7541       if (j.lt.nres-1) then
7542         itj1=itortyp(itype(j+1))
7543       else
7544         itj1=ntortyp+1
7545       endif
7546       itk=itortyp(itype(k))
7547       if (k.lt.nres-1) then
7548         itk1=itortyp(itype(k+1))
7549       else
7550         itk1=ntortyp+1
7551       endif
7552       itl=itortyp(itype(l))
7553       if (l.lt.nres-1) then
7554         itl1=itortyp(itype(l+1))
7555       else
7556         itl1=ntortyp+1
7557       endif
7558 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7559 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7560 cd     & ' itl',itl,' itl1',itl1
7561 #ifdef MOMENT
7562       if (imat.eq.1) then
7563         s1=dip(3,jj,i)*dip(3,kk,k)
7564       else
7565         s1=dip(2,jj,j)*dip(2,kk,l)
7566       endif
7567 #endif
7568       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7569       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7570       if (j.eq.l+1) then
7571         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7572         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7573       else
7574         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7575         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7576       endif
7577       call transpose2(EUg(1,1,k),auxmat(1,1))
7578       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7579       vv(1)=pizda(1,1)-pizda(2,2)
7580       vv(2)=pizda(2,1)+pizda(1,2)
7581       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7582 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7583 #ifdef MOMENT
7584       eello6_graph4=-(s1+s2+s3+s4)
7585 #else
7586       eello6_graph4=-(s2+s3+s4)
7587 #endif
7588       if (.not. calc_grad) return
7589 C Derivatives in gamma(i-1)
7590       if (i.gt.1) then
7591 #ifdef MOMENT
7592         if (imat.eq.1) then
7593           s1=dipderg(2,jj,i)*dip(3,kk,k)
7594         else
7595           s1=dipderg(4,jj,j)*dip(2,kk,l)
7596         endif
7597 #endif
7598         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7599         if (j.eq.l+1) then
7600           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7601           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7602         else
7603           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7604           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7605         endif
7606         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7607         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7608 cd          write (2,*) 'turn6 derivatives'
7609 #ifdef MOMENT
7610           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7611 #else
7612           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7613 #endif
7614         else
7615 #ifdef MOMENT
7616           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7617 #else
7618           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7619 #endif
7620         endif
7621       endif
7622 C Derivatives in gamma(k-1)
7623 #ifdef MOMENT
7624       if (imat.eq.1) then
7625         s1=dip(3,jj,i)*dipderg(2,kk,k)
7626       else
7627         s1=dip(2,jj,j)*dipderg(4,kk,l)
7628       endif
7629 #endif
7630       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7631       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7632       if (j.eq.l+1) then
7633         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7634         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7635       else
7636         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7637         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7638       endif
7639       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7640       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7641       vv(1)=pizda(1,1)-pizda(2,2)
7642       vv(2)=pizda(2,1)+pizda(1,2)
7643       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7644       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7645 #ifdef MOMENT
7646         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7647 #else
7648         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7649 #endif
7650       else
7651 #ifdef MOMENT
7652         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7653 #else
7654         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7655 #endif
7656       endif
7657 C Derivatives in gamma(j-1) or gamma(l-1)
7658       if (l.eq.j+1 .and. l.gt.1) then
7659         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7660         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7661         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7662         vv(1)=pizda(1,1)-pizda(2,2)
7663         vv(2)=pizda(2,1)+pizda(1,2)
7664         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7665         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7666       else if (j.gt.1) then
7667         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7668         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7669         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7670         vv(1)=pizda(1,1)-pizda(2,2)
7671         vv(2)=pizda(2,1)+pizda(1,2)
7672         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7673         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7674           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7675         else
7676           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7677         endif
7678       endif
7679 C Cartesian derivatives.
7680       do iii=1,2
7681         do kkk=1,5
7682           do lll=1,3
7683 #ifdef MOMENT
7684             if (iii.eq.1) then
7685               if (imat.eq.1) then
7686                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7687               else
7688                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7689               endif
7690             else
7691               if (imat.eq.1) then
7692                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7693               else
7694                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7695               endif
7696             endif
7697 #endif
7698             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7699      &        auxvec(1))
7700             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7701             if (j.eq.l+1) then
7702               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7703      &          b1(1,itj1),auxvec(1))
7704               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7705             else
7706               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7707      &          b1(1,itl1),auxvec(1))
7708               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7709             endif
7710             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7711      &        pizda(1,1))
7712             vv(1)=pizda(1,1)-pizda(2,2)
7713             vv(2)=pizda(2,1)+pizda(1,2)
7714             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7715             if (swap) then
7716               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7717 #ifdef MOMENT
7718                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7719      &             -(s1+s2+s4)
7720 #else
7721                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7722      &             -(s2+s4)
7723 #endif
7724                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7725               else
7726 #ifdef MOMENT
7727                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7728 #else
7729                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7730 #endif
7731                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7732               endif
7733             else
7734 #ifdef MOMENT
7735               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7736 #else
7737               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7738 #endif
7739               if (l.eq.j+1) then
7740                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7741               else
7742                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7743               endif
7744             endif
7745           enddo
7746         enddo
7747       enddo
7748       return
7749       end
7750 c----------------------------------------------------------------------------
7751       double precision function eello_turn6(i,jj,kk)
7752       implicit real*8 (a-h,o-z)
7753       include 'DIMENSIONS'
7754       include 'DIMENSIONS.ZSCOPT'
7755       include 'COMMON.IOUNITS'
7756       include 'COMMON.CHAIN'
7757       include 'COMMON.DERIV'
7758       include 'COMMON.INTERACT'
7759       include 'COMMON.CONTACTS'
7760       include 'COMMON.TORSION'
7761       include 'COMMON.VAR'
7762       include 'COMMON.GEO'
7763       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7764      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7765      &  ggg1(3),ggg2(3)
7766       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7767      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7768 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7769 C           the respective energy moment and not to the cluster cumulant.
7770       eello_turn6=0.0d0
7771       j=i+4
7772       k=i+1
7773       l=i+3
7774       iti=itortyp(itype(i))
7775       itk=itortyp(itype(k))
7776       itk1=itortyp(itype(k+1))
7777       itl=itortyp(itype(l))
7778       itj=itortyp(itype(j))
7779 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7780 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7781 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7782 cd        eello6=0.0d0
7783 cd        return
7784 cd      endif
7785 cd      write (iout,*)
7786 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7787 cd     &   ' and',k,l
7788 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7789       do iii=1,2
7790         do kkk=1,5
7791           do lll=1,3
7792             derx_turn(lll,kkk,iii)=0.0d0
7793           enddo
7794         enddo
7795       enddo
7796 cd      eij=1.0d0
7797 cd      ekl=1.0d0
7798 cd      ekont=1.0d0
7799       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7800 cd      eello6_5=0.0d0
7801 cd      write (2,*) 'eello6_5',eello6_5
7802 #ifdef MOMENT
7803       call transpose2(AEA(1,1,1),auxmat(1,1))
7804       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7805       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7806       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7807 #else
7808       s1 = 0.0d0
7809 #endif
7810       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7811       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7812       s2 = scalar2(b1(1,itk),vtemp1(1))
7813 #ifdef MOMENT
7814       call transpose2(AEA(1,1,2),atemp(1,1))
7815       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7816       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7817       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7818 #else
7819       s8=0.0d0
7820 #endif
7821       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7822       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7823       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7824 #ifdef MOMENT
7825       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7826       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7827       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7828       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7829       ss13 = scalar2(b1(1,itk),vtemp4(1))
7830       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7831 #else
7832       s13=0.0d0
7833 #endif
7834 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7835 c      s1=0.0d0
7836 c      s2=0.0d0
7837 c      s8=0.0d0
7838 c      s12=0.0d0
7839 c      s13=0.0d0
7840       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7841       if (calc_grad) then
7842 C Derivatives in gamma(i+2)
7843 #ifdef MOMENT
7844       call transpose2(AEA(1,1,1),auxmatd(1,1))
7845       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7847       call transpose2(AEAderg(1,1,2),atempd(1,1))
7848       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7849       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7850 #else
7851       s8d=0.0d0
7852 #endif
7853       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7854       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7855       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7856 c      s1d=0.0d0
7857 c      s2d=0.0d0
7858 c      s8d=0.0d0
7859 c      s12d=0.0d0
7860 c      s13d=0.0d0
7861       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7862 C Derivatives in gamma(i+3)
7863 #ifdef MOMENT
7864       call transpose2(AEA(1,1,1),auxmatd(1,1))
7865       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7866       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7867       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7868 #else
7869       s1d=0.0d0
7870 #endif
7871       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7872       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7873       s2d = scalar2(b1(1,itk),vtemp1d(1))
7874 #ifdef MOMENT
7875       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7876       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7877 #endif
7878       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7879 #ifdef MOMENT
7880       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7881       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7882       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7883 #else
7884       s13d=0.0d0
7885 #endif
7886 c      s1d=0.0d0
7887 c      s2d=0.0d0
7888 c      s8d=0.0d0
7889 c      s12d=0.0d0
7890 c      s13d=0.0d0
7891 #ifdef MOMENT
7892       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7893      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7894 #else
7895       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7896      &               -0.5d0*ekont*(s2d+s12d)
7897 #endif
7898 C Derivatives in gamma(i+4)
7899       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7900       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7901       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7902 #ifdef MOMENT
7903       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7904       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7905       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7906 #else
7907       s13d = 0.0d0
7908 #endif
7909 c      s1d=0.0d0
7910 c      s2d=0.0d0
7911 c      s8d=0.0d0
7912 C      s12d=0.0d0
7913 c      s13d=0.0d0
7914 #ifdef MOMENT
7915       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7916 #else
7917       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7918 #endif
7919 C Derivatives in gamma(i+5)
7920 #ifdef MOMENT
7921       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7922       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7923       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7924 #else
7925       s1d = 0.0d0
7926 #endif
7927       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7928       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7929       s2d = scalar2(b1(1,itk),vtemp1d(1))
7930 #ifdef MOMENT
7931       call transpose2(AEA(1,1,2),atempd(1,1))
7932       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7933       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7934 #else
7935       s8d = 0.0d0
7936 #endif
7937       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7938       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7939 #ifdef MOMENT
7940       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7941       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7942       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7943 #else
7944       s13d = 0.0d0
7945 #endif
7946 c      s1d=0.0d0
7947 c      s2d=0.0d0
7948 c      s8d=0.0d0
7949 c      s12d=0.0d0
7950 c      s13d=0.0d0
7951 #ifdef MOMENT
7952       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7953      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7954 #else
7955       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7956      &               -0.5d0*ekont*(s2d+s12d)
7957 #endif
7958 C Cartesian derivatives
7959       do iii=1,2
7960         do kkk=1,5
7961           do lll=1,3
7962 #ifdef MOMENT
7963             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7964             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7965             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7966 #else
7967             s1d = 0.0d0
7968 #endif
7969             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7970             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7971      &          vtemp1d(1))
7972             s2d = scalar2(b1(1,itk),vtemp1d(1))
7973 #ifdef MOMENT
7974             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7975             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7976             s8d = -(atempd(1,1)+atempd(2,2))*
7977      &           scalar2(cc(1,1,itl),vtemp2(1))
7978 #else
7979             s8d = 0.0d0
7980 #endif
7981             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7982      &           auxmatd(1,1))
7983             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7984             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7985 c      s1d=0.0d0
7986 c      s2d=0.0d0
7987 c      s8d=0.0d0
7988 c      s12d=0.0d0
7989 c      s13d=0.0d0
7990 #ifdef MOMENT
7991             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7992      &        - 0.5d0*(s1d+s2d)
7993 #else
7994             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7995      &        - 0.5d0*s2d
7996 #endif
7997 #ifdef MOMENT
7998             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7999      &        - 0.5d0*(s8d+s12d)
8000 #else
8001             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8002      &        - 0.5d0*s12d
8003 #endif
8004           enddo
8005         enddo
8006       enddo
8007 #ifdef MOMENT
8008       do kkk=1,5
8009         do lll=1,3
8010           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8011      &      achuj_tempd(1,1))
8012           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8013           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8014           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8015           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8016           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8017      &      vtemp4d(1))
8018           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8019           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8020           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8021         enddo
8022       enddo
8023 #endif
8024 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8025 cd     &  16*eel_turn6_num
8026 cd      goto 1112
8027       if (j.lt.nres-1) then
8028         j1=j+1
8029         j2=j-1
8030       else
8031         j1=j-1
8032         j2=j-2
8033       endif
8034       if (l.lt.nres-1) then
8035         l1=l+1
8036         l2=l-1
8037       else
8038         l1=l-1
8039         l2=l-2
8040       endif
8041       do ll=1,3
8042         ggg1(ll)=eel_turn6*g_contij(ll,1)
8043         ggg2(ll)=eel_turn6*g_contij(ll,2)
8044         ghalf=0.5d0*ggg1(ll)
8045 cd        ghalf=0.0d0
8046         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8047      &    +ekont*derx_turn(ll,2,1)
8048         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8049         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8050      &    +ekont*derx_turn(ll,4,1)
8051         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8052         ghalf=0.5d0*ggg2(ll)
8053 cd        ghalf=0.0d0
8054         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8055      &    +ekont*derx_turn(ll,2,2)
8056         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8057         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8058      &    +ekont*derx_turn(ll,4,2)
8059         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8060       enddo
8061 cd      goto 1112
8062       do m=i+1,j-1
8063         do ll=1,3
8064           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8065         enddo
8066       enddo
8067       do m=k+1,l-1
8068         do ll=1,3
8069           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8070         enddo
8071       enddo
8072 1112  continue
8073       do m=i+2,j2
8074         do ll=1,3
8075           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8076         enddo
8077       enddo
8078       do m=k+2,l2
8079         do ll=1,3
8080           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8081         enddo
8082       enddo
8083 cd      do iii=1,nres-3
8084 cd        write (2,*) iii,g_corr6_loc(iii)
8085 cd      enddo
8086       endif
8087       eello_turn6=ekont*eel_turn6
8088 cd      write (2,*) 'ekont',ekont
8089 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8090       return
8091       end
8092 crc-------------------------------------------------
8093       SUBROUTINE MATVEC2(A1,V1,V2)
8094       implicit real*8 (a-h,o-z)
8095       include 'DIMENSIONS'
8096       DIMENSION A1(2,2),V1(2),V2(2)
8097 c      DO 1 I=1,2
8098 c        VI=0.0
8099 c        DO 3 K=1,2
8100 c    3     VI=VI+A1(I,K)*V1(K)
8101 c        Vaux(I)=VI
8102 c    1 CONTINUE
8103
8104       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8105       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8106
8107       v2(1)=vaux1
8108       v2(2)=vaux2
8109       END
8110 C---------------------------------------
8111       SUBROUTINE MATMAT2(A1,A2,A3)
8112       implicit real*8 (a-h,o-z)
8113       include 'DIMENSIONS'
8114       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8115 c      DIMENSION AI3(2,2)
8116 c        DO  J=1,2
8117 c          A3IJ=0.0
8118 c          DO K=1,2
8119 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8120 c          enddo
8121 c          A3(I,J)=A3IJ
8122 c       enddo
8123 c      enddo
8124
8125       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8126       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8127       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8128       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8129
8130       A3(1,1)=AI3_11
8131       A3(2,1)=AI3_21
8132       A3(1,2)=AI3_12
8133       A3(2,2)=AI3_22
8134       END
8135
8136 c-------------------------------------------------------------------------
8137       double precision function scalar2(u,v)
8138       implicit none
8139       double precision u(2),v(2)
8140       double precision sc
8141       integer i
8142       scalar2=u(1)*v(1)+u(2)*v(2)
8143       return
8144       end
8145
8146 C-----------------------------------------------------------------------------
8147
8148       subroutine transpose2(a,at)
8149       implicit none
8150       double precision a(2,2),at(2,2)
8151       at(1,1)=a(1,1)
8152       at(1,2)=a(2,1)
8153       at(2,1)=a(1,2)
8154       at(2,2)=a(2,2)
8155       return
8156       end
8157 c--------------------------------------------------------------------------
8158       subroutine transpose(n,a,at)
8159       implicit none
8160       integer n,i,j
8161       double precision a(n,n),at(n,n)
8162       do i=1,n
8163         do j=1,n
8164           at(j,i)=a(i,j)
8165         enddo
8166       enddo
8167       return
8168       end
8169 C---------------------------------------------------------------------------
8170       subroutine prodmat3(a1,a2,kk,transp,prod)
8171       implicit none
8172       integer i,j
8173       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8174       logical transp
8175 crc      double precision auxmat(2,2),prod_(2,2)
8176
8177       if (transp) then
8178 crc        call transpose2(kk(1,1),auxmat(1,1))
8179 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8180 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8181
8182            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8183      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8184            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8185      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8186            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8187      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8188            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8189      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8190
8191       else
8192 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8193 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8194
8195            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8196      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8197            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8198      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8199            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8200      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8201            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8202      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8203
8204       endif
8205 c      call transpose2(a2(1,1),a2t(1,1))
8206
8207 crc      print *,transp
8208 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8209 crc      print *,((prod(i,j),i=1,2),j=1,2)
8210
8211       return
8212       end
8213 C-----------------------------------------------------------------------------
8214       double precision function scalar(u,v)
8215       implicit none
8216       double precision u(3),v(3)
8217       double precision sc
8218       integer i
8219       sc=0.0d0
8220       do i=1,3
8221         sc=sc+u(i)*v(i)
8222       enddo
8223       scalar=sc
8224       return
8225       end
8226