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) call edfad(edfadis)
 120 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 121       if (wdfa_tor.gt.0) call edfat(edfator)
 122 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 123       if (wdfa_nei.gt.0) call edfan(edfanei)
 124 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 125       if (wdfa_beta.gt.0) call edfab(edfabet)
 126 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 127
 128 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 129 #ifdef SPLITELE
 130       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 131      & +wvdwpp*evdw1
 132      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 133      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 134      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 135      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 136      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 137      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 138      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 139      & +wdfa_beta*edfabet
 140 #else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 142      & +welec*fact(1)*(ees+evdw1)
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 149      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 150      & +wdfa_beta*edfabet
 151 #endif
 152       energia(0)=etot
 153       energia(1)=evdw
 154 #ifdef SCP14
 155       energia(2)=evdw2-evdw2_14
 156       energia(17)=evdw2_14
 157 #else
 158       energia(2)=evdw2
 159       energia(17)=0.0d0
 160 #endif
 161 #ifdef SPLITELE
 162       energia(3)=ees
 163       energia(16)=evdw1
 164 #else
 165       energia(3)=ees+evdw1
 166       energia(16)=0.0d0
 167 #endif
 168       energia(4)=ecorr
 169       energia(5)=ecorr5
 170       energia(6)=ecorr6
 171       energia(7)=eel_loc
 172       energia(8)=eello_turn3
 173       energia(9)=eello_turn4
 174       energia(10)=eturn6
 175       energia(11)=ebe
 176       energia(12)=escloc
 177       energia(13)=etors
 178       energia(14)=etors_d
 179       energia(15)=ehpb
 180       energia(18)=estr
 181       energia(19)=esccor
 182       energia(20)=edihcnstr
 183       energia(21)=evdw_t
 184       energia(22)=ehomology_constr
 185       energia(23)=edfadis
 186       energia(24)=edfator
 187       energia(25)=edfanei
 188       energia(26)=edfabet
 189 c      if (dyn_ss) call dyn_set_nss
 190 c detecting NaNQ
 191 #ifdef ISNAN
 192 #ifdef AIX
 193       if (isnan(etot).ne.0) energia(0)=1.0d+99
 194 #else
 195       if (isnan(etot)) energia(0)=1.0d+99
 196 #endif
 197 #else
 198       i=0
 199 #ifdef WINPGI
 200       idumm=proc_proc(etot,i)
 201 #else
 202       call proc_proc(etot,i)
 203 #endif
 204       if(i.eq.1)energia(0)=1.0d+99
 205 #endif
 206 #ifdef MPL
 207 c     endif
 208 #endif
 209       if (calc_grad) then
 210 C
 211 C Sum up the components of the Cartesian gradient.
 212 C
 213 #ifdef SPLITELE
 214       do i=1,nct
 215         do j=1,3
 216           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 217      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 218      &                wbond*gradb(j,i)+
 219      &                wstrain*ghpbc(j,i)+
 220      &                wcorr*fact(3)*gradcorr(j,i)+
 221      &                wel_loc*fact(2)*gel_loc(j,i)+
 222      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 223      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 224      &                wcorr5*fact(4)*gradcorr5(j,i)+
 225      &                wcorr6*fact(5)*gradcorr6(j,i)+
 226      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 227      &                wsccor*fact(2)*gsccorc(j,i)+
 228      &                wdfa_dist*gdfad(j,i)+
 229      &                wdfa_tor*gdfat(j,i)+
 230      &                wdfa_nei*gdfan(j,i)+
 231      &                wdfa_beta*gdfab(j,i)
 232           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 233      &                  wbond*gradbx(j,i)+
 234      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 235      &                  wsccor*fact(2)*gsccorx(j,i)
 236         enddo
 237 #else
 238       do i=1,nct
 239         do j=1,3
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wcorr*fact(3)*gradcorr(j,i)+
 244      &                wel_loc*fact(2)*gel_loc(j,i)+
 245      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 246      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 247      &                wcorr5*fact(4)*gradcorr5(j,i)+
 248      &                wcorr6*fact(5)*gradcorr6(j,i)+
 249      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 250      &                wsccor*fact(2)*gsccorc(j,i)+
 251      &                wdfa_dist*gdfad(j,i)+
 252      &                wdfa_tor*gdfat(j,i)+
 253      &                wdfa_nei*gdfan(j,i)+
 254      &                wdfa_beta*gdfab(j,i)
 255           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 256      &                  wbond*gradbx(j,i)+
 257      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 258      &                  wsccor*fact(1)*gsccorx(j,i)
 259         enddo
 260 #endif
 261       enddo
 262
 263
 264       do i=1,nres-3
 265         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 266      &   +wcorr5*fact(4)*g_corr5_loc(i)
 267      &   +wcorr6*fact(5)*g_corr6_loc(i)
 268      &   +wturn4*fact(3)*gel_loc_turn4(i)
 269      &   +wturn3*fact(2)*gel_loc_turn3(i)
 270      &   +wturn6*fact(5)*gel_loc_turn6(i)
 271      &   +wel_loc*fact(2)*gel_loc_loc(i)
 272      &   +wsccor*fact(1)*gsccor_loc(i)
 273       enddo
 274       endif
 275       return
 276       end
 277 C------------------------------------------------------------------------
 278       subroutine enerprint(energia,fact)
 279       implicit real*8 (a-h,o-z)
 280       include 'DIMENSIONS'
 281       include 'DIMENSIONS.ZSCOPT'
 282       include 'COMMON.IOUNITS'
 283       include 'COMMON.FFIELD'
 284       include 'COMMON.SBRIDGE'
 285       double precision energia(0:max_ene),fact(6)
 286       etot=energia(0)
 287       evdw=energia(1)+fact(6)*energia(21)
 288 #ifdef SCP14
 289       evdw2=energia(2)+energia(17)
 290 #else
 291       evdw2=energia(2)
 292 #endif
 293       ees=energia(3)
 294 #ifdef SPLITELE
 295       evdw1=energia(16)
 296 #endif
 297       ecorr=energia(4)
 298       ecorr5=energia(5)
 299       ecorr6=energia(6)
 300       eel_loc=energia(7)
 301       eello_turn3=energia(8)
 302       eello_turn4=energia(9)
 303       eello_turn6=energia(10)
 304       ebe=energia(11)
 305       escloc=energia(12)
 306       etors=energia(13)
 307       etors_d=energia(14)
 308       ehpb=energia(15)
 309       esccor=energia(19)
 310       edihcnstr=energia(20)
 311       estr=energia(18)
 312       ehomology_constr=energia(22)
 313       edfadis=energia(23)
 314       edfator=energia(24)
 315       edfanei=energia(25)
 316       edfabet=energia(26)
 317 #ifdef SPLITELE
 318       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 319      &  wvdwpp,
 320      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 321      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 322      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 323      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 324      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 325      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 326      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 327      &  wdfa_beta,etot
 328    10 format (/'Virtual-chain energies:'//
 329      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 330      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 331      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 332      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 333      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 334      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 335      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 336      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 337      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 338      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 339      & ' (SS bridges & dist. cnstr.)'/
 340      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 343      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 344      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 345      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 346      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 347      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 348      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 349      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 350      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 351      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 352      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 353      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 354      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 355      & 'ETOT=  ',1pE16.6,' (total)')
 356 #else
 357       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 358      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 359      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 360      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 361      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 362      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 363      &  edihcnstr,ehomology_constr,ebr*nss,
 364      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 365      &  wdfa_beta,etot
 366    10 format (/'Virtual-chain energies:'//
 367      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 368      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 369      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 370      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 371      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 372      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 373      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 374      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 375      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 376      & ' (SS bridges & dist. cnstr.)'/
 377      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 380      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 381      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 382      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 383      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 384      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 385      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 386      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 387      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 388      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 389      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 390      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 391      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 392      & 'ETOT=  ',1pE16.6,' (total)')
 393 #endif
 394       return
 395       end
 396 C-----------------------------------------------------------------------
 397       subroutine elj(evdw,evdw_t)
 398 C
 399 C This subroutine calculates the interaction energy of nonbonded side chains
 400 C assuming the LJ potential of interaction.
 401 C
 402       implicit real*8 (a-h,o-z)
 403       include 'DIMENSIONS'
 404       include 'DIMENSIONS.ZSCOPT'
 405       include "DIMENSIONS.COMPAR"
 406       parameter (accur=1.0d-10)
 407       include 'COMMON.GEO'
 408       include 'COMMON.VAR'
 409       include 'COMMON.LOCAL'
 410       include 'COMMON.CHAIN'
 411       include 'COMMON.DERIV'
 412       include 'COMMON.INTERACT'
 413       include 'COMMON.TORSION'
 414       include 'COMMON.ENEPS'
 415       include 'COMMON.SBRIDGE'
 416       include 'COMMON.NAMES'
 417       include 'COMMON.IOUNITS'
 418       include 'COMMON.CONTACTS'
 419       dimension gg(3)
 420       integer icant
 421       external icant
 422 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 423       do i=1,210
 424         do j=1,2
 425           eneps_temp(j,i)=0.0d0
 426         enddo
 427       enddo
 428       evdw=0.0D0
 429       evdw_t=0.0d0
 430       do i=iatsc_s,iatsc_e
 431         itypi=itype(i)
 432         itypi1=itype(i+1)
 433         xi=c(1,nres+i)
 434         yi=c(2,nres+i)
 435         zi=c(3,nres+i)
 436 C Change 12/1/95
 437         num_conti=0
 438 C
 439 C Calculate SC interaction energy.
 440 C
 441         do iint=1,nint_gr(i)
 442 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 443 cd   &                  'iend=',iend(i,iint)
 444           do j=istart(i,iint),iend(i,iint)
 445             itypj=itype(j)
 446             xj=c(1,nres+j)-xi
 447             yj=c(2,nres+j)-yi
 448             zj=c(3,nres+j)-zi
 449 C Change 12/1/95 to calculate four-body interactions
 450             rij=xj*xj+yj*yj+zj*zj
 451             rrij=1.0D0/rij
 452 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 453             eps0ij=eps(itypi,itypj)
 454             fac=rrij**expon2
 455             e1=fac*fac*aa(itypi,itypj)
 456             e2=fac*bb(itypi,itypj)
 457             evdwij=e1+e2
 458             ij=icant(itypi,itypj)
 459             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 460             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 461 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 462 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 463 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 464 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 465 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 466 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 467             if (bb(itypi,itypj).gt.0.0d0) then
 468               evdw=evdw+evdwij
 469             else
 470               evdw_t=evdw_t+evdwij
 471             endif
 472             if (calc_grad) then
 473 C
 474 C Calculate the components of the gradient in DC and X
 475 C
 476             fac=-rrij*(e1+evdwij)
 477             gg(1)=xj*fac
 478             gg(2)=yj*fac
 479             gg(3)=zj*fac
 480             do k=1,3
 481               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 482               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 483             enddo
 484             do k=i,j-1
 485               do l=1,3
 486                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 487               enddo
 488             enddo
 489             endif
 490 C
 491 C 12/1/95, revised on 5/20/97
 492 C
 493 C Calculate the contact function. The ith column of the array JCONT will
 494 C contain the numbers of atoms that make contacts with the atom I (of numbers
 495 C greater than I). The arrays FACONT and GACONT will contain the values of
 496 C the contact function and its derivative.
 497 C
 498 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 499 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 500 C Uncomment next line, if the correlation interactions are contact function only
 501             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 502               rij=dsqrt(rij)
 503               sigij=sigma(itypi,itypj)
 504               r0ij=rs0(itypi,itypj)
 505 C
 506 C Check whether the SC's are not too far to make a contact.
 507 C
 508               rcut=1.5d0*r0ij
 509               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 510 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 511 C
 512               if (fcont.gt.0.0D0) then
 513 C If the SC-SC distance if close to sigma, apply spline.
 514 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 515 cAdam &             fcont1,fprimcont1)
 516 cAdam           fcont1=1.0d0-fcont1
 517 cAdam           if (fcont1.gt.0.0d0) then
 518 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 519 cAdam             fcont=fcont*fcont1
 520 cAdam           endif
 521 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 522 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 523 cga             do k=1,3
 524 cga               gg(k)=gg(k)*eps0ij
 525 cga             enddo
 526 cga             eps0ij=-evdwij*eps0ij
 527 C Uncomment for AL's type of SC correlation interactions.
 528 cadam           eps0ij=-evdwij
 529                 num_conti=num_conti+1
 530                 jcont(num_conti,i)=j
 531                 facont(num_conti,i)=fcont*eps0ij
 532                 fprimcont=eps0ij*fprimcont/rij
 533                 fcont=expon*fcont
 534 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 535 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 536 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 537 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 538                 gacont(1,num_conti,i)=-fprimcont*xj
 539                 gacont(2,num_conti,i)=-fprimcont*yj
 540                 gacont(3,num_conti,i)=-fprimcont*zj
 541 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 542 cd              write (iout,'(2i3,3f10.5)')
 543 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 544               endif
 545             endif
 546           enddo      ! j
 547         enddo        ! iint
 548 C Change 12/1/95
 549         num_cont(i)=num_conti
 550       enddo          ! i
 551       if (calc_grad) then
 552       do i=1,nct
 553         do j=1,3
 554           gvdwc(j,i)=expon*gvdwc(j,i)
 555           gvdwx(j,i)=expon*gvdwx(j,i)
 556         enddo
 557       enddo
 558       endif
 559 C******************************************************************************
 560 C
 561 C                              N O T E !!!
 562 C
 563 C To save time, the factor of EXPON has been extracted from ALL components
 564 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 565 C use!
 566 C
 567 C******************************************************************************
 568       return
 569       end
 570 C-----------------------------------------------------------------------------
 571       subroutine eljk(evdw,evdw_t)
 572 C
 573 C This subroutine calculates the interaction energy of nonbonded side chains
 574 C assuming the LJK potential of interaction.
 575 C
 576       implicit real*8 (a-h,o-z)
 577       include 'DIMENSIONS'
 578       include 'DIMENSIONS.ZSCOPT'
 579       include "DIMENSIONS.COMPAR"
 580       include 'COMMON.GEO'
 581       include 'COMMON.VAR'
 582       include 'COMMON.LOCAL'
 583       include 'COMMON.CHAIN'
 584       include 'COMMON.DERIV'
 585       include 'COMMON.INTERACT'
 586       include 'COMMON.ENEPS'
 587       include 'COMMON.IOUNITS'
 588       include 'COMMON.NAMES'
 589       dimension gg(3)
 590       logical scheck
 591       integer icant
 592       external icant
 593 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 594       do i=1,210
 595         do j=1,2
 596           eneps_temp(j,i)=0.0d0
 597         enddo
 598       enddo
 599       evdw=0.0D0
 600       evdw_t=0.0d0
 601       do i=iatsc_s,iatsc_e
 602         itypi=itype(i)
 603         itypi1=itype(i+1)
 604         xi=c(1,nres+i)
 605         yi=c(2,nres+i)
 606         zi=c(3,nres+i)
 607 C
 608 C Calculate SC interaction energy.
 609 C
 610         do iint=1,nint_gr(i)
 611           do j=istart(i,iint),iend(i,iint)
 612             itypj=itype(j)
 613             xj=c(1,nres+j)-xi
 614             yj=c(2,nres+j)-yi
 615             zj=c(3,nres+j)-zi
 616             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 617             fac_augm=rrij**expon
 618             e_augm=augm(itypi,itypj)*fac_augm
 619             r_inv_ij=dsqrt(rrij)
 620             rij=1.0D0/r_inv_ij
 621             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 622             fac=r_shift_inv**expon
 623             e1=fac*fac*aa(itypi,itypj)
 624             e2=fac*bb(itypi,itypj)
 625             evdwij=e_augm+e1+e2
 626             ij=icant(itypi,itypj)
 627             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 628      &        /dabs(eps(itypi,itypj))
 629             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 630 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 631 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 632 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 633 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 634 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 635 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 636 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 637             if (bb(itypi,itypj).gt.0.0d0) then
 638               evdw=evdw+evdwij
 639             else
 640               evdw_t=evdw_t+evdwij
 641             endif
 642             if (calc_grad) then
 643 C
 644 C Calculate the components of the gradient in DC and X
 645 C
 646             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 647             gg(1)=xj*fac
 648             gg(2)=yj*fac
 649             gg(3)=zj*fac
 650             do k=1,3
 651               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 652               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 653             enddo
 654             do k=i,j-1
 655               do l=1,3
 656                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 657               enddo
 658             enddo
 659             endif
 660           enddo      ! j
 661         enddo        ! iint
 662       enddo          ! i
 663       if (calc_grad) then
 664       do i=1,nct
 665         do j=1,3
 666           gvdwc(j,i)=expon*gvdwc(j,i)
 667           gvdwx(j,i)=expon*gvdwx(j,i)
 668         enddo
 669       enddo
 670       endif
 671       return
 672       end
 673 C-----------------------------------------------------------------------------
 674       subroutine ebp(evdw,evdw_t)
 675 C
 676 C This subroutine calculates the interaction energy of nonbonded side chains
 677 C assuming the Berne-Pechukas potential of interaction.
 678 C
 679       implicit real*8 (a-h,o-z)
 680       include 'DIMENSIONS'
 681       include 'DIMENSIONS.ZSCOPT'
 682       include "DIMENSIONS.COMPAR"
 683       include 'COMMON.GEO'
 684       include 'COMMON.VAR'
 685       include 'COMMON.LOCAL'
 686       include 'COMMON.CHAIN'
 687       include 'COMMON.DERIV'
 688       include 'COMMON.NAMES'
 689       include 'COMMON.INTERACT'
 690       include 'COMMON.ENEPS'
 691       include 'COMMON.IOUNITS'
 692       include 'COMMON.CALC'
 693       common /srutu/ icall
 694 c     double precision rrsave(maxdim)
 695       logical lprn
 696       integer icant
 697       external icant
 698       do i=1,210
 699         do j=1,2
 700           eneps_temp(j,i)=0.0d0
 701         enddo
 702       enddo
 703       evdw=0.0D0
 704       evdw_t=0.0d0
 705 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 706 c     if (icall.eq.0) then
 707 c       lprn=.true.
 708 c     else
 709         lprn=.false.
 710 c     endif
 711       ind=0
 712       do i=iatsc_s,iatsc_e
 713         itypi=itype(i)
 714         itypi1=itype(i+1)
 715         xi=c(1,nres+i)
 716         yi=c(2,nres+i)
 717         zi=c(3,nres+i)
 718         dxi=dc_norm(1,nres+i)
 719         dyi=dc_norm(2,nres+i)
 720         dzi=dc_norm(3,nres+i)
 721         dsci_inv=vbld_inv(i+nres)
 722 C
 723 C Calculate SC interaction energy.
 724 C
 725         do iint=1,nint_gr(i)
 726           do j=istart(i,iint),iend(i,iint)
 727             ind=ind+1
 728             itypj=itype(j)
 729             dscj_inv=vbld_inv(j+nres)
 730             chi1=chi(itypi,itypj)
 731             chi2=chi(itypj,itypi)
 732             chi12=chi1*chi2
 733             chip1=chip(itypi)
 734             chip2=chip(itypj)
 735             chip12=chip1*chip2
 736             alf1=alp(itypi)
 737             alf2=alp(itypj)
 738             alf12=0.5D0*(alf1+alf2)
 739 C For diagnostics only!!!
 740 c           chi1=0.0D0
 741 c           chi2=0.0D0
 742 c           chi12=0.0D0
 743 c           chip1=0.0D0
 744 c           chip2=0.0D0
 745 c           chip12=0.0D0
 746 c           alf1=0.0D0
 747 c           alf2=0.0D0
 748 c           alf12=0.0D0
 749             xj=c(1,nres+j)-xi
 750             yj=c(2,nres+j)-yi
 751             zj=c(3,nres+j)-zi
 752             dxj=dc_norm(1,nres+j)
 753             dyj=dc_norm(2,nres+j)
 754             dzj=dc_norm(3,nres+j)
 755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 756 cd          if (icall.eq.0) then
 757 cd            rrsave(ind)=rrij
 758 cd          else
 759 cd            rrij=rrsave(ind)
 760 cd          endif
 761             rij=dsqrt(rrij)
 762 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 763             call sc_angular
 764 C Calculate whole angle-dependent part of epsilon and contributions
 765 C to its derivatives
 766             fac=(rrij*sigsq)**expon2
 767             e1=fac*fac*aa(itypi,itypj)
 768             e2=fac*bb(itypi,itypj)
 769             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 770             eps2der=evdwij*eps3rt
 771             eps3der=evdwij*eps2rt
 772             evdwij=evdwij*eps2rt*eps3rt
 773             ij=icant(itypi,itypj)
 774             aux=eps1*eps2rt**2*eps3rt**2
 775             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 776      &        /dabs(eps(itypi,itypj))
 777             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 778             if (bb(itypi,itypj).gt.0.0d0) then
 779               evdw=evdw+evdwij
 780             else
 781               evdw_t=evdw_t+evdwij
 782             endif
 783             if (calc_grad) then
 784             if (lprn) then
 785             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 786             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 787 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 788 cd     &        restyp(itypi),i,restyp(itypj),j,
 789 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 790 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 791 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 792 cd     &        evdwij
 793             endif
 794 C Calculate gradient components.
 795             e1=e1*eps1*eps2rt**2*eps3rt**2
 796             fac=-expon*(e1+evdwij)
 797             sigder=fac/sigsq
 798             fac=rrij*fac
 799 C Calculate radial part of the gradient
 800             gg(1)=xj*fac
 801             gg(2)=yj*fac
 802             gg(3)=zj*fac
 803 C Calculate the angular part of the gradient and sum add the contributions
 804 C to the appropriate components of the Cartesian gradient.
 805             call sc_grad
 806             endif
 807           enddo      ! j
 808         enddo        ! iint
 809       enddo          ! i
 810 c     stop
 811       return
 812       end
 813 C-----------------------------------------------------------------------------
 814       subroutine egb(evdw,evdw_t)
 815 C
 816 C This subroutine calculates the interaction energy of nonbonded side chains
 817 C assuming the Gay-Berne potential of interaction.
 818 C
 819       implicit real*8 (a-h,o-z)
 820       include 'DIMENSIONS'
 821       include 'DIMENSIONS.ZSCOPT'
 822       include "DIMENSIONS.COMPAR"
 823       include 'COMMON.GEO'
 824       include 'COMMON.VAR'
 825       include 'COMMON.LOCAL'
 826       include 'COMMON.CHAIN'
 827       include 'COMMON.DERIV'
 828       include 'COMMON.NAMES'
 829       include 'COMMON.INTERACT'
 830       include 'COMMON.ENEPS'
 831       include 'COMMON.IOUNITS'
 832       include 'COMMON.CALC'
 833       include 'COMMON.SBRIDGE'
 834       logical lprn
 835       common /srutu/icall
 836       integer icant
 837       external icant
 838       do i=1,210
 839         do j=1,2
 840           eneps_temp(j,i)=0.0d0
 841         enddo
 842       enddo
 843 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 844       evdw=0.0D0
 845       evdw_t=0.0d0
 846       lprn=.false.
 847 c      if (icall.gt.0) lprn=.true.
 848       ind=0
 849       do i=iatsc_s,iatsc_e
 850         itypi=itype(i)
 851         itypi1=itype(i+1)
 852         xi=c(1,nres+i)
 853         yi=c(2,nres+i)
 854         zi=c(3,nres+i)
 855         dxi=dc_norm(1,nres+i)
 856         dyi=dc_norm(2,nres+i)
 857         dzi=dc_norm(3,nres+i)
 858         dsci_inv=vbld_inv(i+nres)
 859 C
 860 C Calculate SC interaction energy.
 861 C
 862         do iint=1,nint_gr(i)
 863           do j=istart(i,iint),iend(i,iint)
 864 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 865 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 866 C formation no electrostatic interactions should be calculated. If it
 867 C would be allowed NaN would appear
 868             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 869 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 870 C residue can or cannot form disulfide bond. There is still bug allowing
 871 C Cys...Cys...Cys bond formation
 872               call dyn_ssbond_ene(i,j,evdwij)
 873 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 874 C function in ssMD.F
 875               evdw=evdw+evdwij
 876 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 877 c     &                        'evdw',i,j,evdwij,' ss'
 878             ELSE
 879             ind=ind+1
 880             itypj=itype(j)
 881             dscj_inv=vbld_inv(j+nres)
 882             sig0ij=sigma(itypi,itypj)
 883             chi1=chi(itypi,itypj)
 884             chi2=chi(itypj,itypi)
 885             chi12=chi1*chi2
 886             chip1=chip(itypi)
 887             chip2=chip(itypj)
 888             chip12=chip1*chip2
 889             alf1=alp(itypi)
 890             alf2=alp(itypj)
 891             alf12=0.5D0*(alf1+alf2)
 892 C For diagnostics only!!!
 893 c           chi1=0.0D0
 894 c           chi2=0.0D0
 895 c           chi12=0.0D0
 896 c           chip1=0.0D0
 897 c           chip2=0.0D0
 898 c           chip12=0.0D0
 899 c           alf1=0.0D0
 900 c           alf2=0.0D0
 901 c           alf12=0.0D0
 902             xj=c(1,nres+j)-xi
 903             yj=c(2,nres+j)-yi
 904             zj=c(3,nres+j)-zi
 905             dxj=dc_norm(1,nres+j)
 906             dyj=dc_norm(2,nres+j)
 907             dzj=dc_norm(3,nres+j)
 908 c            write (iout,*) i,j,xj,yj,zj
 909             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 910             rij=dsqrt(rrij)
 911 C Calculate angle-dependent terms of energy and contributions to their
 912 C derivatives.
 913             call sc_angular
 914             sigsq=1.0D0/sigsq
 915             sig=sig0ij*dsqrt(sigsq)
 916             rij_shift=1.0D0/rij-sig+sig0ij
 917 C I hate to put IF's in the loops, but here don't have another choice!!!!
 918             if (rij_shift.le.0.0D0) then
 919               evdw=1.0D20
 920               return
 921             endif
 922             sigder=-sig*sigsq
 923 c---------------------------------------------------------------
 924             rij_shift=1.0D0/rij_shift
 925             fac=rij_shift**expon
 926             e1=fac*fac*aa(itypi,itypj)
 927             e2=fac*bb(itypi,itypj)
 928             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 929             eps2der=evdwij*eps3rt
 930             eps3der=evdwij*eps2rt
 931             evdwij=evdwij*eps2rt*eps3rt
 932             if (bb(itypi,itypj).gt.0) then
 933               evdw=evdw+evdwij
 934             else
 935               evdw_t=evdw_t+evdwij
 936             endif
 937             ij=icant(itypi,itypj)
 938             aux=eps1*eps2rt**2*eps3rt**2
 939             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 940      &        /dabs(eps(itypi,itypj))
 941             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 942 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 943 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 944 c     &         aux*e2/eps(itypi,itypj)
 945 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 946             if (lprn) then
 947             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 948             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 949             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 950      &        restyp(itypi),i,restyp(itypj),j,
 951      &        epsi,sigm,chi1,chi2,chip1,chip2,
 952      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 953      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 954      &        evdwij
 955             endif
 956             if (calc_grad) then
 957 C Calculate gradient components.
 958             e1=e1*eps1*eps2rt**2*eps3rt**2
 959             fac=-expon*(e1+evdwij)*rij_shift
 960             sigder=fac*sigder
 961             fac=rij*fac
 962 C Calculate the radial part of the gradient
 963             gg(1)=xj*fac
 964             gg(2)=yj*fac
 965             gg(3)=zj*fac
 966 C Calculate angular part of the gradient.
 967             call sc_grad
 968             endif
 969             ENDIF    ! dyn_ss
 970           enddo      ! j
 971         enddo        ! iint
 972       enddo          ! i
 973       return
 974       end
 975 C-----------------------------------------------------------------------------
 976       subroutine egbv(evdw,evdw_t)
 977 C
 978 C This subroutine calculates the interaction energy of nonbonded side chains
 979 C assuming the Gay-Berne-Vorobjev potential of interaction.
 980 C
 981       implicit real*8 (a-h,o-z)
 982       include 'DIMENSIONS'
 983       include 'DIMENSIONS.ZSCOPT'
 984       include "DIMENSIONS.COMPAR"
 985       include 'COMMON.GEO'
 986       include 'COMMON.VAR'
 987       include 'COMMON.LOCAL'
 988       include 'COMMON.CHAIN'
 989       include 'COMMON.DERIV'
 990       include 'COMMON.NAMES'
 991       include 'COMMON.INTERACT'
 992       include 'COMMON.ENEPS'
 993       include 'COMMON.IOUNITS'
 994       include 'COMMON.CALC'
 995       common /srutu/ icall
 996       logical lprn
 997       integer icant
 998       external icant
 999       do i=1,210
1000         do j=1,2
1001           eneps_temp(j,i)=0.0d0
1002         enddo
1003       enddo
1004       evdw=0.0D0
1005       evdw_t=0.0d0
1006 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1007       evdw=0.0D0
1008       lprn=.false.
1009 c      if (icall.gt.0) lprn=.true.
1010       ind=0
1011       do i=iatsc_s,iatsc_e
1012         itypi=itype(i)
1013         itypi1=itype(i+1)
1014         xi=c(1,nres+i)
1015         yi=c(2,nres+i)
1016         zi=c(3,nres+i)
1017         dxi=dc_norm(1,nres+i)
1018         dyi=dc_norm(2,nres+i)
1019         dzi=dc_norm(3,nres+i)
1020         dsci_inv=vbld_inv(i+nres)
1021 C
1022 C Calculate SC interaction energy.
1023 C
1024         do iint=1,nint_gr(i)
1025           do j=istart(i,iint),iend(i,iint)
1026             ind=ind+1
1027             itypj=itype(j)
1028             dscj_inv=vbld_inv(j+nres)
1029             sig0ij=sigma(itypi,itypj)
1030             r0ij=r0(itypi,itypj)
1031             chi1=chi(itypi,itypj)
1032             chi2=chi(itypj,itypi)
1033             chi12=chi1*chi2
1034             chip1=chip(itypi)
1035             chip2=chip(itypj)
1036             chip12=chip1*chip2
1037             alf1=alp(itypi)
1038             alf2=alp(itypj)
1039             alf12=0.5D0*(alf1+alf2)
1040 C For diagnostics only!!!
1041 c           chi1=0.0D0
1042 c           chi2=0.0D0
1043 c           chi12=0.0D0
1044 c           chip1=0.0D0
1045 c           chip2=0.0D0
1046 c           chip12=0.0D0
1047 c           alf1=0.0D0
1048 c           alf2=0.0D0
1049 c           alf12=0.0D0
1050             xj=c(1,nres+j)-xi
1051             yj=c(2,nres+j)-yi
1052             zj=c(3,nres+j)-zi
1053             dxj=dc_norm(1,nres+j)
1054             dyj=dc_norm(2,nres+j)
1055             dzj=dc_norm(3,nres+j)
1056             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1057             rij=dsqrt(rrij)
1058 C Calculate angle-dependent terms of energy and contributions to their
1059 C derivatives.
1060             call sc_angular
1061             sigsq=1.0D0/sigsq
1062             sig=sig0ij*dsqrt(sigsq)
1063             rij_shift=1.0D0/rij-sig+r0ij
1064 C I hate to put IF's in the loops, but here don't have another choice!!!!
1065             if (rij_shift.le.0.0D0) then
1066               evdw=1.0D20
1067               return
1068             endif
1069             sigder=-sig*sigsq
1070 c---------------------------------------------------------------
1071             rij_shift=1.0D0/rij_shift
1072             fac=rij_shift**expon
1073             e1=fac*fac*aa(itypi,itypj)
1074             e2=fac*bb(itypi,itypj)
1075             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1076             eps2der=evdwij*eps3rt
1077             eps3der=evdwij*eps2rt
1078             fac_augm=rrij**expon
1079             e_augm=augm(itypi,itypj)*fac_augm
1080             evdwij=evdwij*eps2rt*eps3rt
1081             if (bb(itypi,itypj).gt.0.0d0) then
1082               evdw=evdw+evdwij+e_augm
1083             else
1084               evdw_t=evdw_t+evdwij+e_augm
1085             endif
1086             ij=icant(itypi,itypj)
1087             aux=eps1*eps2rt**2*eps3rt**2
1088             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1089      &        /dabs(eps(itypi,itypj))
1090             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1091 c            eneps_temp(ij)=eneps_temp(ij)
1092 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1093 c            if (lprn) then
1094 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1097 c     &        restyp(itypi),i,restyp(itypj),j,
1098 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1099 c     &        chi1,chi2,chip1,chip2,
1100 c     &        eps1,eps2rt**2,eps3rt**2,
1101 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1102 c     &        evdwij+e_augm
1103 c            endif
1104             if (calc_grad) then
1105 C Calculate gradient components.
1106             e1=e1*eps1*eps2rt**2*eps3rt**2
1107             fac=-expon*(e1+evdwij)*rij_shift
1108             sigder=fac*sigder
1109             fac=rij*fac-2*expon*rrij*e_augm
1110 C Calculate the radial part of the gradient
1111             gg(1)=xj*fac
1112             gg(2)=yj*fac
1113             gg(3)=zj*fac
1114 C Calculate angular part of the gradient.
1115             call sc_grad
1116             endif
1117           enddo      ! j
1118         enddo        ! iint
1119       enddo          ! i
1120       return
1121       end
1122 C-----------------------------------------------------------------------------
1123       subroutine sc_angular
1124 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1125 C om12. Called by ebp, egb, and egbv.
1126       implicit none
1127       include 'COMMON.CALC'
1128       erij(1)=xj*rij
1129       erij(2)=yj*rij
1130       erij(3)=zj*rij
1131       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1132       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1133       om12=dxi*dxj+dyi*dyj+dzi*dzj
1134       chiom12=chi12*om12
1135 C Calculate eps1(om12) and its derivative in om12
1136       faceps1=1.0D0-om12*chiom12
1137       faceps1_inv=1.0D0/faceps1
1138       eps1=dsqrt(faceps1_inv)
1139 C Following variable is eps1*deps1/dom12
1140       eps1_om12=faceps1_inv*chiom12
1141 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1142 C and om12.
1143       om1om2=om1*om2
1144       chiom1=chi1*om1
1145       chiom2=chi2*om2
1146       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1147       sigsq=1.0D0-facsig*faceps1_inv
1148       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1149       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1150       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1151 C Calculate eps2 and its derivatives in om1, om2, and om12.
1152       chipom1=chip1*om1
1153       chipom2=chip2*om2
1154       chipom12=chip12*om12
1155       facp=1.0D0-om12*chipom12
1156       facp_inv=1.0D0/facp
1157       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1158 C Following variable is the square root of eps2
1159       eps2rt=1.0D0-facp1*facp_inv
1160 C Following three variables are the derivatives of the square root of eps
1161 C in om1, om2, and om12.
1162       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1163       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1164       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1165 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1166       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1167 C Calculate whole angle-dependent part of epsilon and contributions
1168 C to its derivatives
1169       return
1170       end
1171 C----------------------------------------------------------------------------
1172       subroutine sc_grad
1173       implicit real*8 (a-h,o-z)
1174       include 'DIMENSIONS'
1175       include 'DIMENSIONS.ZSCOPT'
1176       include 'COMMON.CHAIN'
1177       include 'COMMON.DERIV'
1178       include 'COMMON.CALC'
1179       double precision dcosom1(3),dcosom2(3)
1180       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1181       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1182       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1183      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1184       do k=1,3
1185         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1186         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1187       enddo
1188       do k=1,3
1189         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1190       enddo
1191       do k=1,3
1192         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1194      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1195         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1197      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1198       enddo
1199 C
1200 C Calculate the components of the gradient in DC and X
1201 C
1202       do k=i,j-1
1203         do l=1,3
1204           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1205         enddo
1206       enddo
1207       return
1208       end
1209 c------------------------------------------------------------------------------
1210       subroutine vec_and_deriv
1211       implicit real*8 (a-h,o-z)
1212       include 'DIMENSIONS'
1213       include 'DIMENSIONS.ZSCOPT'
1214       include 'COMMON.IOUNITS'
1215       include 'COMMON.GEO'
1216       include 'COMMON.VAR'
1217       include 'COMMON.LOCAL'
1218       include 'COMMON.CHAIN'
1219       include 'COMMON.VECTORS'
1220       include 'COMMON.DERIV'
1221       include 'COMMON.INTERACT'
1222       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1223 C Compute the local reference systems. For reference system (i), the
1224 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1225 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1226       do i=1,nres-1
1227 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1228           if (i.eq.nres-1) then
1229 C Case of the last full residue
1230 C Compute the Z-axis
1231             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1232             costh=dcos(pi-theta(nres))
1233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1234             do k=1,3
1235               uz(k,i)=fac*uz(k,i)
1236             enddo
1237             if (calc_grad) then
1238 C Compute the derivatives of uz
1239             uzder(1,1,1)= 0.0d0
1240             uzder(2,1,1)=-dc_norm(3,i-1)
1241             uzder(3,1,1)= dc_norm(2,i-1)
1242             uzder(1,2,1)= dc_norm(3,i-1)
1243             uzder(2,2,1)= 0.0d0
1244             uzder(3,2,1)=-dc_norm(1,i-1)
1245             uzder(1,3,1)=-dc_norm(2,i-1)
1246             uzder(2,3,1)= dc_norm(1,i-1)
1247             uzder(3,3,1)= 0.0d0
1248             uzder(1,1,2)= 0.0d0
1249             uzder(2,1,2)= dc_norm(3,i)
1250             uzder(3,1,2)=-dc_norm(2,i)
1251             uzder(1,2,2)=-dc_norm(3,i)
1252             uzder(2,2,2)= 0.0d0
1253             uzder(3,2,2)= dc_norm(1,i)
1254             uzder(1,3,2)= dc_norm(2,i)
1255             uzder(2,3,2)=-dc_norm(1,i)
1256             uzder(3,3,2)= 0.0d0
1257             endif
1258 C Compute the Y-axis
1259             facy=fac
1260             do k=1,3
1261               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1262             enddo
1263             if (calc_grad) then
1264 C Compute the derivatives of uy
1265             do j=1,3
1266               do k=1,3
1267                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1268      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1269                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1270               enddo
1271               uyder(j,j,1)=uyder(j,j,1)-costh
1272               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1273             enddo
1274             do j=1,2
1275               do k=1,3
1276                 do l=1,3
1277                   uygrad(l,k,j,i)=uyder(l,k,j)
1278                   uzgrad(l,k,j,i)=uzder(l,k,j)
1279                 enddo
1280               enddo
1281             enddo
1282             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1283             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1284             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1285             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1286             endif
1287           else
1288 C Other residues
1289 C Compute the Z-axis
1290             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1291             costh=dcos(pi-theta(i+2))
1292             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1293             do k=1,3
1294               uz(k,i)=fac*uz(k,i)
1295             enddo
1296             if (calc_grad) then
1297 C Compute the derivatives of uz
1298             uzder(1,1,1)= 0.0d0
1299             uzder(2,1,1)=-dc_norm(3,i+1)
1300             uzder(3,1,1)= dc_norm(2,i+1)
1301             uzder(1,2,1)= dc_norm(3,i+1)
1302             uzder(2,2,1)= 0.0d0
1303             uzder(3,2,1)=-dc_norm(1,i+1)
1304             uzder(1,3,1)=-dc_norm(2,i+1)
1305             uzder(2,3,1)= dc_norm(1,i+1)
1306             uzder(3,3,1)= 0.0d0
1307             uzder(1,1,2)= 0.0d0
1308             uzder(2,1,2)= dc_norm(3,i)
1309             uzder(3,1,2)=-dc_norm(2,i)
1310             uzder(1,2,2)=-dc_norm(3,i)
1311             uzder(2,2,2)= 0.0d0
1312             uzder(3,2,2)= dc_norm(1,i)
1313             uzder(1,3,2)= dc_norm(2,i)
1314             uzder(2,3,2)=-dc_norm(1,i)
1315             uzder(3,3,2)= 0.0d0
1316             endif
1317 C Compute the Y-axis
1318             facy=fac
1319             do k=1,3
1320               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1321             enddo
1322             if (calc_grad) then
1323 C Compute the derivatives of uy
1324             do j=1,3
1325               do k=1,3
1326                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1327      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1328                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1329               enddo
1330               uyder(j,j,1)=uyder(j,j,1)-costh
1331               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1332             enddo
1333             do j=1,2
1334               do k=1,3
1335                 do l=1,3
1336                   uygrad(l,k,j,i)=uyder(l,k,j)
1337                   uzgrad(l,k,j,i)=uzder(l,k,j)
1338                 enddo
1339               enddo
1340             enddo
1341             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1342             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1343             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1344             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1345           endif
1346           endif
1347       enddo
1348       if (calc_grad) then
1349       do i=1,nres-1
1350         vbld_inv_temp(1)=vbld_inv(i+1)
1351         if (i.lt.nres-1) then
1352           vbld_inv_temp(2)=vbld_inv(i+2)
1353         else
1354           vbld_inv_temp(2)=vbld_inv(i)
1355         endif
1356         do j=1,2
1357           do k=1,3
1358             do l=1,3
1359               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1360               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1361             enddo
1362           enddo
1363         enddo
1364       enddo
1365       endif
1366       return
1367       end
1368 C-----------------------------------------------------------------------------
1369       subroutine vec_and_deriv_test
1370       implicit real*8 (a-h,o-z)
1371       include 'DIMENSIONS'
1372       include 'DIMENSIONS.ZSCOPT'
1373       include 'COMMON.IOUNITS'
1374       include 'COMMON.GEO'
1375       include 'COMMON.VAR'
1376       include 'COMMON.LOCAL'
1377       include 'COMMON.CHAIN'
1378       include 'COMMON.VECTORS'
1379       dimension uyder(3,3,2),uzder(3,3,2)
1380 C Compute the local reference systems. For reference system (i), the
1381 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1382 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1383       do i=1,nres-1
1384           if (i.eq.nres-1) then
1385 C Case of the last full residue
1386 C Compute the Z-axis
1387             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1388             costh=dcos(pi-theta(nres))
1389             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1390 c            write (iout,*) 'fac',fac,
1391 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i-1)
1399             uzder(3,1,1)= dc_norm(2,i-1)
1400             uzder(1,2,1)= dc_norm(3,i-1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i-1)
1403             uzder(1,3,1)=-dc_norm(2,i-1)
1404             uzder(2,3,1)= dc_norm(1,i-1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             do k=1,3
1417               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1418             enddo
1419             facy=fac
1420             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1421      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1422      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1423             do k=1,3
1424 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1425               uy(k,i)=
1426 c     &        facy*(
1427      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1428      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1429 c     &        )
1430             enddo
1431 c            write (iout,*) 'facy',facy,
1432 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1434             do k=1,3
1435               uy(k,i)=facy*uy(k,i)
1436             enddo
1437 C Compute the derivatives of uy
1438             do j=1,3
1439               do k=1,3
1440                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1441      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1442                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1443               enddo
1444 c              uyder(j,j,1)=uyder(j,j,1)-costh
1445 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1446               uyder(j,j,1)=uyder(j,j,1)
1447      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1448               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1449      &          +uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463           else
1464 C Other residues
1465 C Compute the Z-axis
1466             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1467             costh=dcos(pi-theta(i+2))
1468             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1469             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1470             do k=1,3
1471               uz(k,i)=fac*uz(k,i)
1472             enddo
1473 C Compute the derivatives of uz
1474             uzder(1,1,1)= 0.0d0
1475             uzder(2,1,1)=-dc_norm(3,i+1)
1476             uzder(3,1,1)= dc_norm(2,i+1)
1477             uzder(1,2,1)= dc_norm(3,i+1)
1478             uzder(2,2,1)= 0.0d0
1479             uzder(3,2,1)=-dc_norm(1,i+1)
1480             uzder(1,3,1)=-dc_norm(2,i+1)
1481             uzder(2,3,1)= dc_norm(1,i+1)
1482             uzder(3,3,1)= 0.0d0
1483             uzder(1,1,2)= 0.0d0
1484             uzder(2,1,2)= dc_norm(3,i)
1485             uzder(3,1,2)=-dc_norm(2,i)
1486             uzder(1,2,2)=-dc_norm(3,i)
1487             uzder(2,2,2)= 0.0d0
1488             uzder(3,2,2)= dc_norm(1,i)
1489             uzder(1,3,2)= dc_norm(2,i)
1490             uzder(2,3,2)=-dc_norm(1,i)
1491             uzder(3,3,2)= 0.0d0
1492 C Compute the Y-axis
1493             facy=fac
1494             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1495      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1496      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1497             do k=1,3
1498 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1499               uy(k,i)=
1500 c     &        facy*(
1501      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1502      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1503 c     &        )
1504             enddo
1505 c            write (iout,*) 'facy',facy,
1506 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1508             do k=1,3
1509               uy(k,i)=facy*uy(k,i)
1510             enddo
1511 C Compute the derivatives of uy
1512             do j=1,3
1513               do k=1,3
1514                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1515      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1516                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1517               enddo
1518 c              uyder(j,j,1)=uyder(j,j,1)-costh
1519 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1520               uyder(j,j,1)=uyder(j,j,1)
1521      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1522               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1523      &          +uyder(j,j,2)
1524             enddo
1525             do j=1,2
1526               do k=1,3
1527                 do l=1,3
1528                   uygrad(l,k,j,i)=uyder(l,k,j)
1529                   uzgrad(l,k,j,i)=uzder(l,k,j)
1530                 enddo
1531               enddo
1532             enddo
1533             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1534             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1535             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1536             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1537           endif
1538       enddo
1539       do i=1,nres-1
1540         do j=1,2
1541           do k=1,3
1542             do l=1,3
1543               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1544               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1545             enddo
1546           enddo
1547         enddo
1548       enddo
1549       return
1550       end
1551 C-----------------------------------------------------------------------------
1552       subroutine check_vecgrad
1553       implicit real*8 (a-h,o-z)
1554       include 'DIMENSIONS'
1555       include 'DIMENSIONS.ZSCOPT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.GEO'
1558       include 'COMMON.VAR'
1559       include 'COMMON.LOCAL'
1560       include 'COMMON.CHAIN'
1561       include 'COMMON.VECTORS'
1562       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1563       dimension uyt(3,maxres),uzt(3,maxres)
1564       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1565       double precision delta /1.0d-7/
1566       call vec_and_deriv
1567 cd      do i=1,nres
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1570 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1571 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1572 cd     &     (dc_norm(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1574 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1575 cd          write(iout,'(a)')
1576 cd      enddo
1577       do i=1,nres
1578         do j=1,2
1579           do k=1,3
1580             do l=1,3
1581               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1582               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1583             enddo
1584           enddo
1585         enddo
1586       enddo
1587       call vec_and_deriv
1588       do i=1,nres
1589         do j=1,3
1590           uyt(j,i)=uy(j,i)
1591           uzt(j,i)=uz(j,i)
1592         enddo
1593       enddo
1594       do i=1,nres
1595 cd        write (iout,*) 'i=',i
1596         do k=1,3
1597           erij(k)=dc_norm(k,i)
1598         enddo
1599         do j=1,3
1600           do k=1,3
1601             dc_norm(k,i)=erij(k)
1602           enddo
1603           dc_norm(j,i)=dc_norm(j,i)+delta
1604 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1605 c          do k=1,3
1606 c            dc_norm(k,i)=dc_norm(k,i)/fac
1607 c          enddo
1608 c          write (iout,*) (dc_norm(k,i),k=1,3)
1609 c          write (iout,*) (erij(k),k=1,3)
1610           call vec_and_deriv
1611           do k=1,3
1612             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1613             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1614             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1615             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1616           enddo
1617 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1618 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1619 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1620         enddo
1621         do k=1,3
1622           dc_norm(k,i)=erij(k)
1623         enddo
1624 cd        do k=1,3
1625 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1626 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1627 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1628 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1629 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1630 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1631 cd          write (iout,'(a)')
1632 cd        enddo
1633       enddo
1634       return
1635       end
1636 C--------------------------------------------------------------------------
1637       subroutine set_matrices
1638       implicit real*8 (a-h,o-z)
1639       include 'DIMENSIONS'
1640       include 'DIMENSIONS.ZSCOPT'
1641       include 'COMMON.IOUNITS'
1642       include 'COMMON.GEO'
1643       include 'COMMON.VAR'
1644       include 'COMMON.LOCAL'
1645       include 'COMMON.CHAIN'
1646       include 'COMMON.DERIV'
1647       include 'COMMON.INTERACT'
1648       include 'COMMON.CONTACTS'
1649       include 'COMMON.TORSION'
1650       include 'COMMON.VECTORS'
1651       include 'COMMON.FFIELD'
1652       double precision auxvec(2),auxmat(2,2)
1653 C
1654 C Compute the virtual-bond-torsional-angle dependent quantities needed
1655 C to calculate the el-loc multibody terms of various order.
1656 C
1657       do i=3,nres+1
1658         if (i .lt. nres+1) then
1659           sin1=dsin(phi(i))
1660           cos1=dcos(phi(i))
1661           sintab(i-2)=sin1
1662           costab(i-2)=cos1
1663           obrot(1,i-2)=cos1
1664           obrot(2,i-2)=sin1
1665           sin2=dsin(2*phi(i))
1666           cos2=dcos(2*phi(i))
1667           sintab2(i-2)=sin2
1668           costab2(i-2)=cos2
1669           obrot2(1,i-2)=cos2
1670           obrot2(2,i-2)=sin2
1671           Ug(1,1,i-2)=-cos1
1672           Ug(1,2,i-2)=-sin1
1673           Ug(2,1,i-2)=-sin1
1674           Ug(2,2,i-2)= cos1
1675           Ug2(1,1,i-2)=-cos2
1676           Ug2(1,2,i-2)=-sin2
1677           Ug2(2,1,i-2)=-sin2
1678           Ug2(2,2,i-2)= cos2
1679         else
1680           costab(i-2)=1.0d0
1681           sintab(i-2)=0.0d0
1682           obrot(1,i-2)=1.0d0
1683           obrot(2,i-2)=0.0d0
1684           obrot2(1,i-2)=0.0d0
1685           obrot2(2,i-2)=0.0d0
1686           Ug(1,1,i-2)=1.0d0
1687           Ug(1,2,i-2)=0.0d0
1688           Ug(2,1,i-2)=0.0d0
1689           Ug(2,2,i-2)=1.0d0
1690           Ug2(1,1,i-2)=0.0d0
1691           Ug2(1,2,i-2)=0.0d0
1692           Ug2(2,1,i-2)=0.0d0
1693           Ug2(2,2,i-2)=0.0d0
1694         endif
1695         if (i .gt. 3 .and. i .lt. nres+1) then
1696           obrot_der(1,i-2)=-sin1
1697           obrot_der(2,i-2)= cos1
1698           Ugder(1,1,i-2)= sin1
1699           Ugder(1,2,i-2)=-cos1
1700           Ugder(2,1,i-2)=-cos1
1701           Ugder(2,2,i-2)=-sin1
1702           dwacos2=cos2+cos2
1703           dwasin2=sin2+sin2
1704           obrot2_der(1,i-2)=-dwasin2
1705           obrot2_der(2,i-2)= dwacos2
1706           Ug2der(1,1,i-2)= dwasin2
1707           Ug2der(1,2,i-2)=-dwacos2
1708           Ug2der(2,1,i-2)=-dwacos2
1709           Ug2der(2,2,i-2)=-dwasin2
1710         else
1711           obrot_der(1,i-2)=0.0d0
1712           obrot_der(2,i-2)=0.0d0
1713           Ugder(1,1,i-2)=0.0d0
1714           Ugder(1,2,i-2)=0.0d0
1715           Ugder(2,1,i-2)=0.0d0
1716           Ugder(2,2,i-2)=0.0d0
1717           obrot2_der(1,i-2)=0.0d0
1718           obrot2_der(2,i-2)=0.0d0
1719           Ug2der(1,1,i-2)=0.0d0
1720           Ug2der(1,2,i-2)=0.0d0
1721           Ug2der(2,1,i-2)=0.0d0
1722           Ug2der(2,2,i-2)=0.0d0
1723         endif
1724         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1725           iti = itortyp(itype(i-2))
1726         else
1727           iti=ntortyp+1
1728         endif
1729         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1730           iti1 = itortyp(itype(i-1))
1731         else
1732           iti1=ntortyp+1
1733         endif
1734 cd        write (iout,*) '*******i',i,' iti1',iti
1735 cd        write (iout,*) 'b1',b1(:,iti)
1736 cd        write (iout,*) 'b2',b2(:,iti)
1737 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1738         if (i .gt. iatel_s+2) then
1739           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1740           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1741           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1742           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1743           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1744           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1745           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1746         else
1747           do k=1,2
1748             Ub2(k,i-2)=0.0d0
1749             Ctobr(k,i-2)=0.0d0
1750             Dtobr2(k,i-2)=0.0d0
1751             do l=1,2
1752               EUg(l,k,i-2)=0.0d0
1753               CUg(l,k,i-2)=0.0d0
1754               DUg(l,k,i-2)=0.0d0
1755               DtUg2(l,k,i-2)=0.0d0
1756             enddo
1757           enddo
1758         endif
1759         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1760         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1761         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1762         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1763         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1764         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1765         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1766         do k=1,2
1767           muder(k,i-2)=Ub2der(k,i-2)
1768         enddo
1769         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1770           iti1 = itortyp(itype(i-1))
1771         else
1772           iti1=ntortyp+1
1773         endif
1774         do k=1,2
1775           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1776         enddo
1777 C Vectors and matrices dependent on a single virtual-bond dihedral.
1778         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1779         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1780         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1782         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1783         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1784         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1785         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1786         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1787 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1788 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1789       enddo
1790 C Matrices dependent on two consecutive virtual-bond dihedrals.
1791 C The order of matrices is from left to right.
1792       do i=2,nres-1
1793         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1794         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1795         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1796         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1797         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1798         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1799         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1800         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1801       enddo
1802 cd      do i=1,nres
1803 cd        iti = itortyp(itype(i))
1804 cd        write (iout,*) i
1805 cd        do j=1,2
1806 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1807 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1808 cd        enddo
1809 cd      enddo
1810       return
1811       end
1812 C--------------------------------------------------------------------------
1813       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1814 C
1815 C This subroutine calculates the average interaction energy and its gradient
1816 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1817 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1818 C The potential depends both on the distance of peptide-group centers and on
1819 C the orientation of the CA-CA virtual bonds.
1820 C
1821       implicit real*8 (a-h,o-z)
1822       include 'DIMENSIONS'
1823       include 'DIMENSIONS.ZSCOPT'
1824       include 'DIMENSIONS.FREE'
1825       include 'COMMON.CONTROL'
1826       include 'COMMON.IOUNITS'
1827       include 'COMMON.GEO'
1828       include 'COMMON.VAR'
1829       include 'COMMON.LOCAL'
1830       include 'COMMON.CHAIN'
1831       include 'COMMON.DERIV'
1832       include 'COMMON.INTERACT'
1833       include 'COMMON.CONTACTS'
1834       include 'COMMON.TORSION'
1835       include 'COMMON.VECTORS'
1836       include 'COMMON.FFIELD'
1837       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1838      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1839       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1840      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1841       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1842 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1843       double precision scal_el /0.5d0/
1844 C 12/13/98
1845 C 13-go grudnia roku pamietnego...
1846       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1847      &                   0.0d0,1.0d0,0.0d0,
1848      &                   0.0d0,0.0d0,1.0d0/
1849 cd      write(iout,*) 'In EELEC'
1850 cd      do i=1,nloctyp
1851 cd        write(iout,*) 'Type',i
1852 cd        write(iout,*) 'B1',B1(:,i)
1853 cd        write(iout,*) 'B2',B2(:,i)
1854 cd        write(iout,*) 'CC',CC(:,:,i)
1855 cd        write(iout,*) 'DD',DD(:,:,i)
1856 cd        write(iout,*) 'EE',EE(:,:,i)
1857 cd      enddo
1858 cd      call check_vecgrad
1859 cd      stop
1860       if (icheckgrad.eq.1) then
1861         do i=1,nres-1
1862           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1863           do k=1,3
1864             dc_norm(k,i)=dc(k,i)*fac
1865           enddo
1866 c          write (iout,*) 'i',i,' fac',fac
1867         enddo
1868       endif
1869       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1870      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1871      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1872 cd      if (wel_loc.gt.0.0d0) then
1873         if (icheckgrad.eq.1) then
1874         call vec_and_deriv_test
1875         else
1876         call vec_and_deriv
1877         endif
1878         call set_matrices
1879       endif
1880 cd      do i=1,nres-1
1881 cd        write (iout,*) 'i=',i
1882 cd        do k=1,3
1883 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1884 cd        enddo
1885 cd        do k=1,3
1886 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1887 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1888 cd        enddo
1889 cd      enddo
1890       num_conti_hb=0
1891       ees=0.0D0
1892       evdw1=0.0D0
1893       eel_loc=0.0d0
1894       eello_turn3=0.0d0
1895       eello_turn4=0.0d0
1896       ind=0
1897       do i=1,nres
1898         num_cont_hb(i)=0
1899       enddo
1900 cd      print '(a)','Enter EELEC'
1901 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1902       do i=1,nres
1903         gel_loc_loc(i)=0.0d0
1904         gcorr_loc(i)=0.0d0
1905       enddo
1906       do i=iatel_s,iatel_e
1907         if (itel(i).eq.0) goto 1215
1908         dxi=dc(1,i)
1909         dyi=dc(2,i)
1910         dzi=dc(3,i)
1911         dx_normi=dc_norm(1,i)
1912         dy_normi=dc_norm(2,i)
1913         dz_normi=dc_norm(3,i)
1914         xmedi=c(1,i)+0.5d0*dxi
1915         ymedi=c(2,i)+0.5d0*dyi
1916         zmedi=c(3,i)+0.5d0*dzi
1917         num_conti=0
1918 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1919         do j=ielstart(i),ielend(i)
1920           if (itel(j).eq.0) goto 1216
1921           ind=ind+1
1922           iteli=itel(i)
1923           itelj=itel(j)
1924           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1925           aaa=app(iteli,itelj)
1926           bbb=bpp(iteli,itelj)
1927 C Diagnostics only!!!
1928 c         aaa=0.0D0
1929 c         bbb=0.0D0
1930 c         ael6i=0.0D0
1931 c         ael3i=0.0D0
1932 C End diagnostics
1933           ael6i=ael6(iteli,itelj)
1934           ael3i=ael3(iteli,itelj)
1935           dxj=dc(1,j)
1936           dyj=dc(2,j)
1937           dzj=dc(3,j)
1938           dx_normj=dc_norm(1,j)
1939           dy_normj=dc_norm(2,j)
1940           dz_normj=dc_norm(3,j)
1941           xj=c(1,j)+0.5D0*dxj-xmedi
1942           yj=c(2,j)+0.5D0*dyj-ymedi
1943           zj=c(3,j)+0.5D0*dzj-zmedi
1944           rij=xj*xj+yj*yj+zj*zj
1945           rrmij=1.0D0/rij
1946           rij=dsqrt(rij)
1947           rmij=1.0D0/rij
1948           r3ij=rrmij*rmij
1949           r6ij=r3ij*r3ij
1950           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1951           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1952           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1953           fac=cosa-3.0D0*cosb*cosg
1954           ev1=aaa*r6ij*r6ij
1955 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1956           if (j.eq.i+2) ev1=scal_el*ev1
1957           ev2=bbb*r6ij
1958           fac3=ael6i*r6ij
1959           fac4=ael3i*r3ij
1960           evdwij=ev1+ev2
1961           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1962           el2=fac4*fac
1963           eesij=el1+el2
1964 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1965 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1966           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1967           ees=ees+eesij
1968           evdw1=evdw1+evdwij
1969 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1970 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1971 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1972 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1973 C
1974 C Calculate contributions to the Cartesian gradient.
1975 C
1976 #ifdef SPLITELE
1977           facvdw=-6*rrmij*(ev1+evdwij)
1978           facel=-3*rrmij*(el1+eesij)
1979           fac1=fac
1980           erij(1)=xj*rmij
1981           erij(2)=yj*rmij
1982           erij(3)=zj*rmij
1983           if (calc_grad) then
1984 *
1985 * Radial derivatives. First process both termini of the fragment (i,j)
1986 *
1987           ggg(1)=facel*xj
1988           ggg(2)=facel*yj
1989           ggg(3)=facel*zj
1990           do k=1,3
1991             ghalf=0.5D0*ggg(k)
1992             gelc(k,i)=gelc(k,i)+ghalf
1993             gelc(k,j)=gelc(k,j)+ghalf
1994           enddo
1995 *
1996 * Loop over residues i+1 thru j-1.
1997 *
1998           do k=i+1,j-1
1999             do l=1,3
2000               gelc(l,k)=gelc(l,k)+ggg(l)
2001             enddo
2002           enddo
2003           ggg(1)=facvdw*xj
2004           ggg(2)=facvdw*yj
2005           ggg(3)=facvdw*zj
2006           do k=1,3
2007             ghalf=0.5D0*ggg(k)
2008             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2009             gvdwpp(k,j)=gvdwpp(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               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2017             enddo
2018           enddo
2019 #else
2020           facvdw=ev1+evdwij
2021           facel=el1+eesij
2022           fac1=fac
2023           fac=-3*rrmij*(facvdw+facvdw+facel)
2024           erij(1)=xj*rmij
2025           erij(2)=yj*rmij
2026           erij(3)=zj*rmij
2027           if (calc_grad) then
2028 *
2029 * Radial derivatives. First process both termini of the fragment (i,j)
2030 *
2031           ggg(1)=fac*xj
2032           ggg(2)=fac*yj
2033           ggg(3)=fac*zj
2034           do k=1,3
2035             ghalf=0.5D0*ggg(k)
2036             gelc(k,i)=gelc(k,i)+ghalf
2037             gelc(k,j)=gelc(k,j)+ghalf
2038           enddo
2039 *
2040 * Loop over residues i+1 thru j-1.
2041 *
2042           do k=i+1,j-1
2043             do l=1,3
2044               gelc(l,k)=gelc(l,k)+ggg(l)
2045             enddo
2046           enddo
2047 #endif
2048 *
2049 * Angular part
2050 *
2051           ecosa=2.0D0*fac3*fac1+fac4
2052           fac4=-3.0D0*fac4
2053           fac3=-6.0D0*fac3
2054           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2055           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2056           do k=1,3
2057             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2058             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2059           enddo
2060 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2061 cd   &          (dcosg(k),k=1,3)
2062           do k=1,3
2063             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2064           enddo
2065           do k=1,3
2066             ghalf=0.5D0*ggg(k)
2067             gelc(k,i)=gelc(k,i)+ghalf
2068      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2069      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2070             gelc(k,j)=gelc(k,j)+ghalf
2071      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2072      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2073           enddo
2074           do k=i+1,j-1
2075             do l=1,3
2076               gelc(l,k)=gelc(l,k)+ggg(l)
2077             enddo
2078           enddo
2079           endif
2080
2081           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2082      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2083      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2084 C
2085 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2086 C   energy of a peptide unit is assumed in the form of a second-order
2087 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2088 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2089 C   are computed for EVERY pair of non-contiguous peptide groups.
2090 C
2091           if (j.lt.nres-1) then
2092             j1=j+1
2093             j2=j-1
2094           else
2095             j1=j-1
2096             j2=j-2
2097           endif
2098           kkk=0
2099           do k=1,2
2100             do l=1,2
2101               kkk=kkk+1
2102               muij(kkk)=mu(k,i)*mu(l,j)
2103             enddo
2104           enddo
2105 cd         write (iout,*) 'EELEC: i',i,' j',j
2106 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2107 cd          write(iout,*) 'muij',muij
2108           ury=scalar(uy(1,i),erij)
2109           urz=scalar(uz(1,i),erij)
2110           vry=scalar(uy(1,j),erij)
2111           vrz=scalar(uz(1,j),erij)
2112           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2113           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2114           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2115           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2116 C For diagnostics only
2117 cd          a22=1.0d0
2118 cd          a23=1.0d0
2119 cd          a32=1.0d0
2120 cd          a33=1.0d0
2121           fac=dsqrt(-ael6i)*r3ij
2122 cd          write (2,*) 'fac=',fac
2123 C For diagnostics only
2124 cd          fac=1.0d0
2125           a22=a22*fac
2126           a23=a23*fac
2127           a32=a32*fac
2128           a33=a33*fac
2129 cd          write (iout,'(4i5,4f10.5)')
2130 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2131 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2132 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2133 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2134 cd          write (iout,'(4f10.5)')
2135 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2136 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2137 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2138 cd           write (iout,'(2i3,9f10.5/)') i,j,
2139 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2140           if (calc_grad) then
2141 C Derivatives of the elements of A in virtual-bond vectors
2142           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2143 cd          do k=1,3
2144 cd            do l=1,3
2145 cd              erder(k,l)=0.0d0
2146 cd            enddo
2147 cd          enddo
2148           do k=1,3
2149             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2150             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2151             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2152             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2153             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2154             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2155             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2156             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2157             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2158             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2159             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2160             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2161           enddo
2162 cd          do k=1,3
2163 cd            do l=1,3
2164 cd              uryg(k,l)=0.0d0
2165 cd              urzg(k,l)=0.0d0
2166 cd              vryg(k,l)=0.0d0
2167 cd              vrzg(k,l)=0.0d0
2168 cd            enddo
2169 cd          enddo
2170 C Compute radial contributions to the gradient
2171           facr=-3.0d0*rrmij
2172           a22der=a22*facr
2173           a23der=a23*facr
2174           a32der=a32*facr
2175           a33der=a33*facr
2176 cd          a22der=0.0d0
2177 cd          a23der=0.0d0
2178 cd          a32der=0.0d0
2179 cd          a33der=0.0d0
2180           agg(1,1)=a22der*xj
2181           agg(2,1)=a22der*yj
2182           agg(3,1)=a22der*zj
2183           agg(1,2)=a23der*xj
2184           agg(2,2)=a23der*yj
2185           agg(3,2)=a23der*zj
2186           agg(1,3)=a32der*xj
2187           agg(2,3)=a32der*yj
2188           agg(3,3)=a32der*zj
2189           agg(1,4)=a33der*xj
2190           agg(2,4)=a33der*yj
2191           agg(3,4)=a33der*zj
2192 C Add the contributions coming from er
2193           fac3=-3.0d0*fac
2194           do k=1,3
2195             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2196             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2197             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2198             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2199           enddo
2200           do k=1,3
2201 C Derivatives in DC(i)
2202             ghalf1=0.5d0*agg(k,1)
2203             ghalf2=0.5d0*agg(k,2)
2204             ghalf3=0.5d0*agg(k,3)
2205             ghalf4=0.5d0*agg(k,4)
2206             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2207      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2208             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2209      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2210             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2211      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2212             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2213      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2214 C Derivatives in DC(i+1)
2215             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2216      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2217             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2218      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2219             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2220      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2221             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2222      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2223 C Derivatives in DC(j)
2224             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2226             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2227      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2228             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2230             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2231      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2232 C Derivatives in DC(j+1) or DC(nres-1)
2233             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vryg(k,3)*ury)
2235             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2236      &      -3.0d0*vrzg(k,3)*ury)
2237             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vryg(k,3)*urz)
2239             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2240      &      -3.0d0*vrzg(k,3)*urz)
2241 cd            aggi(k,1)=ghalf1
2242 cd            aggi(k,2)=ghalf2
2243 cd            aggi(k,3)=ghalf3
2244 cd            aggi(k,4)=ghalf4
2245 C Derivatives in DC(i+1)
2246 cd            aggi1(k,1)=agg(k,1)
2247 cd            aggi1(k,2)=agg(k,2)
2248 cd            aggi1(k,3)=agg(k,3)
2249 cd            aggi1(k,4)=agg(k,4)
2250 C Derivatives in DC(j)
2251 cd            aggj(k,1)=ghalf1
2252 cd            aggj(k,2)=ghalf2
2253 cd            aggj(k,3)=ghalf3
2254 cd            aggj(k,4)=ghalf4
2255 C Derivatives in DC(j+1)
2256 cd            aggj1(k,1)=0.0d0
2257 cd            aggj1(k,2)=0.0d0
2258 cd            aggj1(k,3)=0.0d0
2259 cd            aggj1(k,4)=0.0d0
2260             if (j.eq.nres-1 .and. i.lt.j-2) then
2261               do l=1,4
2262                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2263 cd                aggj1(k,l)=agg(k,l)
2264               enddo
2265             endif
2266           enddo
2267           endif
2268 c          goto 11111
2269 C Check the loc-el terms by numerical integration
2270           acipa(1,1)=a22
2271           acipa(1,2)=a23
2272           acipa(2,1)=a32
2273           acipa(2,2)=a33
2274           a22=-a22
2275           a23=-a23
2276           do l=1,2
2277             do k=1,3
2278               agg(k,l)=-agg(k,l)
2279               aggi(k,l)=-aggi(k,l)
2280               aggi1(k,l)=-aggi1(k,l)
2281               aggj(k,l)=-aggj(k,l)
2282               aggj1(k,l)=-aggj1(k,l)
2283             enddo
2284           enddo
2285           if (j.lt.nres-1) then
2286             a22=-a22
2287             a32=-a32
2288             do l=1,3,2
2289               do k=1,3
2290                 agg(k,l)=-agg(k,l)
2291                 aggi(k,l)=-aggi(k,l)
2292                 aggi1(k,l)=-aggi1(k,l)
2293                 aggj(k,l)=-aggj(k,l)
2294                 aggj1(k,l)=-aggj1(k,l)
2295               enddo
2296             enddo
2297           else
2298             a22=-a22
2299             a23=-a23
2300             a32=-a32
2301             a33=-a33
2302             do l=1,4
2303               do k=1,3
2304                 agg(k,l)=-agg(k,l)
2305                 aggi(k,l)=-aggi(k,l)
2306                 aggi1(k,l)=-aggi1(k,l)
2307                 aggj(k,l)=-aggj(k,l)
2308                 aggj1(k,l)=-aggj1(k,l)
2309               enddo
2310             enddo
2311           endif
2312           ENDIF ! WCORR
2313 11111     continue
2314           IF (wel_loc.gt.0.0d0) THEN
2315 C Contribution to the local-electrostatic energy coming from the i-j pair
2316           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2317      &     +a33*muij(4)
2318 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2319 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2320           eel_loc=eel_loc+eel_loc_ij
2321 C Partial derivatives in virtual-bond dihedral angles gamma
2322           if (calc_grad) then
2323           if (i.gt.1)
2324      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2325      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2326      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2327           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2328      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2329      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2330 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2331 cd          write(iout,*) 'agg  ',agg
2332 cd          write(iout,*) 'aggi ',aggi
2333 cd          write(iout,*) 'aggi1',aggi1
2334 cd          write(iout,*) 'aggj ',aggj
2335 cd          write(iout,*) 'aggj1',aggj1
2336
2337 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2338           do l=1,3
2339             ggg(l)=agg(l,1)*muij(1)+
2340      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2341           enddo
2342           do k=i+2,j2
2343             do l=1,3
2344               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2345             enddo
2346           enddo
2347 C Remaining derivatives of eello
2348           do l=1,3
2349             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2350      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2351             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2352      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2353             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2354      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2355             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2356      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2357           enddo
2358           endif
2359           ENDIF
2360           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2361 C Contributions from turns
2362             a_temp(1,1)=a22
2363             a_temp(1,2)=a23
2364             a_temp(2,1)=a32
2365             a_temp(2,2)=a33
2366             call eturn34(i,j,eello_turn3,eello_turn4)
2367           endif
2368 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2369           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2370 C
2371 C Calculate the contact function. The ith column of the array JCONT will
2372 C contain the numbers of atoms that make contacts with the atom I (of numbers
2373 C greater than I). The arrays FACONT and GACONT will contain the values of
2374 C the contact function and its derivative.
2375 c           r0ij=1.02D0*rpp(iteli,itelj)
2376 c           r0ij=1.11D0*rpp(iteli,itelj)
2377             r0ij=2.20D0*rpp(iteli,itelj)
2378 c           r0ij=1.55D0*rpp(iteli,itelj)
2379             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2380             if (fcont.gt.0.0D0) then
2381               num_conti=num_conti+1
2382               if (num_conti.gt.maxconts) then
2383                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2384      &                         ' will skip next contacts for this conf.'
2385               else
2386                 jcont_hb(num_conti,i)=j
2387                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2388      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2389 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2390 C  terms.
2391                 d_cont(num_conti,i)=rij
2392 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2393 C     --- Electrostatic-interaction matrix ---
2394                 a_chuj(1,1,num_conti,i)=a22
2395                 a_chuj(1,2,num_conti,i)=a23
2396                 a_chuj(2,1,num_conti,i)=a32
2397                 a_chuj(2,2,num_conti,i)=a33
2398 C     --- Gradient of rij
2399                 do kkk=1,3
2400                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2401                 enddo
2402 c             if (i.eq.1) then
2403 c                a_chuj(1,1,num_conti,i)=-0.61d0
2404 c                a_chuj(1,2,num_conti,i)= 0.4d0
2405 c                a_chuj(2,1,num_conti,i)= 0.65d0
2406 c                a_chuj(2,2,num_conti,i)= 0.50d0
2407 c             else if (i.eq.2) then
2408 c                a_chuj(1,1,num_conti,i)= 0.0d0
2409 c                a_chuj(1,2,num_conti,i)= 0.0d0
2410 c                a_chuj(2,1,num_conti,i)= 0.0d0
2411 c                a_chuj(2,2,num_conti,i)= 0.0d0
2412 c             endif
2413 C     --- and its gradients
2414 cd                write (iout,*) 'i',i,' j',j
2415 cd                do kkk=1,3
2416 cd                write (iout,*) 'iii 1 kkk',kkk
2417 cd                write (iout,*) agg(kkk,:)
2418 cd                enddo
2419 cd                do kkk=1,3
2420 cd                write (iout,*) 'iii 2 kkk',kkk
2421 cd                write (iout,*) aggi(kkk,:)
2422 cd                enddo
2423 cd                do kkk=1,3
2424 cd                write (iout,*) 'iii 3 kkk',kkk
2425 cd                write (iout,*) aggi1(kkk,:)
2426 cd                enddo
2427 cd                do kkk=1,3
2428 cd                write (iout,*) 'iii 4 kkk',kkk
2429 cd                write (iout,*) aggj(kkk,:)
2430 cd                enddo
2431 cd                do kkk=1,3
2432 cd                write (iout,*) 'iii 5 kkk',kkk
2433 cd                write (iout,*) aggj1(kkk,:)
2434 cd                enddo
2435                 kkll=0
2436                 do k=1,2
2437                   do l=1,2
2438                     kkll=kkll+1
2439                     do m=1,3
2440                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2441                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2442                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2443                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2444                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2445 c                      do mm=1,5
2446 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2447 c                      enddo
2448                     enddo
2449                   enddo
2450                 enddo
2451                 ENDIF
2452                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2453 C Calculate contact energies
2454                 cosa4=4.0D0*cosa
2455                 wij=cosa-3.0D0*cosb*cosg
2456                 cosbg1=cosb+cosg
2457                 cosbg2=cosb-cosg
2458 c               fac3=dsqrt(-ael6i)/r0ij**3
2459                 fac3=dsqrt(-ael6i)*r3ij
2460                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2461                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2462 c               ees0mij=0.0D0
2463                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2464                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2465 C Diagnostics. Comment out or remove after debugging!
2466 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2467 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2468 c               ees0m(num_conti,i)=0.0D0
2469 C End diagnostics.
2470 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2471 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2472                 facont_hb(num_conti,i)=fcont
2473                 if (calc_grad) then
2474 C Angular derivatives of the contact function
2475                 ees0pij1=fac3/ees0pij
2476                 ees0mij1=fac3/ees0mij
2477                 fac3p=-3.0D0*fac3*rrmij
2478                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2479                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2480 c               ees0mij1=0.0D0
2481                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2482                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2483                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2484                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2485                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2486                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2487                 ecosap=ecosa1+ecosa2
2488                 ecosbp=ecosb1+ecosb2
2489                 ecosgp=ecosg1+ecosg2
2490                 ecosam=ecosa1-ecosa2
2491                 ecosbm=ecosb1-ecosb2
2492                 ecosgm=ecosg1-ecosg2
2493 C Diagnostics
2494 c               ecosap=ecosa1
2495 c               ecosbp=ecosb1
2496 c               ecosgp=ecosg1
2497 c               ecosam=0.0D0
2498 c               ecosbm=0.0D0
2499 c               ecosgm=0.0D0
2500 C End diagnostics
2501                 fprimcont=fprimcont/rij
2502 cd              facont_hb(num_conti,i)=1.0D0
2503 C Following line is for diagnostics.
2504 cd              fprimcont=0.0D0
2505                 do k=1,3
2506                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2507                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2508                 enddo
2509                 do k=1,3
2510                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2511                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2512                 enddo
2513                 gggp(1)=gggp(1)+ees0pijp*xj
2514                 gggp(2)=gggp(2)+ees0pijp*yj
2515                 gggp(3)=gggp(3)+ees0pijp*zj
2516                 gggm(1)=gggm(1)+ees0mijp*xj
2517                 gggm(2)=gggm(2)+ees0mijp*yj
2518                 gggm(3)=gggm(3)+ees0mijp*zj
2519 C Derivatives due to the contact function
2520                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2521                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2522                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2523                 do k=1,3
2524                   ghalfp=0.5D0*gggp(k)
2525                   ghalfm=0.5D0*gggm(k)
2526                   gacontp_hb1(k,num_conti,i)=ghalfp
2527      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2528      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2529                   gacontp_hb2(k,num_conti,i)=ghalfp
2530      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2531      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2532                   gacontp_hb3(k,num_conti,i)=gggp(k)
2533                   gacontm_hb1(k,num_conti,i)=ghalfm
2534      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2535      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2536                   gacontm_hb2(k,num_conti,i)=ghalfm
2537      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2538      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2539                   gacontm_hb3(k,num_conti,i)=gggm(k)
2540                 enddo
2541                 endif
2542 C Diagnostics. Comment out or remove after debugging!
2543 cdiag           do k=1,3
2544 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2545 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2546 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2548 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2549 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2550 cdiag           enddo
2551               ENDIF ! wcorr
2552               endif  ! num_conti.le.maxconts
2553             endif  ! fcont.gt.0
2554           endif    ! j.gt.i+1
2555  1216     continue
2556         enddo ! j
2557         num_cont_hb(i)=num_conti
2558  1215   continue
2559       enddo   ! i
2560 cd      do i=1,nres
2561 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2562 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2563 cd      enddo
2564 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2565 ccc      eel_loc=eel_loc+eello_turn3
2566       return
2567       end
2568 C-----------------------------------------------------------------------------
2569       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2570 C Third- and fourth-order contributions from turns
2571       implicit real*8 (a-h,o-z)
2572       include 'DIMENSIONS'
2573       include 'DIMENSIONS.ZSCOPT'
2574       include 'COMMON.IOUNITS'
2575       include 'COMMON.GEO'
2576       include 'COMMON.VAR'
2577       include 'COMMON.LOCAL'
2578       include 'COMMON.CHAIN'
2579       include 'COMMON.DERIV'
2580       include 'COMMON.INTERACT'
2581       include 'COMMON.CONTACTS'
2582       include 'COMMON.TORSION'
2583       include 'COMMON.VECTORS'
2584       include 'COMMON.FFIELD'
2585       dimension ggg(3)
2586       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2587      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2588      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2589       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2590      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2591       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2592       if (j.eq.i+2) then
2593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2594 C
2595 C               Third-order contributions
2596 C
2597 C                 (i+2)o----(i+3)
2598 C                      | |
2599 C                      | |
2600 C                 (i+1)o----i
2601 C
2602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2603 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2604         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2605         call transpose2(auxmat(1,1),auxmat1(1,1))
2606         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2607         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2608 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2609 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2610 cd     &    ' eello_turn3_num',4*eello_turn3_num
2611         if (calc_grad) then
2612 C Derivatives in gamma(i)
2613         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2614         call transpose2(auxmat2(1,1),pizda(1,1))
2615         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2616         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2617 C Derivatives in gamma(i+1)
2618         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2619         call transpose2(auxmat2(1,1),pizda(1,1))
2620         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2621         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2622      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2623 C Cartesian derivatives
2624         do l=1,3
2625           a_temp(1,1)=aggi(l,1)
2626           a_temp(1,2)=aggi(l,2)
2627           a_temp(2,1)=aggi(l,3)
2628           a_temp(2,2)=aggi(l,4)
2629           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2630           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2631      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2632           a_temp(1,1)=aggi1(l,1)
2633           a_temp(1,2)=aggi1(l,2)
2634           a_temp(2,1)=aggi1(l,3)
2635           a_temp(2,2)=aggi1(l,4)
2636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2637           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2639           a_temp(1,1)=aggj(l,1)
2640           a_temp(1,2)=aggj(l,2)
2641           a_temp(2,1)=aggj(l,3)
2642           a_temp(2,2)=aggj(l,4)
2643           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2644           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2645      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2646           a_temp(1,1)=aggj1(l,1)
2647           a_temp(1,2)=aggj1(l,2)
2648           a_temp(2,1)=aggj1(l,3)
2649           a_temp(2,2)=aggj1(l,4)
2650           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2651           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2652      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2653         enddo
2654         endif
2655       else if (j.eq.i+3) then
2656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2657 C
2658 C               Fourth-order contributions
2659 C
2660 C                 (i+3)o----(i+4)
2661 C                     /  |
2662 C               (i+2)o   |
2663 C                     \  |
2664 C                 (i+1)o----i
2665 C
2666 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2667 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2668         iti1=itortyp(itype(i+1))
2669         iti2=itortyp(itype(i+2))
2670         iti3=itortyp(itype(i+3))
2671         call transpose2(EUg(1,1,i+1),e1t(1,1))
2672         call transpose2(Eug(1,1,i+2),e2t(1,1))
2673         call transpose2(Eug(1,1,i+3),e3t(1,1))
2674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2676         s1=scalar2(b1(1,iti2),auxvec(1))
2677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2679         s2=scalar2(b1(1,iti1),auxvec(1))
2680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2683         eello_turn4=eello_turn4-(s1+s2+s3)
2684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2685 cd     &    ' eello_turn4_num',8*eello_turn4_num
2686 C Derivatives in gamma(i)
2687         if (calc_grad) then
2688         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2689         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2690         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2691         s1=scalar2(b1(1,iti2),auxvec(1))
2692         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2693         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2694         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2695 C Derivatives in gamma(i+1)
2696         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2697         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2698         s2=scalar2(b1(1,iti1),auxvec(1))
2699         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2700         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2702         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2703 C Derivatives in gamma(i+2)
2704         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2705         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2706         s1=scalar2(b1(1,iti2),auxvec(1))
2707         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2708         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2709         s2=scalar2(b1(1,iti1),auxvec(1))
2710         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2711         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2712         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2713         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2714 C Cartesian derivatives
2715 C Derivatives of this turn contributions in DC(i+2)
2716         if (j.lt.nres-1) then
2717           do l=1,3
2718             a_temp(1,1)=agg(l,1)
2719             a_temp(1,2)=agg(l,2)
2720             a_temp(2,1)=agg(l,3)
2721             a_temp(2,2)=agg(l,4)
2722             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2723             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2724             s1=scalar2(b1(1,iti2),auxvec(1))
2725             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2726             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2727             s2=scalar2(b1(1,iti1),auxvec(1))
2728             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2729             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2730             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2731             ggg(l)=-(s1+s2+s3)
2732             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2733           enddo
2734         endif
2735 C Remaining derivatives of this turn contribution
2736         do l=1,3
2737           a_temp(1,1)=aggi(l,1)
2738           a_temp(1,2)=aggi(l,2)
2739           a_temp(2,1)=aggi(l,3)
2740           a_temp(2,2)=aggi(l,4)
2741           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2742           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2743           s1=scalar2(b1(1,iti2),auxvec(1))
2744           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2745           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2746           s2=scalar2(b1(1,iti1),auxvec(1))
2747           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2748           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2749           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2750           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2751           a_temp(1,1)=aggi1(l,1)
2752           a_temp(1,2)=aggi1(l,2)
2753           a_temp(2,1)=aggi1(l,3)
2754           a_temp(2,2)=aggi1(l,4)
2755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2757           s1=scalar2(b1(1,iti2),auxvec(1))
2758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2760           s2=scalar2(b1(1,iti1),auxvec(1))
2761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2765           a_temp(1,1)=aggj(l,1)
2766           a_temp(1,2)=aggj(l,2)
2767           a_temp(2,1)=aggj(l,3)
2768           a_temp(2,2)=aggj(l,4)
2769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2771           s1=scalar2(b1(1,iti2),auxvec(1))
2772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2774           s2=scalar2(b1(1,iti1),auxvec(1))
2775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2778           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2779           a_temp(1,1)=aggj1(l,1)
2780           a_temp(1,2)=aggj1(l,2)
2781           a_temp(2,1)=aggj1(l,3)
2782           a_temp(2,2)=aggj1(l,4)
2783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2785           s1=scalar2(b1(1,iti2),auxvec(1))
2786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2788           s2=scalar2(b1(1,iti1),auxvec(1))
2789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2792           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2793         enddo
2794         endif
2795       endif
2796       return
2797       end
2798 C-----------------------------------------------------------------------------
2799       subroutine vecpr(u,v,w)
2800       implicit real*8(a-h,o-z)
2801       dimension u(3),v(3),w(3)
2802       w(1)=u(2)*v(3)-u(3)*v(2)
2803       w(2)=-u(1)*v(3)+u(3)*v(1)
2804       w(3)=u(1)*v(2)-u(2)*v(1)
2805       return
2806       end
2807 C-----------------------------------------------------------------------------
2808       subroutine unormderiv(u,ugrad,unorm,ungrad)
2809 C This subroutine computes the derivatives of a normalized vector u, given
2810 C the derivatives computed without normalization conditions, ugrad. Returns
2811 C ungrad.
2812       implicit none
2813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2814       double precision vec(3)
2815       double precision scalar
2816       integer i,j
2817 c      write (2,*) 'ugrad',ugrad
2818 c      write (2,*) 'u',u
2819       do i=1,3
2820         vec(i)=scalar(ugrad(1,i),u(1))
2821       enddo
2822 c      write (2,*) 'vec',vec
2823       do i=1,3
2824         do j=1,3
2825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2826         enddo
2827       enddo
2828 c      write (2,*) 'ungrad',ungrad
2829       return
2830       end
2831 C-----------------------------------------------------------------------------
2832       subroutine escp(evdw2,evdw2_14)
2833 C
2834 C This subroutine calculates the excluded-volume interaction energy between
2835 C peptide-group centers and side chains and its gradient in virtual-bond and
2836 C side-chain vectors.
2837 C
2838       implicit real*8 (a-h,o-z)
2839       include 'DIMENSIONS'
2840       include 'DIMENSIONS.ZSCOPT'
2841       include 'COMMON.GEO'
2842       include 'COMMON.VAR'
2843       include 'COMMON.LOCAL'
2844       include 'COMMON.CHAIN'
2845       include 'COMMON.DERIV'
2846       include 'COMMON.INTERACT'
2847       include 'COMMON.FFIELD'
2848       include 'COMMON.IOUNITS'
2849       dimension ggg(3)
2850       evdw2=0.0D0
2851       evdw2_14=0.0d0
2852 cd    print '(a)','Enter ESCP'
2853 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2854 c     &  ' scal14',scal14
2855       do i=iatscp_s,iatscp_e
2856         iteli=itel(i)
2857 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2858 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2859         if (iteli.eq.0) goto 1225
2860         xi=0.5D0*(c(1,i)+c(1,i+1))
2861         yi=0.5D0*(c(2,i)+c(2,i+1))
2862         zi=0.5D0*(c(3,i)+c(3,i+1))
2863
2864         do iint=1,nscp_gr(i)
2865
2866         do j=iscpstart(i,iint),iscpend(i,iint)
2867           itypj=itype(j)
2868 C Uncomment following three lines for SC-p interactions
2869 c         xj=c(1,nres+j)-xi
2870 c         yj=c(2,nres+j)-yi
2871 c         zj=c(3,nres+j)-zi
2872 C Uncomment following three lines for Ca-p interactions
2873           xj=c(1,j)-xi
2874           yj=c(2,j)-yi
2875           zj=c(3,j)-zi
2876           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2877           fac=rrij**expon2
2878           e1=fac*fac*aad(itypj,iteli)
2879           e2=fac*bad(itypj,iteli)
2880           if (iabs(j-i) .le. 2) then
2881             e1=scal14*e1
2882             e2=scal14*e2
2883             evdw2_14=evdw2_14+e1+e2
2884           endif
2885           evdwij=e1+e2
2886 c          write (iout,*) i,j,evdwij
2887           evdw2=evdw2+evdwij
2888           if (calc_grad) then
2889 C
2890 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2891 C
2892           fac=-(evdwij+e1)*rrij
2893           ggg(1)=xj*fac
2894           ggg(2)=yj*fac
2895           ggg(3)=zj*fac
2896           if (j.lt.i) then
2897 cd          write (iout,*) 'j<i'
2898 C Uncomment following three lines for SC-p interactions
2899 c           do k=1,3
2900 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2901 c           enddo
2902           else
2903 cd          write (iout,*) 'j>i'
2904             do k=1,3
2905               ggg(k)=-ggg(k)
2906 C Uncomment following line for SC-p interactions
2907 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2908             enddo
2909           endif
2910           do k=1,3
2911             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2912           enddo
2913           kstart=min0(i+1,j)
2914           kend=max0(i-1,j-1)
2915 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2916 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2917           do k=kstart,kend
2918             do l=1,3
2919               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2920             enddo
2921           enddo
2922           endif
2923         enddo
2924         enddo ! iint
2925  1225   continue
2926       enddo ! i
2927       do i=1,nct
2928         do j=1,3
2929           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2930           gradx_scp(j,i)=expon*gradx_scp(j,i)
2931         enddo
2932       enddo
2933 C******************************************************************************
2934 C
2935 C                              N O T E !!!
2936 C
2937 C To save time the factor EXPON has been extracted from ALL components
2938 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2939 C use!
2940 C
2941 C******************************************************************************
2942       return
2943       end
2944 C--------------------------------------------------------------------------
2945       subroutine edis(ehpb)
2946 C
2947 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2948 C
2949       implicit real*8 (a-h,o-z)
2950       include 'DIMENSIONS'
2951       include 'COMMON.SBRIDGE'
2952       include 'COMMON.CHAIN'
2953       include 'COMMON.DERIV'
2954       include 'COMMON.VAR'
2955       include 'COMMON.INTERACT'
2956       include 'COMMON.IOUNITS'
2957       dimension ggg(3)
2958       ehpb=0.0D0
2959 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2960 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2961       if (link_end.eq.0) return
2962       do i=link_start,link_end
2963 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2964 C CA-CA distance used in regularization of structure.
2965         ii=ihpb(i)
2966         jj=jhpb(i)
2967 C iii and jjj point to the residues for which the distance is assigned.
2968         if (ii.gt.nres) then
2969           iii=ii-nres
2970           jjj=jj-nres
2971         else
2972           iii=ii
2973           jjj=jj
2974         endif
2975 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2976 c     &    dhpb(i),dhpb1(i),forcon(i)
2977 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2978 C    distance and angle dependent SS bond potential.
2979         if (.not.dyn_ss .and. i.le.nss) then
2980 C 15/02/13 CC dynamic SSbond - additional check
2981         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2982           call ssbond_ene(iii,jjj,eij)
2983           ehpb=ehpb+2*eij
2984          endif
2985 cd          write (iout,*) "eij",eij
2986         else if (ii.gt.nres .and. jj.gt.nres) then
2987 c Restraints from contact prediction
2988           dd=dist(ii,jj)
2989           if (dhpb1(i).gt.0.0d0) then
2990             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2991             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2992 c            write (iout,*) "beta nmr",
2993 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2994           else
2995             dd=dist(ii,jj)
2996             rdis=dd-dhpb(i)
2997 C Get the force constant corresponding to this distance.
2998             waga=forcon(i)
2999 C Calculate the contribution to energy.
3000             ehpb=ehpb+waga*rdis*rdis
3001 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3002 C
3003 C Evaluate gradient.
3004 C
3005             fac=waga*rdis/dd
3006           endif
3007           do j=1,3
3008             ggg(j)=fac*(c(j,jj)-c(j,ii))
3009           enddo
3010           do j=1,3
3011             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3012             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3013           enddo
3014           do k=1,3
3015             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3016             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3017           enddo
3018         else
3019 C Calculate the distance between the two points and its difference from the
3020 C target distance.
3021           dd=dist(ii,jj)
3022           if (dhpb1(i).gt.0.0d0) then
3023             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3024             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3025 c            write (iout,*) "alph nmr",
3026 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3027           else
3028             rdis=dd-dhpb(i)
3029 C Get the force constant corresponding to this distance.
3030             waga=forcon(i)
3031 C Calculate the contribution to energy.
3032             ehpb=ehpb+waga*rdis*rdis
3033 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3034 C
3035 C Evaluate gradient.
3036 C
3037             fac=waga*rdis/dd
3038           endif
3039 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3040 cd   &   ' waga=',waga,' fac=',fac
3041             do j=1,3
3042               ggg(j)=fac*(c(j,jj)-c(j,ii))
3043             enddo
3044 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3045 C If this is a SC-SC distance, we need to calculate the contributions to the
3046 C Cartesian gradient in the SC vectors (ghpbx).
3047           if (iii.lt.ii) then
3048           do j=1,3
3049             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3050             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3051           enddo
3052           endif
3053           do k=1,3
3054             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3055             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3056           enddo
3057         endif
3058       enddo
3059       ehpb=0.5D0*ehpb
3060       return
3061       end
3062 C--------------------------------------------------------------------------
3063       subroutine ssbond_ene(i,j,eij)
3064 C
3065 C Calculate the distance and angle dependent SS-bond potential energy
3066 C using a free-energy function derived based on RHF/6-31G** ab initio
3067 C calculations of diethyl disulfide.
3068 C
3069 C A. Liwo and U. Kozlowska, 11/24/03
3070 C
3071       implicit real*8 (a-h,o-z)
3072       include 'DIMENSIONS'
3073       include 'DIMENSIONS.ZSCOPT'
3074       include 'COMMON.SBRIDGE'
3075       include 'COMMON.CHAIN'
3076       include 'COMMON.DERIV'
3077       include 'COMMON.LOCAL'
3078       include 'COMMON.INTERACT'
3079       include 'COMMON.VAR'
3080       include 'COMMON.IOUNITS'
3081       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3082       itypi=itype(i)
3083       xi=c(1,nres+i)
3084       yi=c(2,nres+i)
3085       zi=c(3,nres+i)
3086       dxi=dc_norm(1,nres+i)
3087       dyi=dc_norm(2,nres+i)
3088       dzi=dc_norm(3,nres+i)
3089       dsci_inv=dsc_inv(itypi)
3090       itypj=itype(j)
3091       dscj_inv=dsc_inv(itypj)
3092       xj=c(1,nres+j)-xi
3093       yj=c(2,nres+j)-yi
3094       zj=c(3,nres+j)-zi
3095       dxj=dc_norm(1,nres+j)
3096       dyj=dc_norm(2,nres+j)
3097       dzj=dc_norm(3,nres+j)
3098       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3099       rij=dsqrt(rrij)
3100       erij(1)=xj*rij
3101       erij(2)=yj*rij
3102       erij(3)=zj*rij
3103       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3104       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3105       om12=dxi*dxj+dyi*dyj+dzi*dzj
3106       do k=1,3
3107         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3108         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3109       enddo
3110       rij=1.0d0/rij
3111       deltad=rij-d0cm
3112       deltat1=1.0d0-om1
3113       deltat2=1.0d0+om2
3114       deltat12=om2-om1+2.0d0
3115       cosphi=om12-om1*om2
3116       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3117      &  +akct*deltad*deltat12+ebr
3118 c     &  +akct*deltad*deltat12
3119      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3120       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3121      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3122      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3123       ed=2*akcm*deltad+akct*deltat12
3124       pom1=akct*deltad
3125       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3126       eom1=-2*akth*deltat1-pom1-om2*pom2
3127       eom2= 2*akth*deltat2+pom1-om1*pom2
3128       eom12=pom2
3129       do k=1,3
3130         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3131       enddo
3132       do k=1,3
3133         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3134      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3135         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3136      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3137       enddo
3138 C
3139 C Calculate the components of the gradient in DC and X
3140 C
3141       do k=i,j-1
3142         do l=1,3
3143           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3144         enddo
3145       enddo
3146       return
3147       end
3148 C--------------------------------------------------------------------------
3149 c MODELLER restraint function
3150       subroutine e_modeller(ehomology_constr)
3151       implicit real*8 (a-h,o-z)
3152       include 'DIMENSIONS'
3153       include 'DIMENSIONS.ZSCOPT'
3154       include 'DIMENSIONS.FREE'
3155       integer nnn, i, j, k, ki, irec, l
3156       integer katy, odleglosci, test7
3157       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3158       real*8 distance(max_template),distancek(max_template),
3159      &    min_odl,godl(max_template),dih_diff(max_template)
3160
3161 c
3162 c     FP - 30/10/2014 Temporary specifications for homology restraints
3163 c
3164       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3165      &                 sgtheta
3166       double precision, dimension (maxres) :: guscdiff,usc_diff
3167       double precision, dimension (max_template) ::
3168      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3169      &           theta_diff
3170
3171       include 'COMMON.SBRIDGE'
3172       include 'COMMON.CHAIN'
3173       include 'COMMON.GEO'
3174       include 'COMMON.DERIV'
3175       include 'COMMON.LOCAL'
3176       include 'COMMON.INTERACT'
3177       include 'COMMON.VAR'
3178       include 'COMMON.IOUNITS'
3179       include 'COMMON.CONTROL'
3180       include 'COMMON.HOMRESTR'
3181 c
3182       include 'COMMON.SETUP'
3183       include 'COMMON.NAMES'
3184
3185       do i=1,max_template
3186         distancek(i)=9999999.9
3187       enddo
3188
3189       odleg=0.0d0
3190
3191 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3192 c function)
3193 C AL 5/2/14 - Introduce list of restraints
3194 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3195 #ifdef DEBUG
3196       write(iout,*) "------- dist restrs start -------"
3197 #endif
3198       do ii = link_start_homo,link_end_homo
3199          i = ires_homo(ii)
3200          j = jres_homo(ii)
3201          dij=dist(i,j)
3202 c        write (iout,*) "dij(",i,j,") =",dij
3203          do k=1,constr_homology
3204            if(.not.l_homo(k,ii)) cycle
3205            distance(k)=odl(k,ii)-dij
3206 c          write (iout,*) "distance(",k,") =",distance(k)
3207 c
3208 c          For Gaussian-type Urestr
3209 c
3210            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3211 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3212 c          write (iout,*) "distancek(",k,") =",distancek(k)
3213 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3214 c
3215 c          For Lorentzian-type Urestr
3216 c
3217            if (waga_dist.lt.0.0d0) then
3218               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3219               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3220      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3221            endif
3222          enddo
3223
3224 c         min_odl=minval(distancek)
3225          do kk=1,constr_homology
3226           if(l_homo(kk,ii)) then
3227             min_odl=distancek(kk)
3228             exit
3229           endif
3230          enddo
3231          do kk=1,constr_homology
3232           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3233      &              min_odl=distancek(kk)
3234          enddo
3235 c        write (iout,* )"min_odl",min_odl
3236 #ifdef DEBUG
3237          write (iout,*) "ij dij",i,j,dij
3238          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3239          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3240          write (iout,* )"min_odl",min_odl
3241 #endif
3242          odleg2=0.0d0
3243          do k=1,constr_homology
3244 c Nie wiem po co to liczycie jeszcze raz!
3245 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3246 c     &              (2*(sigma_odl(i,j,k))**2))
3247            if(.not.l_homo(k,ii)) cycle
3248            if (waga_dist.ge.0.0d0) then
3249 c
3250 c          For Gaussian-type Urestr
3251 c
3252             godl(k)=dexp(-distancek(k)+min_odl)
3253             odleg2=odleg2+godl(k)
3254 c
3255 c          For Lorentzian-type Urestr
3256 c
3257            else
3258             odleg2=odleg2+distancek(k)
3259            endif
3260
3261 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3262 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3263 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3264 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3265
3266          enddo
3267 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3268 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3269 #ifdef DEBUG
3270          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3271          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3272 #endif
3273            if (waga_dist.ge.0.0d0) then
3274 c
3275 c          For Gaussian-type Urestr
3276 c
3277               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3278 c
3279 c          For Lorentzian-type Urestr
3280 c
3281            else
3282               odleg=odleg+odleg2/constr_homology
3283            endif
3284 c
3285 #ifdef GRAD
3286 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3287 c Gradient
3288 c
3289 c          For Gaussian-type Urestr
3290 c
3291          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3292          sum_sgodl=0.0d0
3293          do k=1,constr_homology
3294 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3295 c     &           *waga_dist)+min_odl
3296 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3297 c
3298          if(.not.l_homo(k,ii)) cycle
3299          if (waga_dist.ge.0.0d0) then
3300 c          For Gaussian-type Urestr
3301 c
3302            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3303 c
3304 c          For Lorentzian-type Urestr
3305 c
3306          else
3307            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3308      &           sigma_odlir(k,ii)**2)**2)
3309          endif
3310            sum_sgodl=sum_sgodl+sgodl
3311
3312 c            sgodl2=sgodl2+sgodl
3313 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3314 c      write(iout,*) "constr_homology=",constr_homology
3315 c      write(iout,*) i, j, k, "TEST K"
3316          enddo
3317          if (waga_dist.ge.0.0d0) then
3318 c
3319 c          For Gaussian-type Urestr
3320 c
3321             grad_odl3=waga_homology(iset)*waga_dist
3322      &                *sum_sgodl/(sum_godl*dij)
3323 c
3324 c          For Lorentzian-type Urestr
3325 c
3326          else
3327 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3328 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3329             grad_odl3=-waga_homology(iset)*waga_dist*
3330      &                sum_sgodl/(constr_homology*dij)
3331          endif
3332 c
3333 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3334
3335
3336 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3337 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3338 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3339
3340 ccc      write(iout,*) godl, sgodl, grad_odl3
3341
3342 c          grad_odl=grad_odl+grad_odl3
3343
3344          do jik=1,3
3345             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3346 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3347 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3348 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3349             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3350             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3351 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3352 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3353 c         if (i.eq.25.and.j.eq.27) then
3354 c         write(iout,*) "jik",jik,"i",i,"j",j
3355 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3356 c         write(iout,*) "grad_odl3",grad_odl3
3357 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3358 c         write(iout,*) "ggodl",ggodl
3359 c         write(iout,*) "ghpbc(",jik,i,")",
3360 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3361 c     &                 ghpbc(jik,j)
3362 c         endif
3363          enddo
3364 #endif
3365 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3366 ccc     & dLOG(odleg2),"-odleg=", -odleg
3367
3368       enddo ! ii-loop for dist
3369 #ifdef DEBUG
3370       write(iout,*) "------- dist restrs end -------"
3371 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3372 c    &     waga_d.eq.1.0d0) call sum_gradient
3373 #endif
3374 c Pseudo-energy and gradient from dihedral-angle restraints from
3375 c homology templates
3376 c      write (iout,*) "End of distance loop"
3377 c      call flush(iout)
3378       kat=0.0d0
3379 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3380 #ifdef DEBUG
3381       write(iout,*) "------- dih restrs start -------"
3382       do i=idihconstr_start_homo,idihconstr_end_homo
3383         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3384       enddo
3385 #endif
3386       do i=idihconstr_start_homo,idihconstr_end_homo
3387         kat2=0.0d0
3388 c        betai=beta(i,i+1,i+2,i+3)
3389         betai = phi(i+3)
3390 c       write (iout,*) "betai =",betai
3391         do k=1,constr_homology
3392           dih_diff(k)=pinorm(dih(k,i)-betai)
3393 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3394 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3395 c     &                                   -(6.28318-dih_diff(i,k))
3396 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3397 c     &                                   6.28318+dih_diff(i,k)
3398
3399           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3400 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3401           gdih(k)=dexp(kat3)
3402           kat2=kat2+gdih(k)
3403 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3404 c          write(*,*)""
3405         enddo
3406 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3407 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3408 #ifdef DEBUG
3409         write (iout,*) "i",i," betai",betai," kat2",kat2
3410         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3411 #endif
3412         if (kat2.le.1.0d-14) cycle
3413         kat=kat-dLOG(kat2/constr_homology)
3414 c       write (iout,*) "kat",kat ! sum of -ln-s
3415
3416 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3417 ccc     & dLOG(kat2), "-kat=", -kat
3418
3419 #ifdef GRAD
3420 c ----------------------------------------------------------------------
3421 c Gradient
3422 c ----------------------------------------------------------------------
3423
3424         sum_gdih=kat2
3425         sum_sgdih=0.0d0
3426         do k=1,constr_homology
3427           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3428 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3429           sum_sgdih=sum_sgdih+sgdih
3430         enddo
3431 c       grad_dih3=sum_sgdih/sum_gdih
3432         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3433
3434 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3435 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3436 ccc     & gloc(nphi+i-3,icg)
3437         gloc(i,icg)=gloc(i,icg)+grad_dih3
3438 c        if (i.eq.25) then
3439 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3440 c        endif
3441 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3442 ccc     & gloc(nphi+i-3,icg)
3443 #endif
3444       enddo ! i-loop for dih
3445 #ifdef DEBUG
3446       write(iout,*) "------- dih restrs end -------"
3447 #endif
3448
3449 c Pseudo-energy and gradient for theta angle restraints from
3450 c homology templates
3451 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3452 c adapted
3453
3454 c
3455 c     For constr_homology reference structures (FP)
3456 c
3457 c     Uconst_back_tot=0.0d0
3458       Eval=0.0d0
3459       Erot=0.0d0
3460 c     Econstr_back legacy
3461 #ifdef GRAD
3462       do i=1,nres
3463 c     do i=ithet_start,ithet_end
3464        dutheta(i)=0.0d0
3465 c     enddo
3466 c     do i=loc_start,loc_end
3467         do j=1,3
3468           duscdiff(j,i)=0.0d0
3469           duscdiffx(j,i)=0.0d0
3470         enddo
3471       enddo
3472 #endif
3473 c
3474 c     do iref=1,nref
3475 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3476 c     write (iout,*) "waga_theta",waga_theta
3477       if (waga_theta.gt.0.0d0) then
3478 #ifdef DEBUG
3479       write (iout,*) "usampl",usampl
3480       write(iout,*) "------- theta restrs start -------"
3481 c     do i=ithet_start,ithet_end
3482 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3483 c     enddo
3484 #endif
3485 c     write (iout,*) "maxres",maxres,"nres",nres
3486
3487       do i=ithet_start,ithet_end
3488 c
3489 c     do i=1,nfrag_back
3490 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3491 c
3492 c Deviation of theta angles wrt constr_homology ref structures
3493 c
3494         utheta_i=0.0d0 ! argument of Gaussian for single k
3495         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3496 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3497 c       over residues in a fragment
3498 c       write (iout,*) "theta(",i,")=",theta(i)
3499         do k=1,constr_homology
3500 c
3501 c         dtheta_i=theta(j)-thetaref(j,iref)
3502 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3503           theta_diff(k)=thetatpl(k,i)-theta(i)
3504 c
3505           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3506 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3507           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3508           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3509 c         Gradient for single Gaussian restraint in subr Econstr_back
3510 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3511 c
3512         enddo
3513 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3514 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3515
3516 c
3517 #ifdef GRAD
3518 c         Gradient for multiple Gaussian restraint
3519         sum_gtheta=gutheta_i
3520         sum_sgtheta=0.0d0
3521         do k=1,constr_homology
3522 c        New generalized expr for multiple Gaussian from Econstr_back
3523          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3524 c
3525 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3526           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3527         enddo
3528 c
3529 c       Final value of gradient using same var as in Econstr_back
3530         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3531      &               *waga_homology(iset)
3532 c       dutheta(i)=sum_sgtheta/sum_gtheta
3533 c
3534 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3535 #endif
3536         Eval=Eval-dLOG(gutheta_i/constr_homology)
3537 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3538 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3539 c       Uconst_back=Uconst_back+utheta(i)
3540       enddo ! (i-loop for theta)
3541 #ifdef DEBUG
3542       write(iout,*) "------- theta restrs end -------"
3543 #endif
3544       endif
3545 c
3546 c Deviation of local SC geometry
3547 c
3548 c Separation of two i-loops (instructed by AL - 11/3/2014)
3549 c
3550 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3551 c     write (iout,*) "waga_d",waga_d
3552
3553 #ifdef DEBUG
3554       write(iout,*) "------- SC restrs start -------"
3555       write (iout,*) "Initial duscdiff,duscdiffx"
3556       do i=loc_start,loc_end
3557         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3558      &                 (duscdiffx(jik,i),jik=1,3)
3559       enddo
3560 #endif
3561       do i=loc_start,loc_end
3562         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3563         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3564 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3565 c       write(iout,*) "xxtab, yytab, zztab"
3566 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3567         do k=1,constr_homology
3568 c
3569           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3570 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3571           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3572           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3573 c         write(iout,*) "dxx, dyy, dzz"
3574 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3575 c
3576           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3577 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3578 c         uscdiffk(k)=usc_diff(i)
3579           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3580           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3581 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3582 c     &      xxref(j),yyref(j),zzref(j)
3583         enddo
3584 c
3585 c       Gradient
3586 c
3587 c       Generalized expression for multiple Gaussian acc to that for a single
3588 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3589 c
3590 c       Original implementation
3591 c       sum_guscdiff=guscdiff(i)
3592 c
3593 c       sum_sguscdiff=0.0d0
3594 c       do k=1,constr_homology
3595 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3596 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3597 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3598 c       enddo
3599 c
3600 c       Implementation of new expressions for gradient (Jan. 2015)
3601 c
3602 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3603 #ifdef GRAD
3604         do k=1,constr_homology
3605 c
3606 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3607 c       before. Now the drivatives should be correct
3608 c
3609           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3610 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3611           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3612           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3613 c
3614 c         New implementation
3615 c
3616           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3617      &                 sigma_d(k,i) ! for the grad wrt r'
3618 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3619 c
3620 c
3621 c        New implementation
3622          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3623          do jik=1,3
3624             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3625      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3626      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3627             duscdiff(jik,i)=duscdiff(jik,i)+
3628      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3629      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3630             duscdiffx(jik,i)=duscdiffx(jik,i)+
3631      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3632      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3633 c
3634 #ifdef DEBUG
3635              write(iout,*) "jik",jik,"i",i
3636              write(iout,*) "dxx, dyy, dzz"
3637              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3638              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3639 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3640 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3641 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3642 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3643 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3644 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3645 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3646 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3647 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3648 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3649 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3650 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3651 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3652 c            endif
3653 #endif
3654          enddo
3655         enddo
3656 #endif
3657 c
3658 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3659 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3660 c
3661 c        write (iout,*) i," uscdiff",uscdiff(i)
3662 c
3663 c Put together deviations from local geometry
3664
3665 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3666 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3667         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3668 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3669 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3670 c       Uconst_back=Uconst_back+usc_diff(i)
3671 c
3672 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3673 c
3674 c     New implment: multiplied by sum_sguscdiff
3675 c
3676
3677       enddo ! (i-loop for dscdiff)
3678
3679 c      endif
3680
3681 #ifdef DEBUG
3682       write(iout,*) "------- SC restrs end -------"
3683         write (iout,*) "------ After SC loop in e_modeller ------"
3684         do i=loc_start,loc_end
3685          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3686          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3687         enddo
3688       if (waga_theta.eq.1.0d0) then
3689       write (iout,*) "in e_modeller after SC restr end: dutheta"
3690       do i=ithet_start,ithet_end
3691         write (iout,*) i,dutheta(i)
3692       enddo
3693       endif
3694       if (waga_d.eq.1.0d0) then
3695       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3696       do i=1,nres
3697         write (iout,*) i,(duscdiff(j,i),j=1,3)
3698         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3699       enddo
3700       endif
3701 #endif
3702
3703 c Total energy from homology restraints
3704 #ifdef DEBUG
3705       write (iout,*) "odleg",odleg," kat",kat
3706       write (iout,*) "odleg",odleg," kat",kat
3707       write (iout,*) "Eval",Eval," Erot",Erot
3708       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3709       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3710       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3711 #endif
3712 c
3713 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3714 c
3715 c     ehomology_constr=odleg+kat
3716 c
3717 c     For Lorentzian-type Urestr
3718 c
3719
3720       if (waga_dist.ge.0.0d0) then
3721 c
3722 c          For Gaussian-type Urestr
3723 c
3724 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3725 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3726         ehomology_constr=waga_dist*odleg+waga_angle*kat+
3727      &              waga_theta*Eval+waga_d*Erot
3728 c     write (iout,*) "ehomology_constr=",ehomology_constr
3729       else
3730 c
3731 c          For Lorentzian-type Urestr
3732 c
3733 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3734 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3735         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
3736      &              waga_theta*Eval+waga_d*Erot
3737 c     write (iout,*) "ehomology_constr=",ehomology_constr
3738       endif
3739 #ifdef DEBUG
3740       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3741      & "Eval",waga_theta,eval,
3742      &   "Erot",waga_d,Erot
3743       write (iout,*) "ehomology_constr",ehomology_constr
3744 #endif
3745       return
3746
3747   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3748   747 format(a12,i4,i4,i4,f8.3,f8.3)
3749   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3750   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3751   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3752      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3753       end
3754 c-----------------------------------------------------------------------
3755       subroutine ebond(estr)
3756 c
3757 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3758 c
3759       implicit real*8 (a-h,o-z)
3760       include 'DIMENSIONS'
3761       include 'DIMENSIONS.ZSCOPT'
3762       include 'DIMENSIONS.FREE'
3763       include 'COMMON.LOCAL'
3764       include 'COMMON.GEO'
3765       include 'COMMON.INTERACT'
3766       include 'COMMON.DERIV'
3767       include 'COMMON.VAR'
3768       include 'COMMON.CHAIN'
3769       include 'COMMON.IOUNITS'
3770       include 'COMMON.NAMES'
3771       include 'COMMON.FFIELD'
3772       include 'COMMON.CONTROL'
3773       double precision u(3),ud(3)
3774       logical :: lprn=.false.
3775       estr=0.0d0
3776       do i=nnt+1,nct
3777         diff = vbld(i)-vbldp0
3778 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3779         estr=estr+diff*diff
3780         do j=1,3
3781           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3782         enddo
3783       enddo
3784       estr=0.5d0*AKP*estr
3785 c
3786 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3787 c
3788       do i=nnt,nct
3789         iti=itype(i)
3790         if (iti.ne.10) then
3791           nbi=nbondterm(iti)
3792           if (nbi.eq.1) then
3793             diff=vbld(i+nres)-vbldsc0(1,iti)
3794             if (lprn)
3795      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3796      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3797             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3798             do j=1,3
3799               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3800             enddo
3801           else
3802             do j=1,nbi
3803               diff=vbld(i+nres)-vbldsc0(j,iti)
3804               ud(j)=aksc(j,iti)*diff
3805               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3806             enddo
3807             uprod=u(1)
3808             do j=2,nbi
3809               uprod=uprod*u(j)
3810             enddo
3811             usum=0.0d0
3812             usumsqder=0.0d0
3813             do j=1,nbi
3814               uprod1=1.0d0
3815               uprod2=1.0d0
3816               do k=1,nbi
3817                 if (k.ne.j) then
3818                   uprod1=uprod1*u(k)
3819                   uprod2=uprod2*u(k)*u(k)
3820                 endif
3821               enddo
3822               usum=usum+uprod1
3823               usumsqder=usumsqder+ud(j)*uprod2
3824             enddo
3825             if (lprn)
3826      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3827      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3828             estr=estr+uprod/usum
3829             do j=1,3
3830              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3831             enddo
3832           endif
3833         endif
3834       enddo
3835       return
3836       end
3837 #ifdef CRYST_THETA
3838 C--------------------------------------------------------------------------
3839       subroutine ebend(etheta)
3840 C
3841 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3842 C angles gamma and its derivatives in consecutive thetas and gammas.
3843 C
3844       implicit real*8 (a-h,o-z)
3845       include 'DIMENSIONS'
3846       include 'DIMENSIONS.ZSCOPT'
3847       include 'COMMON.LOCAL'
3848       include 'COMMON.GEO'
3849       include 'COMMON.INTERACT'
3850       include 'COMMON.DERIV'
3851       include 'COMMON.VAR'
3852       include 'COMMON.CHAIN'
3853       include 'COMMON.IOUNITS'
3854       include 'COMMON.NAMES'
3855       include 'COMMON.FFIELD'
3856       common /calcthet/ term1,term2,termm,diffak,ratak,
3857      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3858      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3859       double precision y(2),z(2)
3860       delta=0.02d0*pi
3861       time11=dexp(-2*time)
3862       time12=1.0d0
3863       etheta=0.0D0
3864 c      write (iout,*) "nres",nres
3865 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3866 c      write (iout,*) ithet_start,ithet_end
3867       do i=ithet_start,ithet_end
3868 C Zero the energy function and its derivative at 0 or pi.
3869         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3870         it=itype(i-1)
3871 c        if (i.gt.ithet_start .and.
3872 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3873 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3874 c          phii=phi(i)
3875 c          y(1)=dcos(phii)
3876 c          y(2)=dsin(phii)
3877 c        else
3878 c          y(1)=0.0D0
3879 c          y(2)=0.0D0
3880 c        endif
3881 c        if (i.lt.nres .and. itel(i).ne.0) then
3882 c          phii1=phi(i+1)
3883 c          z(1)=dcos(phii1)
3884 c          z(2)=dsin(phii1)
3885 c        else
3886 c          z(1)=0.0D0
3887 c          z(2)=0.0D0
3888 c        endif
3889         if (i.gt.3) then
3890 #ifdef OSF
3891           phii=phi(i)
3892           icrc=0
3893           call proc_proc(phii,icrc)
3894           if (icrc.eq.1) phii=150.0
3895 #else
3896           phii=phi(i)
3897 #endif
3898           y(1)=dcos(phii)
3899           y(2)=dsin(phii)
3900         else
3901           y(1)=0.0D0
3902           y(2)=0.0D0
3903         endif
3904         if (i.lt.nres) then
3905 #ifdef OSF
3906           phii1=phi(i+1)
3907           icrc=0
3908           call proc_proc(phii1,icrc)
3909           if (icrc.eq.1) phii1=150.0
3910           phii1=pinorm(phii1)
3911           z(1)=cos(phii1)
3912 #else
3913           phii1=phi(i+1)
3914           z(1)=dcos(phii1)
3915 #endif
3916           z(2)=dsin(phii1)
3917         else
3918           z(1)=0.0D0
3919           z(2)=0.0D0
3920         endif
3921 C Calculate the "mean" value of theta from the part of the distribution
3922 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3923 C In following comments this theta will be referred to as t_c.
3924         thet_pred_mean=0.0d0
3925         do k=1,2
3926           athetk=athet(k,it)
3927           bthetk=bthet(k,it)
3928           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3929         enddo
3930 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3931         dthett=thet_pred_mean*ssd
3932         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3933 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3934 C Derivatives of the "mean" values in gamma1 and gamma2.
3935         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3936         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3937         if (theta(i).gt.pi-delta) then
3938           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3939      &         E_tc0)
3940           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3941           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3942           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3943      &        E_theta)
3944           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3945      &        E_tc)
3946         else if (theta(i).lt.delta) then
3947           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3948           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3949           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3950      &        E_theta)
3951           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3952           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3953      &        E_tc)
3954         else
3955           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3956      &        E_theta,E_tc)
3957         endif
3958         etheta=etheta+ethetai
3959 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3960 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3961         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3962         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3963         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3964  1215   continue
3965       enddo
3966 C Ufff.... We've done all this!!!
3967       return
3968       end
3969 C---------------------------------------------------------------------------
3970       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3971      &     E_tc)
3972       implicit real*8 (a-h,o-z)
3973       include 'DIMENSIONS'
3974       include 'COMMON.LOCAL'
3975       include 'COMMON.IOUNITS'
3976       common /calcthet/ term1,term2,termm,diffak,ratak,
3977      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3978      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3979 C Calculate the contributions to both Gaussian lobes.
3980 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3981 C The "polynomial part" of the "standard deviation" of this part of
3982 C the distribution.
3983         sig=polthet(3,it)
3984         do j=2,0,-1
3985           sig=sig*thet_pred_mean+polthet(j,it)
3986         enddo
3987 C Derivative of the "interior part" of the "standard deviation of the"
3988 C gamma-dependent Gaussian lobe in t_c.
3989         sigtc=3*polthet(3,it)
3990         do j=2,1,-1
3991           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3992         enddo
3993         sigtc=sig*sigtc
3994 C Set the parameters of both Gaussian lobes of the distribution.
3995 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3996         fac=sig*sig+sigc0(it)
3997         sigcsq=fac+fac
3998         sigc=1.0D0/sigcsq
3999 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4000         sigsqtc=-4.0D0*sigcsq*sigtc
4001 c       print *,i,sig,sigtc,sigsqtc
4002 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4003         sigtc=-sigtc/(fac*fac)
4004 C Following variable is sigma(t_c)**(-2)
4005         sigcsq=sigcsq*sigcsq
4006         sig0i=sig0(it)
4007         sig0inv=1.0D0/sig0i**2
4008         delthec=thetai-thet_pred_mean
4009         delthe0=thetai-theta0i
4010         term1=-0.5D0*sigcsq*delthec*delthec
4011         term2=-0.5D0*sig0inv*delthe0*delthe0
4012 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4013 C NaNs in taking the logarithm. We extract the largest exponent which is added
4014 C to the energy (this being the log of the distribution) at the end of energy
4015 C term evaluation for this virtual-bond angle.
4016         if (term1.gt.term2) then
4017           termm=term1
4018           term2=dexp(term2-termm)
4019           term1=1.0d0
4020         else
4021           termm=term2
4022           term1=dexp(term1-termm)
4023           term2=1.0d0
4024         endif
4025 C The ratio between the gamma-independent and gamma-dependent lobes of
4026 C the distribution is a Gaussian function of thet_pred_mean too.
4027         diffak=gthet(2,it)-thet_pred_mean
4028         ratak=diffak/gthet(3,it)**2
4029         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4030 C Let's differentiate it in thet_pred_mean NOW.
4031         aktc=ak*ratak
4032 C Now put together the distribution terms to make complete distribution.
4033         termexp=term1+ak*term2
4034         termpre=sigc+ak*sig0i
4035 C Contribution of the bending energy from this theta is just the -log of
4036 C the sum of the contributions from the two lobes and the pre-exponential
4037 C factor. Simple enough, isn't it?
4038         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4039 C NOW the derivatives!!!
4040 C 6/6/97 Take into account the deformation.
4041         E_theta=(delthec*sigcsq*term1
4042      &       +ak*delthe0*sig0inv*term2)/termexp
4043         E_tc=((sigtc+aktc*sig0i)/termpre
4044      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4045      &       aktc*term2)/termexp)
4046       return
4047       end
4048 c-----------------------------------------------------------------------------
4049       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4050       implicit real*8 (a-h,o-z)
4051       include 'DIMENSIONS'
4052       include 'COMMON.LOCAL'
4053       include 'COMMON.IOUNITS'
4054       common /calcthet/ term1,term2,termm,diffak,ratak,
4055      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4056      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4057       delthec=thetai-thet_pred_mean
4058       delthe0=thetai-theta0i
4059 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4060       t3 = thetai-thet_pred_mean
4061       t6 = t3**2
4062       t9 = term1
4063       t12 = t3*sigcsq
4064       t14 = t12+t6*sigsqtc
4065       t16 = 1.0d0
4066       t21 = thetai-theta0i
4067       t23 = t21**2
4068       t26 = term2
4069       t27 = t21*t26
4070       t32 = termexp
4071       t40 = t32**2
4072       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4073      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4074      & *(-t12*t9-ak*sig0inv*t27)
4075       return
4076       end
4077 #else
4078 C--------------------------------------------------------------------------
4079       subroutine ebend(etheta)
4080 C
4081 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4082 C angles gamma and its derivatives in consecutive thetas and gammas.
4083 C ab initio-derived potentials from
4084 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4085 C
4086       implicit real*8 (a-h,o-z)
4087       include 'DIMENSIONS'
4088       include 'DIMENSIONS.ZSCOPT'
4089       include 'DIMENSIONS.FREE'
4090       include 'COMMON.LOCAL'
4091       include 'COMMON.GEO'
4092       include 'COMMON.INTERACT'
4093       include 'COMMON.DERIV'
4094       include 'COMMON.VAR'
4095       include 'COMMON.CHAIN'
4096       include 'COMMON.IOUNITS'
4097       include 'COMMON.NAMES'
4098       include 'COMMON.FFIELD'
4099       include 'COMMON.CONTROL'
4100       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4101      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4102      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4103      & sinph1ph2(maxdouble,maxdouble)
4104       logical lprn /.false./, lprn1 /.false./
4105       etheta=0.0D0
4106 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4107       do i=ithet_start,ithet_end
4108         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4109      &    (itype(i).eq.ntyp1)) cycle
4110         dethetai=0.0d0
4111         dephii=0.0d0
4112         dephii1=0.0d0
4113         theti2=0.5d0*theta(i)
4114         ityp2=ithetyp(itype(i-1))
4115         do k=1,nntheterm
4116           coskt(k)=dcos(k*theti2)
4117           sinkt(k)=dsin(k*theti2)
4118         enddo
4119         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4120 #ifdef OSF
4121           phii=phi(i)
4122           if (phii.ne.phii) phii=150.0
4123 #else
4124           phii=phi(i)
4125 #endif
4126           ityp1=ithetyp(itype(i-2))
4127           do k=1,nsingle
4128             cosph1(k)=dcos(k*phii)
4129             sinph1(k)=dsin(k*phii)
4130           enddo
4131         else
4132           phii=0.0d0
4133           ityp1=ithetyp(itype(i-2))
4134           do k=1,nsingle
4135             cosph1(k)=0.0d0
4136             sinph1(k)=0.0d0
4137           enddo
4138         endif
4139         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4140 #ifdef OSF
4141           phii1=phi(i+1)
4142           if (phii1.ne.phii1) phii1=150.0
4143           phii1=pinorm(phii1)
4144 #else
4145           phii1=phi(i+1)
4146 #endif
4147           ityp3=ithetyp(itype(i))
4148           do k=1,nsingle
4149             cosph2(k)=dcos(k*phii1)
4150             sinph2(k)=dsin(k*phii1)
4151           enddo
4152         else
4153           phii1=0.0d0
4154 c          ityp3=nthetyp+1
4155           ityp3=ithetyp(itype(i))
4156           do k=1,nsingle
4157             cosph2(k)=0.0d0
4158             sinph2(k)=0.0d0
4159           enddo
4160         endif
4161 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4162 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4163 c        call flush(iout)
4164         ethetai=aa0thet(ityp1,ityp2,ityp3)
4165         do k=1,ndouble
4166           do l=1,k-1
4167             ccl=cosph1(l)*cosph2(k-l)
4168             ssl=sinph1(l)*sinph2(k-l)
4169             scl=sinph1(l)*cosph2(k-l)
4170             csl=cosph1(l)*sinph2(k-l)
4171             cosph1ph2(l,k)=ccl-ssl
4172             cosph1ph2(k,l)=ccl+ssl
4173             sinph1ph2(l,k)=scl+csl
4174             sinph1ph2(k,l)=scl-csl
4175           enddo
4176         enddo
4177         if (lprn) then
4178         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4179      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4180         write (iout,*) "coskt and sinkt"
4181         do k=1,nntheterm
4182           write (iout,*) k,coskt(k),sinkt(k)
4183         enddo
4184         endif
4185         do k=1,ntheterm
4186           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4187           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4188      &      *coskt(k)
4189           if (lprn)
4190      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4191      &     " ethetai",ethetai
4192         enddo
4193         if (lprn) then
4194         write (iout,*) "cosph and sinph"
4195         do k=1,nsingle
4196           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4197         enddo
4198         write (iout,*) "cosph1ph2 and sinph2ph2"
4199         do k=2,ndouble
4200           do l=1,k-1
4201             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4202      &         sinph1ph2(l,k),sinph1ph2(k,l)
4203           enddo
4204         enddo
4205         write(iout,*) "ethetai",ethetai
4206         endif
4207         do m=1,ntheterm2
4208           do k=1,nsingle
4209             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4210      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4211      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4212      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4213             ethetai=ethetai+sinkt(m)*aux
4214             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4215             dephii=dephii+k*sinkt(m)*(
4216      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4217      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4218             dephii1=dephii1+k*sinkt(m)*(
4219      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4220      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4221             if (lprn)
4222      &      write (iout,*) "m",m," k",k," bbthet",
4223      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4224      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4225      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4226      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4227           enddo
4228         enddo
4229         if (lprn)
4230      &  write(iout,*) "ethetai",ethetai
4231         do m=1,ntheterm3
4232           do k=2,ndouble
4233             do l=1,k-1
4234               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4235      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4236      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4237      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4238               ethetai=ethetai+sinkt(m)*aux
4239               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4240               dephii=dephii+l*sinkt(m)*(
4241      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4242      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4243      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4244      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4245               dephii1=dephii1+(k-l)*sinkt(m)*(
4246      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4247      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4248      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4249      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4250               if (lprn) then
4251               write (iout,*) "m",m," k",k," l",l," ffthet",
4252      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4253      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4254      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4255      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4256               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4257      &            cosph1ph2(k,l)*sinkt(m),
4258      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4259               endif
4260             enddo
4261           enddo
4262         enddo
4263 10      continue
4264 c        lprn1=.true.
4265         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4266      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4267      &   phii1*rad2deg,ethetai
4268 c        lprn1=.false.
4269         etheta=etheta+ethetai
4270
4271         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4272         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4273         gloc(nphi+i-2,icg)=wang*dethetai
4274       enddo
4275       return
4276       end
4277 #endif
4278 #ifdef CRYST_SC
4279 c-----------------------------------------------------------------------------
4280       subroutine esc(escloc)
4281 C Calculate the local energy of a side chain and its derivatives in the
4282 C corresponding virtual-bond valence angles THETA and the spherical angles
4283 C ALPHA and OMEGA.
4284       implicit real*8 (a-h,o-z)
4285       include 'DIMENSIONS'
4286       include 'DIMENSIONS.ZSCOPT'
4287       include 'COMMON.GEO'
4288       include 'COMMON.LOCAL'
4289       include 'COMMON.VAR'
4290       include 'COMMON.INTERACT'
4291       include 'COMMON.DERIV'
4292       include 'COMMON.CHAIN'
4293       include 'COMMON.IOUNITS'
4294       include 'COMMON.NAMES'
4295       include 'COMMON.FFIELD'
4296       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4297      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4298       common /sccalc/ time11,time12,time112,theti,it,nlobit
4299       delta=0.02d0*pi
4300       escloc=0.0D0
4301 c     write (iout,'(a)') 'ESC'
4302       do i=loc_start,loc_end
4303         it=itype(i)
4304         if (it.eq.10) goto 1
4305         nlobit=nlob(it)
4306 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4307 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4308         theti=theta(i+1)-pipol
4309         x(1)=dtan(theti)
4310         x(2)=alph(i)
4311         x(3)=omeg(i)
4312 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4313
4314         if (x(2).gt.pi-delta) then
4315           xtemp(1)=x(1)
4316           xtemp(2)=pi-delta
4317           xtemp(3)=x(3)
4318           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4319           xtemp(2)=pi
4320           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4321           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4322      &        escloci,dersc(2))
4323           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4324      &        ddersc0(1),dersc(1))
4325           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4326      &        ddersc0(3),dersc(3))
4327           xtemp(2)=pi-delta
4328           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4329           xtemp(2)=pi
4330           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4331           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4332      &            dersc0(2),esclocbi,dersc02)
4333           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4334      &            dersc12,dersc01)
4335           call splinthet(x(2),0.5d0*delta,ss,ssd)
4336           dersc0(1)=dersc01
4337           dersc0(2)=dersc02
4338           dersc0(3)=0.0d0
4339           do k=1,3
4340             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4341           enddo
4342           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4343 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4344 c    &             esclocbi,ss,ssd
4345           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4346 c         escloci=esclocbi
4347 c         write (iout,*) escloci
4348         else if (x(2).lt.delta) then
4349           xtemp(1)=x(1)
4350           xtemp(2)=delta
4351           xtemp(3)=x(3)
4352           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4353           xtemp(2)=0.0d0
4354           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4355           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4356      &        escloci,dersc(2))
4357           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4358      &        ddersc0(1),dersc(1))
4359           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4360      &        ddersc0(3),dersc(3))
4361           xtemp(2)=delta
4362           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4363           xtemp(2)=0.0d0
4364           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4365           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4366      &            dersc0(2),esclocbi,dersc02)
4367           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4368      &            dersc12,dersc01)
4369           dersc0(1)=dersc01
4370           dersc0(2)=dersc02
4371           dersc0(3)=0.0d0
4372           call splinthet(x(2),0.5d0*delta,ss,ssd)
4373           do k=1,3
4374             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4375           enddo
4376           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4377 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4378 c    &             esclocbi,ss,ssd
4379           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4380 c         write (iout,*) escloci
4381         else
4382           call enesc(x,escloci,dersc,ddummy,.false.)
4383         endif
4384
4385         escloc=escloc+escloci
4386 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4387
4388         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4389      &   wscloc*dersc(1)
4390         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4391         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4392     1   continue
4393       enddo
4394       return
4395       end
4396 C---------------------------------------------------------------------------
4397       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4398       implicit real*8 (a-h,o-z)
4399       include 'DIMENSIONS'
4400       include 'COMMON.GEO'
4401       include 'COMMON.LOCAL'
4402       include 'COMMON.IOUNITS'
4403       common /sccalc/ time11,time12,time112,theti,it,nlobit
4404       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4405       double precision contr(maxlob,-1:1)
4406       logical mixed
4407 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4408         escloc_i=0.0D0
4409         do j=1,3
4410           dersc(j)=0.0D0
4411           if (mixed) ddersc(j)=0.0d0
4412         enddo
4413         x3=x(3)
4414
4415 C Because of periodicity of the dependence of the SC energy in omega we have
4416 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4417 C To avoid underflows, first compute & store the exponents.
4418
4419         do iii=-1,1
4420
4421           x(3)=x3+iii*dwapi
4422
4423           do j=1,nlobit
4424             do k=1,3
4425               z(k)=x(k)-censc(k,j,it)
4426             enddo
4427             do k=1,3
4428               Axk=0.0D0
4429               do l=1,3
4430                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4431               enddo
4432               Ax(k,j,iii)=Axk
4433             enddo
4434             expfac=0.0D0
4435             do k=1,3
4436               expfac=expfac+Ax(k,j,iii)*z(k)
4437             enddo
4438             contr(j,iii)=expfac
4439           enddo ! j
4440
4441         enddo ! iii
4442
4443         x(3)=x3
4444 C As in the case of ebend, we want to avoid underflows in exponentiation and
4445 C subsequent NaNs and INFs in energy calculation.
4446 C Find the largest exponent
4447         emin=contr(1,-1)
4448         do iii=-1,1
4449           do j=1,nlobit
4450             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4451           enddo
4452         enddo
4453         emin=0.5D0*emin
4454 cd      print *,'it=',it,' emin=',emin
4455
4456 C Compute the contribution to SC energy and derivatives
4457         do iii=-1,1
4458
4459           do j=1,nlobit
4460             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4461 cd          print *,'j=',j,' expfac=',expfac
4462             escloc_i=escloc_i+expfac
4463             do k=1,3
4464               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4465             enddo
4466             if (mixed) then
4467               do k=1,3,2
4468                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4469      &            +gaussc(k,2,j,it))*expfac
4470               enddo
4471             endif
4472           enddo
4473
4474         enddo ! iii
4475
4476         dersc(1)=dersc(1)/cos(theti)**2
4477         ddersc(1)=ddersc(1)/cos(theti)**2
4478         ddersc(3)=ddersc(3)
4479
4480         escloci=-(dlog(escloc_i)-emin)
4481         do j=1,3
4482           dersc(j)=dersc(j)/escloc_i
4483         enddo
4484         if (mixed) then
4485           do j=1,3,2
4486             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4487           enddo
4488         endif
4489       return
4490       end
4491 C------------------------------------------------------------------------------
4492       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4493       implicit real*8 (a-h,o-z)
4494       include 'DIMENSIONS'
4495       include 'COMMON.GEO'
4496       include 'COMMON.LOCAL'
4497       include 'COMMON.IOUNITS'
4498       common /sccalc/ time11,time12,time112,theti,it,nlobit
4499       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4500       double precision contr(maxlob)
4501       logical mixed
4502
4503       escloc_i=0.0D0
4504
4505       do j=1,3
4506         dersc(j)=0.0D0
4507       enddo
4508
4509       do j=1,nlobit
4510         do k=1,2
4511           z(k)=x(k)-censc(k,j,it)
4512         enddo
4513         z(3)=dwapi
4514         do k=1,3
4515           Axk=0.0D0
4516           do l=1,3
4517             Axk=Axk+gaussc(l,k,j,it)*z(l)
4518           enddo
4519           Ax(k,j)=Axk
4520         enddo
4521         expfac=0.0D0
4522         do k=1,3
4523           expfac=expfac+Ax(k,j)*z(k)
4524         enddo
4525         contr(j)=expfac
4526       enddo ! j
4527
4528 C As in the case of ebend, we want to avoid underflows in exponentiation and
4529 C subsequent NaNs and INFs in energy calculation.
4530 C Find the largest exponent
4531       emin=contr(1)
4532       do j=1,nlobit
4533         if (emin.gt.contr(j)) emin=contr(j)
4534       enddo
4535       emin=0.5D0*emin
4536
4537 C Compute the contribution to SC energy and derivatives
4538
4539       dersc12=0.0d0
4540       do j=1,nlobit
4541         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4542         escloc_i=escloc_i+expfac
4543         do k=1,2
4544           dersc(k)=dersc(k)+Ax(k,j)*expfac
4545         enddo
4546         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4547      &            +gaussc(1,2,j,it))*expfac
4548         dersc(3)=0.0d0
4549       enddo
4550
4551       dersc(1)=dersc(1)/cos(theti)**2
4552       dersc12=dersc12/cos(theti)**2
4553       escloci=-(dlog(escloc_i)-emin)
4554       do j=1,2
4555         dersc(j)=dersc(j)/escloc_i
4556       enddo
4557       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4558       return
4559       end
4560 #else
4561 c----------------------------------------------------------------------------------
4562       subroutine esc(escloc)
4563 C Calculate the local energy of a side chain and its derivatives in the
4564 C corresponding virtual-bond valence angles THETA and the spherical angles
4565 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4566 C added by Urszula Kozlowska. 07/11/2007
4567 C
4568       implicit real*8 (a-h,o-z)
4569       include 'DIMENSIONS'
4570       include 'DIMENSIONS.ZSCOPT'
4571       include 'DIMENSIONS.FREE'
4572       include 'COMMON.GEO'
4573       include 'COMMON.LOCAL'
4574       include 'COMMON.VAR'
4575       include 'COMMON.SCROT'
4576       include 'COMMON.INTERACT'
4577       include 'COMMON.DERIV'
4578       include 'COMMON.CHAIN'
4579       include 'COMMON.IOUNITS'
4580       include 'COMMON.NAMES'
4581       include 'COMMON.FFIELD'
4582       include 'COMMON.CONTROL'
4583       include 'COMMON.VECTORS'
4584       double precision x_prime(3),y_prime(3),z_prime(3)
4585      &    , sumene,dsc_i,dp2_i,x(65),
4586      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4587      &    de_dxx,de_dyy,de_dzz,de_dt
4588       double precision s1_t,s1_6_t,s2_t,s2_6_t
4589       double precision
4590      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4591      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4592      & dt_dCi(3),dt_dCi1(3)
4593       common /sccalc/ time11,time12,time112,theti,it,nlobit
4594       delta=0.02d0*pi
4595       escloc=0.0D0
4596       do i=loc_start,loc_end
4597         costtab(i+1) =dcos(theta(i+1))
4598         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4599         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4600         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4601         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4602         cosfac=dsqrt(cosfac2)
4603         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4604         sinfac=dsqrt(sinfac2)
4605         it=itype(i)
4606         if (it.eq.10) goto 1
4607 c
4608 C  Compute the axes of tghe local cartesian coordinates system; store in
4609 c   x_prime, y_prime and z_prime
4610 c
4611         do j=1,3
4612           x_prime(j) = 0.00
4613           y_prime(j) = 0.00
4614           z_prime(j) = 0.00
4615         enddo
4616 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4617 C     &   dc_norm(3,i+nres)
4618         do j = 1,3
4619           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4620           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4621         enddo
4622         do j = 1,3
4623           z_prime(j) = -uz(j,i-1)
4624         enddo
4625 c       write (2,*) "i",i
4626 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4627 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4628 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4629 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4630 c      & " xy",scalar(x_prime(1),y_prime(1)),
4631 c      & " xz",scalar(x_prime(1),z_prime(1)),
4632 c      & " yy",scalar(y_prime(1),y_prime(1)),
4633 c      & " yz",scalar(y_prime(1),z_prime(1)),
4634 c      & " zz",scalar(z_prime(1),z_prime(1))
4635 c
4636 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4637 C to local coordinate system. Store in xx, yy, zz.
4638 c
4639         xx=0.0d0
4640         yy=0.0d0
4641         zz=0.0d0
4642         do j = 1,3
4643           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4644           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4645           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4646         enddo
4647
4648         xxtab(i)=xx
4649         yytab(i)=yy
4650         zztab(i)=zz
4651 C
4652 C Compute the energy of the ith side cbain
4653 C
4654 c        write (2,*) "xx",xx," yy",yy," zz",zz
4655         it=itype(i)
4656         do j = 1,65
4657           x(j) = sc_parmin(j,it)
4658         enddo
4659 #ifdef CHECK_COORD
4660 Cc diagnostics - remove later
4661         xx1 = dcos(alph(2))
4662         yy1 = dsin(alph(2))*dcos(omeg(2))
4663         zz1 = -dsin(alph(2))*dsin(omeg(2))
4664         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4665      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4666      &    xx1,yy1,zz1
4667 C,"  --- ", xx_w,yy_w,zz_w
4668 c end diagnostics
4669 #endif
4670         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4671      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4672      &   + x(10)*yy*zz
4673         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4674      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4675      & + x(20)*yy*zz
4676         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4677      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4678      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4679      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4680      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4681      &  +x(40)*xx*yy*zz
4682         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4683      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4684      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4685      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4686      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4687      &  +x(60)*xx*yy*zz
4688         dsc_i   = 0.743d0+x(61)
4689         dp2_i   = 1.9d0+x(62)
4690         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4691      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4692         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4693      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4694         s1=(1+x(63))/(0.1d0 + dscp1)
4695         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4696         s2=(1+x(65))/(0.1d0 + dscp2)
4697         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4698         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4699      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4700 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4701 c     &   sumene4,
4702 c     &   dscp1,dscp2,sumene
4703 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4704         escloc = escloc + sumene
4705 c        write (2,*) "escloc",escloc
4706         if (.not. calc_grad) goto 1
4707
4708 #ifdef DEBUG2
4709 C
4710 C This section to check the numerical derivatives of the energy of ith side
4711 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4712 C #define DEBUG in the code to turn it on.
4713 C
4714         write (2,*) "sumene               =",sumene
4715         aincr=1.0d-7
4716         xxsave=xx
4717         xx=xx+aincr
4718         write (2,*) xx,yy,zz
4719         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4720         de_dxx_num=(sumenep-sumene)/aincr
4721         xx=xxsave
4722         write (2,*) "xx+ sumene from enesc=",sumenep
4723         yysave=yy
4724         yy=yy+aincr
4725         write (2,*) xx,yy,zz
4726         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4727         de_dyy_num=(sumenep-sumene)/aincr
4728         yy=yysave
4729         write (2,*) "yy+ sumene from enesc=",sumenep
4730         zzsave=zz
4731         zz=zz+aincr
4732         write (2,*) xx,yy,zz
4733         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4734         de_dzz_num=(sumenep-sumene)/aincr
4735         zz=zzsave
4736         write (2,*) "zz+ sumene from enesc=",sumenep
4737         costsave=cost2tab(i+1)
4738         sintsave=sint2tab(i+1)
4739         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4740         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4741         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4742         de_dt_num=(sumenep-sumene)/aincr
4743         write (2,*) " t+ sumene from enesc=",sumenep
4744         cost2tab(i+1)=costsave
4745         sint2tab(i+1)=sintsave
4746 C End of diagnostics section.
4747 #endif
4748 C
4749 C Compute the gradient of esc
4750 C
4751         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4752         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4753         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4754         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4755         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4756         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4757         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4758         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4759         pom1=(sumene3*sint2tab(i+1)+sumene1)
4760      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4761         pom2=(sumene4*cost2tab(i+1)+sumene2)
4762      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4763         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4764         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4765      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4766      &  +x(40)*yy*zz
4767         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4768         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4769      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4770      &  +x(60)*yy*zz
4771         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4772      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4773      &        +(pom1+pom2)*pom_dx
4774 #ifdef DEBUG
4775         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4776 #endif
4777 C
4778         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4779         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4780      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4781      &  +x(40)*xx*zz
4782         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4783         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4784      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4785      &  +x(59)*zz**2 +x(60)*xx*zz
4786         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4787      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4788      &        +(pom1-pom2)*pom_dy
4789 #ifdef DEBUG
4790         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4791 #endif
4792 C
4793         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4794      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4795      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4796      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4797      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4798      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4799      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4800      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4801 #ifdef DEBUG
4802         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4803 #endif
4804 C
4805         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4806      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4807      &  +pom1*pom_dt1+pom2*pom_dt2
4808 #ifdef DEBUG
4809         write(2,*), "de_dt = ", de_dt,de_dt_num
4810 #endif
4811 c
4812 C
4813        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4814        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4815        cosfac2xx=cosfac2*xx
4816        sinfac2yy=sinfac2*yy
4817        do k = 1,3
4818          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4819      &      vbld_inv(i+1)
4820          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4821      &      vbld_inv(i)
4822          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4823          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4824 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4825 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4826 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4827 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4828          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4829          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4830          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4831          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4832          dZZ_Ci1(k)=0.0d0
4833          dZZ_Ci(k)=0.0d0
4834          do j=1,3
4835            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4836            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4837          enddo
4838
4839          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4840          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4841          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4842 c
4843          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4844          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4845        enddo
4846
4847        do k=1,3
4848          dXX_Ctab(k,i)=dXX_Ci(k)
4849          dXX_C1tab(k,i)=dXX_Ci1(k)
4850          dYY_Ctab(k,i)=dYY_Ci(k)
4851          dYY_C1tab(k,i)=dYY_Ci1(k)
4852          dZZ_Ctab(k,i)=dZZ_Ci(k)
4853          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4854          dXX_XYZtab(k,i)=dXX_XYZ(k)
4855          dYY_XYZtab(k,i)=dYY_XYZ(k)
4856          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4857        enddo
4858
4859        do k = 1,3
4860 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4861 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4862 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4863 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4864 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4865 c     &    dt_dci(k)
4866 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4867 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4868          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4869      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4870          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4871      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4872          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4873      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4874        enddo
4875 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4876 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4877
4878 C to check gradient call subroutine check_grad
4879
4880     1 continue
4881       enddo
4882       return
4883       end
4884 #endif
4885 c------------------------------------------------------------------------------
4886       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4887 C
4888 C This procedure calculates two-body contact function g(rij) and its derivative:
4889 C
4890 C           eps0ij                                     !       x < -1
4891 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4892 C            0                                         !       x > 1
4893 C
4894 C where x=(rij-r0ij)/delta
4895 C
4896 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4897 C
4898       implicit none
4899       double precision rij,r0ij,eps0ij,fcont,fprimcont
4900       double precision x,x2,x4,delta
4901 c     delta=0.02D0*r0ij
4902 c      delta=0.2D0*r0ij
4903       x=(rij-r0ij)/delta
4904       if (x.lt.-1.0D0) then
4905         fcont=eps0ij
4906         fprimcont=0.0D0
4907       else if (x.le.1.0D0) then
4908         x2=x*x
4909         x4=x2*x2
4910         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4911         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4912       else
4913         fcont=0.0D0
4914         fprimcont=0.0D0
4915       endif
4916       return
4917       end
4918 c------------------------------------------------------------------------------
4919       subroutine splinthet(theti,delta,ss,ssder)
4920       implicit real*8 (a-h,o-z)
4921       include 'DIMENSIONS'
4922       include 'DIMENSIONS.ZSCOPT'
4923       include 'COMMON.VAR'
4924       include 'COMMON.GEO'
4925       thetup=pi-delta
4926       thetlow=delta
4927       if (theti.gt.pipol) then
4928         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4929       else
4930         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4931         ssder=-ssder
4932       endif
4933       return
4934       end
4935 c------------------------------------------------------------------------------
4936       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4937       implicit none
4938       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4939       double precision ksi,ksi2,ksi3,a1,a2,a3
4940       a1=fprim0*delta/(f1-f0)
4941       a2=3.0d0-2.0d0*a1
4942       a3=a1-2.0d0
4943       ksi=(x-x0)/delta
4944       ksi2=ksi*ksi
4945       ksi3=ksi2*ksi
4946       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4947       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4948       return
4949       end
4950 c------------------------------------------------------------------------------
4951       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4952       implicit none
4953       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4954       double precision ksi,ksi2,ksi3,a1,a2,a3
4955       ksi=(x-x0)/delta
4956       ksi2=ksi*ksi
4957       ksi3=ksi2*ksi
4958       a1=fprim0x*delta
4959       a2=3*(f1x-f0x)-2*fprim0x*delta
4960       a3=fprim0x*delta-2*(f1x-f0x)
4961       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4962       return
4963       end
4964 C-----------------------------------------------------------------------------
4965 #ifdef CRYST_TOR
4966 C-----------------------------------------------------------------------------
4967       subroutine etor(etors,edihcnstr,fact)
4968       implicit real*8 (a-h,o-z)
4969       include 'DIMENSIONS'
4970       include 'DIMENSIONS.ZSCOPT'
4971       include 'COMMON.VAR'
4972       include 'COMMON.GEO'
4973       include 'COMMON.LOCAL'
4974       include 'COMMON.TORSION'
4975       include 'COMMON.INTERACT'
4976       include 'COMMON.DERIV'
4977       include 'COMMON.CHAIN'
4978       include 'COMMON.NAMES'
4979       include 'COMMON.IOUNITS'
4980       include 'COMMON.FFIELD'
4981       include 'COMMON.TORCNSTR'
4982       logical lprn
4983 C Set lprn=.true. for debugging
4984       lprn=.false.
4985 c      lprn=.true.
4986       etors=0.0D0
4987       do i=iphi_start,iphi_end
4988         itori=itortyp(itype(i-2))
4989         itori1=itortyp(itype(i-1))
4990         phii=phi(i)
4991         gloci=0.0D0
4992 C Proline-Proline pair is a special case...
4993         if (itori.eq.3 .and. itori1.eq.3) then
4994           if (phii.gt.-dwapi3) then
4995             cosphi=dcos(3*phii)
4996             fac=1.0D0/(1.0D0-cosphi)
4997             etorsi=v1(1,3,3)*fac
4998             etorsi=etorsi+etorsi
4999             etors=etors+etorsi-v1(1,3,3)
5000             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5001           endif
5002           do j=1,3
5003             v1ij=v1(j+1,itori,itori1)
5004             v2ij=v2(j+1,itori,itori1)
5005             cosphi=dcos(j*phii)
5006             sinphi=dsin(j*phii)
5007             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5008             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5009           enddo
5010         else
5011           do j=1,nterm_old
5012             v1ij=v1(j,itori,itori1)
5013             v2ij=v2(j,itori,itori1)
5014             cosphi=dcos(j*phii)
5015             sinphi=dsin(j*phii)
5016             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5017             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5018           enddo
5019         endif
5020         if (lprn)
5021      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5022      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5023      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5024         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5025 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5026       enddo
5027 ! 6/20/98 - dihedral angle constraints
5028       edihcnstr=0.0d0
5029       do i=1,ndih_constr
5030         itori=idih_constr(i)
5031         phii=phi(itori)
5032         difi=phii-phi0(i)
5033         if (difi.gt.drange(i)) then
5034           difi=difi-drange(i)
5035           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5036           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5037         else if (difi.lt.-drange(i)) then
5038           difi=difi+drange(i)
5039           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5040           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5041         endif
5042 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5043 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5044       enddo
5045 !      write (iout,*) 'edihcnstr',edihcnstr
5046       return
5047       end
5048 c------------------------------------------------------------------------------
5049 #else
5050       subroutine etor(etors,edihcnstr,fact)
5051       implicit real*8 (a-h,o-z)
5052       include 'DIMENSIONS'
5053       include 'DIMENSIONS.ZSCOPT'
5054       include 'COMMON.VAR'
5055       include 'COMMON.GEO'
5056       include 'COMMON.LOCAL'
5057       include 'COMMON.TORSION'
5058       include 'COMMON.INTERACT'
5059       include 'COMMON.DERIV'
5060       include 'COMMON.CHAIN'
5061       include 'COMMON.NAMES'
5062       include 'COMMON.IOUNITS'
5063       include 'COMMON.FFIELD'
5064       include 'COMMON.TORCNSTR'
5065       logical lprn
5066 C Set lprn=.true. for debugging
5067       lprn=.false.
5068 c      lprn=.true.
5069       etors=0.0D0
5070       do i=iphi_start,iphi_end
5071         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5072         itori=itortyp(itype(i-2))
5073         itori1=itortyp(itype(i-1))
5074         phii=phi(i)
5075         gloci=0.0D0
5076 C Regular cosine and sine terms
5077         do j=1,nterm(itori,itori1)
5078           v1ij=v1(j,itori,itori1)
5079           v2ij=v2(j,itori,itori1)
5080           cosphi=dcos(j*phii)
5081           sinphi=dsin(j*phii)
5082           etors=etors+v1ij*cosphi+v2ij*sinphi
5083           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5084         enddo
5085 C Lorentz terms
5086 C                         v1
5087 C  E = SUM ----------------------------------- - v1
5088 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5089 C
5090         cosphi=dcos(0.5d0*phii)
5091         sinphi=dsin(0.5d0*phii)
5092         do j=1,nlor(itori,itori1)
5093           vl1ij=vlor1(j,itori,itori1)
5094           vl2ij=vlor2(j,itori,itori1)
5095           vl3ij=vlor3(j,itori,itori1)
5096           pom=vl2ij*cosphi+vl3ij*sinphi
5097           pom1=1.0d0/(pom*pom+1.0d0)
5098           etors=etors+vl1ij*pom1
5099           pom=-pom*pom1*pom1
5100           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5101         enddo
5102 C Subtract the constant term
5103         etors=etors-v0(itori,itori1)
5104         if (lprn)
5105      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5106      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5107      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5108         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5109 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5110  1215   continue
5111       enddo
5112 ! 6/20/98 - dihedral angle constraints
5113       edihcnstr=0.0d0
5114       do i=1,ndih_constr
5115         itori=idih_constr(i)
5116         phii=phi(itori)
5117         difi=pinorm(phii-phi0(i))
5118         edihi=0.0d0
5119         if (difi.gt.drange(i)) then
5120           difi=difi-drange(i)
5121           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5122           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5123           edihi=0.25d0*ftors*difi**4
5124         else if (difi.lt.-drange(i)) then
5125           difi=difi+drange(i)
5126           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5127           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5128           edihi=0.25d0*ftors*difi**4
5129         else
5130           difi=0.0d0
5131         endif
5132 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5133 c     &    drange(i),edihi
5134 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5135 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5136       enddo
5137 !      write (iout,*) 'edihcnstr',edihcnstr
5138       return
5139       end
5140 c----------------------------------------------------------------------------
5141       subroutine etor_d(etors_d,fact2)
5142 C 6/23/01 Compute double torsional energy
5143       implicit real*8 (a-h,o-z)
5144       include 'DIMENSIONS'
5145       include 'DIMENSIONS.ZSCOPT'
5146       include 'COMMON.VAR'
5147       include 'COMMON.GEO'
5148       include 'COMMON.LOCAL'
5149       include 'COMMON.TORSION'
5150       include 'COMMON.INTERACT'
5151       include 'COMMON.DERIV'
5152       include 'COMMON.CHAIN'
5153       include 'COMMON.NAMES'
5154       include 'COMMON.IOUNITS'
5155       include 'COMMON.FFIELD'
5156       include 'COMMON.TORCNSTR'
5157       logical lprn
5158 C Set lprn=.true. for debugging
5159       lprn=.false.
5160 c     lprn=.true.
5161       etors_d=0.0D0
5162       do i=iphi_start,iphi_end-1
5163         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5164      &     goto 1215
5165         itori=itortyp(itype(i-2))
5166         itori1=itortyp(itype(i-1))
5167         itori2=itortyp(itype(i))
5168         phii=phi(i)
5169         phii1=phi(i+1)
5170         gloci1=0.0D0
5171         gloci2=0.0D0
5172 C Regular cosine and sine terms
5173         do j=1,ntermd_1(itori,itori1,itori2)
5174           v1cij=v1c(1,j,itori,itori1,itori2)
5175           v1sij=v1s(1,j,itori,itori1,itori2)
5176           v2cij=v1c(2,j,itori,itori1,itori2)
5177           v2sij=v1s(2,j,itori,itori1,itori2)
5178           cosphi1=dcos(j*phii)
5179           sinphi1=dsin(j*phii)
5180           cosphi2=dcos(j*phii1)
5181           sinphi2=dsin(j*phii1)
5182           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5183      &     v2cij*cosphi2+v2sij*sinphi2
5184           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5185           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5186         enddo
5187         do k=2,ntermd_2(itori,itori1,itori2)
5188           do l=1,k-1
5189             v1cdij = v2c(k,l,itori,itori1,itori2)
5190             v2cdij = v2c(l,k,itori,itori1,itori2)
5191             v1sdij = v2s(k,l,itori,itori1,itori2)
5192             v2sdij = v2s(l,k,itori,itori1,itori2)
5193             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5194             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5195             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5196             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5197             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5198      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5199             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5200      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5201             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5202      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5203           enddo
5204         enddo
5205         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5206         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5207  1215   continue
5208       enddo
5209       return
5210       end
5211 #endif
5212 c------------------------------------------------------------------------------
5213       subroutine eback_sc_corr(esccor)
5214 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5215 c        conformational states; temporarily implemented as differences
5216 c        between UNRES torsional potentials (dependent on three types of
5217 c        residues) and the torsional potentials dependent on all 20 types
5218 c        of residues computed from AM1 energy surfaces of terminally-blocked
5219 c        amino-acid residues.
5220       implicit real*8 (a-h,o-z)
5221       include 'DIMENSIONS'
5222       include 'DIMENSIONS.ZSCOPT'
5223       include 'DIMENSIONS.FREE'
5224       include 'COMMON.VAR'
5225       include 'COMMON.GEO'
5226       include 'COMMON.LOCAL'
5227       include 'COMMON.TORSION'
5228       include 'COMMON.SCCOR'
5229       include 'COMMON.INTERACT'
5230       include 'COMMON.DERIV'
5231       include 'COMMON.CHAIN'
5232       include 'COMMON.NAMES'
5233       include 'COMMON.IOUNITS'
5234       include 'COMMON.FFIELD'
5235       include 'COMMON.CONTROL'
5236       logical lprn
5237 C Set lprn=.true. for debugging
5238       lprn=.false.
5239 c      lprn=.true.
5240 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5241       esccor=0.0D0
5242       do i=itau_start,itau_end
5243         esccor_ii=0.0D0
5244         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5245         isccori=isccortyp(itype(i-2))
5246         isccori1=isccortyp(itype(i-1))
5247         phii=phi(i)
5248 cccc  Added 9 May 2012
5249 cc Tauangle is torsional engle depending on the value of first digit
5250 c(see comment below)
5251 cc Omicron is flat angle depending on the value of first digit
5252 c(see comment below)
5253
5254
5255         do intertyp=1,3 !intertyp
5256 cc Added 09 May 2012 (Adasko)
5257 cc  Intertyp means interaction type of backbone mainchain correlation:
5258 c   1 = SC...Ca...Ca...Ca
5259 c   2 = Ca...Ca...Ca...SC
5260 c   3 = SC...Ca...Ca...SCi
5261         gloci=0.0D0
5262         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5263      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5264      &      (itype(i-1).eq.21)))
5265      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5266      &     .or.(itype(i-2).eq.21)))
5267      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5268      &      (itype(i-1).eq.21)))) cycle
5269         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5270         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5271      & cycle
5272         do j=1,nterm_sccor(isccori,isccori1)
5273           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5274           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5275           cosphi=dcos(j*tauangle(intertyp,i))
5276           sinphi=dsin(j*tauangle(intertyp,i))
5277           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5278 #ifdef DEBUG
5279           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5280 #endif
5281           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5282         enddo
5283         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5284 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5285 c     &gloc_sc(intertyp,i-3,icg)
5286         if (lprn)
5287      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5288      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5289      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5290      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5291         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5292        enddo !intertyp
5293 #ifdef DEBUG
5294        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5295 #endif
5296       enddo
5297 c        do i=1,nres
5298 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5299 c        enddo
5300       return
5301       end
5302 c------------------------------------------------------------------------------
5303       subroutine multibody(ecorr)
5304 C This subroutine calculates multi-body contributions to energy following
5305 C the idea of Skolnick et al. If side chains I and J make a contact and
5306 C at the same time side chains I+1 and J+1 make a contact, an extra
5307 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5308       implicit real*8 (a-h,o-z)
5309       include 'DIMENSIONS'
5310       include 'COMMON.IOUNITS'
5311       include 'COMMON.DERIV'
5312       include 'COMMON.INTERACT'
5313       include 'COMMON.CONTACTS'
5314       double precision gx(3),gx1(3)
5315       logical lprn
5316
5317 C Set lprn=.true. for debugging
5318       lprn=.false.
5319
5320       if (lprn) then
5321         write (iout,'(a)') 'Contact function values:'
5322         do i=nnt,nct-2
5323           write (iout,'(i2,20(1x,i2,f10.5))')
5324      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5325         enddo
5326       endif
5327       ecorr=0.0D0
5328       do i=nnt,nct
5329         do j=1,3
5330           gradcorr(j,i)=0.0D0
5331           gradxorr(j,i)=0.0D0
5332         enddo
5333       enddo
5334       do i=nnt,nct-2
5335
5336         DO ISHIFT = 3,4
5337
5338         i1=i+ishift
5339         num_conti=num_cont(i)
5340         num_conti1=num_cont(i1)
5341         do jj=1,num_conti
5342           j=jcont(jj,i)
5343           do kk=1,num_conti1
5344             j1=jcont(kk,i1)
5345             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5346 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5347 cd   &                   ' ishift=',ishift
5348 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5349 C The system gains extra energy.
5350               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5351             endif   ! j1==j+-ishift
5352           enddo     ! kk
5353         enddo       ! jj
5354
5355         ENDDO ! ISHIFT
5356
5357       enddo         ! i
5358       return
5359       end
5360 c------------------------------------------------------------------------------
5361       double precision function esccorr(i,j,k,l,jj,kk)
5362       implicit real*8 (a-h,o-z)
5363       include 'DIMENSIONS'
5364       include 'COMMON.IOUNITS'
5365       include 'COMMON.DERIV'
5366       include 'COMMON.INTERACT'
5367       include 'COMMON.CONTACTS'
5368       double precision gx(3),gx1(3)
5369       logical lprn
5370       lprn=.false.
5371       eij=facont(jj,i)
5372       ekl=facont(kk,k)
5373 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5374 C Calculate the multi-body contribution to energy.
5375 C Calculate multi-body contributions to the gradient.
5376 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5377 cd   & k,l,(gacont(m,kk,k),m=1,3)
5378       do m=1,3
5379         gx(m) =ekl*gacont(m,jj,i)
5380         gx1(m)=eij*gacont(m,kk,k)
5381         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5382         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5383         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5384         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5385       enddo
5386       do m=i,j-1
5387         do ll=1,3
5388           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5389         enddo
5390       enddo
5391       do m=k,l-1
5392         do ll=1,3
5393           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5394         enddo
5395       enddo
5396       esccorr=-eij*ekl
5397       return
5398       end
5399 c------------------------------------------------------------------------------
5400 #ifdef MPL
5401       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5402       implicit real*8 (a-h,o-z)
5403       include 'DIMENSIONS'
5404       integer dimen1,dimen2,atom,indx
5405       double precision buffer(dimen1,dimen2)
5406       double precision zapas
5407       common /contacts_hb/ zapas(3,20,maxres,7),
5408      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5409      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5410       num_kont=num_cont_hb(atom)
5411       do i=1,num_kont
5412         do k=1,7
5413           do j=1,3
5414             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5415           enddo ! j
5416         enddo ! k
5417         buffer(i,indx+22)=facont_hb(i,atom)
5418         buffer(i,indx+23)=ees0p(i,atom)
5419         buffer(i,indx+24)=ees0m(i,atom)
5420         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5421       enddo ! i
5422       buffer(1,indx+26)=dfloat(num_kont)
5423       return
5424       end
5425 c------------------------------------------------------------------------------
5426       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5427       implicit real*8 (a-h,o-z)
5428       include 'DIMENSIONS'
5429       integer dimen1,dimen2,atom,indx
5430       double precision buffer(dimen1,dimen2)
5431       double precision zapas
5432       common /contacts_hb/ zapas(3,20,maxres,7),
5433      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5434      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5435       num_kont=buffer(1,indx+26)
5436       num_kont_old=num_cont_hb(atom)
5437       num_cont_hb(atom)=num_kont+num_kont_old
5438       do i=1,num_kont
5439         ii=i+num_kont_old
5440         do k=1,7
5441           do j=1,3
5442             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5443           enddo ! j
5444         enddo ! k
5445         facont_hb(ii,atom)=buffer(i,indx+22)
5446         ees0p(ii,atom)=buffer(i,indx+23)
5447         ees0m(ii,atom)=buffer(i,indx+24)
5448         jcont_hb(ii,atom)=buffer(i,indx+25)
5449       enddo ! i
5450       return
5451       end
5452 c------------------------------------------------------------------------------
5453 #endif
5454       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5455 C This subroutine calculates multi-body contributions to hydrogen-bonding
5456       implicit real*8 (a-h,o-z)
5457       include 'DIMENSIONS'
5458       include 'DIMENSIONS.ZSCOPT'
5459       include 'COMMON.IOUNITS'
5460 #ifdef MPL
5461       include 'COMMON.INFO'
5462 #endif
5463       include 'COMMON.FFIELD'
5464       include 'COMMON.DERIV'
5465       include 'COMMON.INTERACT'
5466       include 'COMMON.CONTACTS'
5467 #ifdef MPL
5468       parameter (max_cont=maxconts)
5469       parameter (max_dim=2*(8*3+2))
5470       parameter (msglen1=max_cont*max_dim*4)
5471       parameter (msglen2=2*msglen1)
5472       integer source,CorrelType,CorrelID,Error
5473       double precision buffer(max_cont,max_dim)
5474 #endif
5475       double precision gx(3),gx1(3)
5476       logical lprn,ldone
5477
5478 C Set lprn=.true. for debugging
5479       lprn=.false.
5480 #ifdef MPL
5481       n_corr=0
5482       n_corr1=0
5483       if (fgProcs.le.1) goto 30
5484       if (lprn) then
5485         write (iout,'(a)') 'Contact function values:'
5486         do i=nnt,nct-2
5487           write (iout,'(2i3,50(1x,i2,f5.2))')
5488      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5489      &    j=1,num_cont_hb(i))
5490         enddo
5491       endif
5492 C Caution! Following code assumes that electrostatic interactions concerning
5493 C a given atom are split among at most two processors!
5494       CorrelType=477
5495       CorrelID=MyID+1
5496       ldone=.false.
5497       do i=1,max_cont
5498         do j=1,max_dim
5499           buffer(i,j)=0.0D0
5500         enddo
5501       enddo
5502       mm=mod(MyRank,2)
5503 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5504       if (mm) 20,20,10
5505    10 continue
5506 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5507       if (MyRank.gt.0) then
5508 C Send correlation contributions to the preceding processor
5509         msglen=msglen1
5510         nn=num_cont_hb(iatel_s)
5511         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5512 cd      write (iout,*) 'The BUFFER array:'
5513 cd      do i=1,nn
5514 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5515 cd      enddo
5516         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5517           msglen=msglen2
5518             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5519 C Clear the contacts of the atom passed to the neighboring processor
5520         nn=num_cont_hb(iatel_s+1)
5521 cd      do i=1,nn
5522 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5523 cd      enddo
5524             num_cont_hb(iatel_s)=0
5525         endif
5526 cd      write (iout,*) 'Processor ',MyID,MyRank,
5527 cd   & ' is sending correlation contribution to processor',MyID-1,
5528 cd   & ' msglen=',msglen
5529 cd      write (*,*) 'Processor ',MyID,MyRank,
5530 cd   & ' is sending correlation contribution to processor',MyID-1,
5531 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5532         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5533 cd      write (iout,*) 'Processor ',MyID,
5534 cd   & ' has sent correlation contribution to processor',MyID-1,
5535 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5536 cd      write (*,*) 'Processor ',MyID,
5537 cd   & ' has sent correlation contribution to processor',MyID-1,
5538 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5539         msglen=msglen1
5540       endif ! (MyRank.gt.0)
5541       if (ldone) goto 30
5542       ldone=.true.
5543    20 continue
5544 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5545       if (MyRank.lt.fgProcs-1) then
5546 C Receive correlation contributions from the next processor
5547         msglen=msglen1
5548         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5549 cd      write (iout,*) 'Processor',MyID,
5550 cd   & ' is receiving correlation contribution from processor',MyID+1,
5551 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5552 cd      write (*,*) 'Processor',MyID,
5553 cd   & ' is receiving correlation contribution from processor',MyID+1,
5554 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5555         nbytes=-1
5556         do while (nbytes.le.0)
5557           call mp_probe(MyID+1,CorrelType,nbytes)
5558         enddo
5559 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5560         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5561 cd      write (iout,*) 'Processor',MyID,
5562 cd   & ' has received correlation contribution from processor',MyID+1,
5563 cd   & ' msglen=',msglen,' nbytes=',nbytes
5564 cd      write (iout,*) 'The received BUFFER array:'
5565 cd      do i=1,max_cont
5566 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5567 cd      enddo
5568         if (msglen.eq.msglen1) then
5569           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5570         else if (msglen.eq.msglen2)  then
5571           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5572           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5573         else
5574           write (iout,*)
5575      & 'ERROR!!!! message length changed while processing correlations.'
5576           write (*,*)
5577      & 'ERROR!!!! message length changed while processing correlations.'
5578           call mp_stopall(Error)
5579         endif ! msglen.eq.msglen1
5580       endif ! MyRank.lt.fgProcs-1
5581       if (ldone) goto 30
5582       ldone=.true.
5583       goto 10
5584    30 continue
5585 #endif
5586       if (lprn) then
5587         write (iout,'(a)') 'Contact function values:'
5588         do i=nnt,nct-2
5589           write (iout,'(2i3,50(1x,i2,f5.2))')
5590      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5591      &    j=1,num_cont_hb(i))
5592         enddo
5593       endif
5594       ecorr=0.0D0
5595 C Remove the loop below after debugging !!!
5596       do i=nnt,nct
5597         do j=1,3
5598           gradcorr(j,i)=0.0D0
5599           gradxorr(j,i)=0.0D0
5600         enddo
5601       enddo
5602 C Calculate the local-electrostatic correlation terms
5603       do i=iatel_s,iatel_e+1
5604         i1=i+1
5605         num_conti=num_cont_hb(i)
5606         num_conti1=num_cont_hb(i+1)
5607         do jj=1,num_conti
5608           j=jcont_hb(jj,i)
5609           do kk=1,num_conti1
5610             j1=jcont_hb(kk,i1)
5611 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5612 c     &         ' jj=',jj,' kk=',kk
5613             if (j1.eq.j+1 .or. j1.eq.j-1) then
5614 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5615 C The system gains extra energy.
5616               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5617 #ifdef DEBUG
5618               write (iout,*) "ecorr",i,j,i+1,j1,
5619      &               ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5620 #endif
5621               n_corr=n_corr+1
5622             else if (j1.eq.j) then
5623 C Contacts I-J and I-(J+1) occur simultaneously.
5624 C The system loses extra energy.
5625 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5626             endif
5627           enddo ! kk
5628           do kk=1,num_conti
5629             j1=jcont_hb(kk,i)
5630 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5631 c    &         ' jj=',jj,' kk=',kk
5632             if (j1.eq.j+1) then
5633 C Contacts I-J and (I+1)-J occur simultaneously.
5634 C The system loses extra energy.
5635 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5636             endif ! j1==j+1
5637           enddo ! kk
5638         enddo ! jj
5639       enddo ! i
5640       return
5641       end
5642 c------------------------------------------------------------------------------
5643       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5644      &  n_corr1)
5645 C This subroutine calculates multi-body contributions to hydrogen-bonding
5646       implicit real*8 (a-h,o-z)
5647       include 'DIMENSIONS'
5648       include 'DIMENSIONS.ZSCOPT'
5649       include 'COMMON.IOUNITS'
5650 #ifdef MPL
5651       include 'COMMON.INFO'
5652 #endif
5653       include 'COMMON.FFIELD'
5654       include 'COMMON.DERIV'
5655       include 'COMMON.INTERACT'
5656       include 'COMMON.CONTACTS'
5657 #ifdef MPL
5658       parameter (max_cont=maxconts)
5659       parameter (max_dim=2*(8*3+2))
5660       parameter (msglen1=max_cont*max_dim*4)
5661       parameter (msglen2=2*msglen1)
5662       integer source,CorrelType,CorrelID,Error
5663       double precision buffer(max_cont,max_dim)
5664 #endif
5665       double precision gx(3),gx1(3)
5666       logical lprn,ldone
5667
5668 C Set lprn=.true. for debugging
5669       lprn=.false.
5670       eturn6=0.0d0
5671 #ifdef MPL
5672       n_corr=0
5673       n_corr1=0
5674       if (fgProcs.le.1) goto 30
5675       if (lprn) then
5676         write (iout,'(a)') 'Contact function values:'
5677         do i=nnt,nct-2
5678           write (iout,'(2i3,50(1x,i2,f5.2))')
5679      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5680      &    j=1,num_cont_hb(i))
5681         enddo
5682       endif
5683 C Caution! Following code assumes that electrostatic interactions concerning
5684 C a given atom are split among at most two processors!
5685       CorrelType=477
5686       CorrelID=MyID+1
5687       ldone=.false.
5688       do i=1,max_cont
5689         do j=1,max_dim
5690           buffer(i,j)=0.0D0
5691         enddo
5692       enddo
5693       mm=mod(MyRank,2)
5694 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5695       if (mm) 20,20,10
5696    10 continue
5697 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5698       if (MyRank.gt.0) then
5699 C Send correlation contributions to the preceding processor
5700         msglen=msglen1
5701         nn=num_cont_hb(iatel_s)
5702         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5703 cd      write (iout,*) 'The BUFFER array:'
5704 cd      do i=1,nn
5705 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5706 cd      enddo
5707         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5708           msglen=msglen2
5709             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5710 C Clear the contacts of the atom passed to the neighboring processor
5711         nn=num_cont_hb(iatel_s+1)
5712 cd      do i=1,nn
5713 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5714 cd      enddo
5715             num_cont_hb(iatel_s)=0
5716         endif
5717 cd      write (iout,*) 'Processor ',MyID,MyRank,
5718 cd   & ' is sending correlation contribution to processor',MyID-1,
5719 cd   & ' msglen=',msglen
5720 cd      write (*,*) 'Processor ',MyID,MyRank,
5721 cd   & ' is sending correlation contribution to processor',MyID-1,
5722 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5723         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5724 cd      write (iout,*) 'Processor ',MyID,
5725 cd   & ' has sent correlation contribution to processor',MyID-1,
5726 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5727 cd      write (*,*) 'Processor ',MyID,
5728 cd   & ' has sent correlation contribution to processor',MyID-1,
5729 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5730         msglen=msglen1
5731       endif ! (MyRank.gt.0)
5732       if (ldone) goto 30
5733       ldone=.true.
5734    20 continue
5735 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5736       if (MyRank.lt.fgProcs-1) then
5737 C Receive correlation contributions from the next processor
5738         msglen=msglen1
5739         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5740 cd      write (iout,*) 'Processor',MyID,
5741 cd   & ' is receiving correlation contribution from processor',MyID+1,
5742 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5743 cd      write (*,*) 'Processor',MyID,
5744 cd   & ' is receiving correlation contribution from processor',MyID+1,
5745 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5746         nbytes=-1
5747         do while (nbytes.le.0)
5748           call mp_probe(MyID+1,CorrelType,nbytes)
5749         enddo
5750 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5751         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5752 cd      write (iout,*) 'Processor',MyID,
5753 cd   & ' has received correlation contribution from processor',MyID+1,
5754 cd   & ' msglen=',msglen,' nbytes=',nbytes
5755 cd      write (iout,*) 'The received BUFFER array:'
5756 cd      do i=1,max_cont
5757 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5758 cd      enddo
5759         if (msglen.eq.msglen1) then
5760           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5761         else if (msglen.eq.msglen2)  then
5762           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5763           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5764         else
5765           write (iout,*)
5766      & 'ERROR!!!! message length changed while processing correlations.'
5767           write (*,*)
5768      & 'ERROR!!!! message length changed while processing correlations.'
5769           call mp_stopall(Error)
5770         endif ! msglen.eq.msglen1
5771       endif ! MyRank.lt.fgProcs-1
5772       if (ldone) goto 30
5773       ldone=.true.
5774       goto 10
5775    30 continue
5776 #endif
5777       if (lprn) then
5778         write (iout,'(a)') 'Contact function values:'
5779         do i=nnt,nct-2
5780           write (iout,'(2i3,50(1x,i2,f5.2))')
5781      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5782      &    j=1,num_cont_hb(i))
5783         enddo
5784       endif
5785       ecorr=0.0D0
5786       ecorr5=0.0d0
5787       ecorr6=0.0d0
5788 C Remove the loop below after debugging !!!
5789       do i=nnt,nct
5790         do j=1,3
5791           gradcorr(j,i)=0.0D0
5792           gradxorr(j,i)=0.0D0
5793         enddo
5794       enddo
5795 C Calculate the dipole-dipole interaction energies
5796       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5797       do i=iatel_s,iatel_e+1
5798         num_conti=num_cont_hb(i)
5799         do jj=1,num_conti
5800           j=jcont_hb(jj,i)
5801           call dipole(i,j,jj)
5802         enddo
5803       enddo
5804       endif
5805 C Calculate the local-electrostatic correlation terms
5806       do i=iatel_s,iatel_e+1
5807         i1=i+1
5808         num_conti=num_cont_hb(i)
5809         num_conti1=num_cont_hb(i+1)
5810         do jj=1,num_conti
5811           j=jcont_hb(jj,i)
5812           do kk=1,num_conti1
5813             j1=jcont_hb(kk,i1)
5814 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5815 c     &         ' jj=',jj,' kk=',kk
5816             if (j1.eq.j+1 .or. j1.eq.j-1) then
5817 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5818 C The system gains extra energy.
5819               n_corr=n_corr+1
5820               sqd1=dsqrt(d_cont(jj,i))
5821               sqd2=dsqrt(d_cont(kk,i1))
5822               sred_geom = sqd1*sqd2
5823               IF (sred_geom.lt.cutoff_corr) THEN
5824                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5825      &            ekont,fprimcont)
5826 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5827 c     &         ' jj=',jj,' kk=',kk
5828                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5829                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5830                 do l=1,3
5831                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5832                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5833                 enddo
5834                 n_corr1=n_corr1+1
5835 cd               write (iout,*) 'sred_geom=',sred_geom,
5836 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5837                 call calc_eello(i,j,i+1,j1,jj,kk)
5838                 if (wcorr4.gt.0.0d0)
5839      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5840                 if (wcorr5.gt.0.0d0)
5841      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5842 c                print *,"wcorr5",ecorr5
5843 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5844 cd                write(2,*)'ijkl',i,j,i+1,j1
5845                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5846      &               .or. wturn6.eq.0.0d0))then
5847 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5848                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5849 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5850 cd     &            'ecorr6=',ecorr6
5851 cd                write (iout,'(4e15.5)') sred_geom,
5852 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5853 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5854 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5855                 else if (wturn6.gt.0.0d0
5856      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5857 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5858                   eturn6=eturn6+eello_turn6(i,jj,kk)
5859 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5860                 endif
5861               ENDIF
5862 1111          continue
5863             else if (j1.eq.j) then
5864 C Contacts I-J and I-(J+1) occur simultaneously.
5865 C The system loses extra energy.
5866 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5867             endif
5868           enddo ! kk
5869           do kk=1,num_conti
5870             j1=jcont_hb(kk,i)
5871 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5872 c    &         ' jj=',jj,' kk=',kk
5873             if (j1.eq.j+1) then
5874 C Contacts I-J and (I+1)-J occur simultaneously.
5875 C The system loses extra energy.
5876 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5877             endif ! j1==j+1
5878           enddo ! kk
5879         enddo ! jj
5880       enddo ! i
5881       return
5882       end
5883 c------------------------------------------------------------------------------
5884       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5885       implicit real*8 (a-h,o-z)
5886       include 'DIMENSIONS'
5887       include 'COMMON.IOUNITS'
5888       include 'COMMON.DERIV'
5889       include 'COMMON.INTERACT'
5890       include 'COMMON.CONTACTS'
5891       double precision gx(3),gx1(3)
5892       logical lprn
5893       lprn=.false.
5894       eij=facont_hb(jj,i)
5895       ekl=facont_hb(kk,k)
5896       ees0pij=ees0p(jj,i)
5897       ees0pkl=ees0p(kk,k)
5898       ees0mij=ees0m(jj,i)
5899       ees0mkl=ees0m(kk,k)
5900       ekont=eij*ekl
5901       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5902 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5903 C Following 4 lines for diagnostics.
5904 cd    ees0pkl=0.0D0
5905 cd    ees0pij=1.0D0
5906 cd    ees0mkl=0.0D0
5907 cd    ees0mij=1.0D0
5908 cd      write (iout,*)'Contacts have occurred for peptide groups',i,j,
5909 cd     &   ' and',k,l
5910 cd      write (iout,*)'Contacts have occurred for peptide groups',
5911 cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5912 cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5913 C Calculate the multi-body contribution to energy.
5914       ecorr=ecorr+ekont*ees
5915       if (calc_grad) then
5916 C Calculate multi-body contributions to the gradient.
5917       do ll=1,3
5918         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5919         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5920      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5921      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5922         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5923      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5924      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5925         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5926         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5927      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5928      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5929         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5930      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5931      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5932       enddo
5933       do m=i+1,j-1
5934         do ll=1,3
5935           gradcorr(ll,m)=gradcorr(ll,m)+
5936      &     ees*ekl*gacont_hbr(ll,jj,i)-
5937      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5938      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5939         enddo
5940       enddo
5941       do m=k+1,l-1
5942         do ll=1,3
5943           gradcorr(ll,m)=gradcorr(ll,m)+
5944      &     ees*eij*gacont_hbr(ll,kk,k)-
5945      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5946      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5947         enddo
5948       enddo
5949       endif
5950       ehbcorr=ekont*ees
5951       return
5952       end
5953 C---------------------------------------------------------------------------
5954       subroutine dipole(i,j,jj)
5955       implicit real*8 (a-h,o-z)
5956       include 'DIMENSIONS'
5957       include 'DIMENSIONS.ZSCOPT'
5958       include 'COMMON.IOUNITS'
5959       include 'COMMON.CHAIN'
5960       include 'COMMON.FFIELD'
5961       include 'COMMON.DERIV'
5962       include 'COMMON.INTERACT'
5963       include 'COMMON.CONTACTS'
5964       include 'COMMON.TORSION'
5965       include 'COMMON.VAR'
5966       include 'COMMON.GEO'
5967       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5968      &  auxmat(2,2)
5969       iti1 = itortyp(itype(i+1))
5970       if (j.lt.nres-1) then
5971         itj1 = itortyp(itype(j+1))
5972       else
5973         itj1=ntortyp+1
5974       endif
5975       do iii=1,2
5976         dipi(iii,1)=Ub2(iii,i)
5977         dipderi(iii)=Ub2der(iii,i)
5978         dipi(iii,2)=b1(iii,iti1)
5979         dipj(iii,1)=Ub2(iii,j)
5980         dipderj(iii)=Ub2der(iii,j)
5981         dipj(iii,2)=b1(iii,itj1)
5982       enddo
5983       kkk=0
5984       do iii=1,2
5985         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5986         do jjj=1,2
5987           kkk=kkk+1
5988           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5989         enddo
5990       enddo
5991       if (.not.calc_grad) return
5992       do kkk=1,5
5993         do lll=1,3
5994           mmm=0
5995           do iii=1,2
5996             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5997      &        auxvec(1))
5998             do jjj=1,2
5999               mmm=mmm+1
6000               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6001             enddo
6002           enddo
6003         enddo
6004       enddo
6005       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6006       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6007       do iii=1,2
6008         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6009       enddo
6010       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6011       do iii=1,2
6012         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6013       enddo
6014       return
6015       end
6016 C---------------------------------------------------------------------------
6017       subroutine calc_eello(i,j,k,l,jj,kk)
6018 C
6019 C This subroutine computes matrices and vectors needed to calculate
6020 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6021 C
6022       implicit real*8 (a-h,o-z)
6023       include 'DIMENSIONS'
6024       include 'DIMENSIONS.ZSCOPT'
6025       include 'COMMON.IOUNITS'
6026       include 'COMMON.CHAIN'
6027       include 'COMMON.DERIV'
6028       include 'COMMON.INTERACT'
6029       include 'COMMON.CONTACTS'
6030       include 'COMMON.TORSION'
6031       include 'COMMON.VAR'
6032       include 'COMMON.GEO'
6033       include 'COMMON.FFIELD'
6034       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6035      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6036       logical lprn
6037       common /kutas/ lprn
6038 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6039 cd     & ' jj=',jj,' kk=',kk
6040 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6041       do iii=1,2
6042         do jjj=1,2
6043           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6044           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6045         enddo
6046       enddo
6047       call transpose2(aa1(1,1),aa1t(1,1))
6048       call transpose2(aa2(1,1),aa2t(1,1))
6049       do kkk=1,5
6050         do lll=1,3
6051           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6052      &      aa1tder(1,1,lll,kkk))
6053           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6054      &      aa2tder(1,1,lll,kkk))
6055         enddo
6056       enddo
6057       if (l.eq.j+1) then
6058 C parallel orientation of the two CA-CA-CA frames.
6059         if (i.gt.1) then
6060           iti=itortyp(itype(i))
6061         else
6062           iti=ntortyp+1
6063         endif
6064         itk1=itortyp(itype(k+1))
6065         itj=itortyp(itype(j))
6066         if (l.lt.nres-1) then
6067           itl1=itortyp(itype(l+1))
6068         else
6069           itl1=ntortyp+1
6070         endif
6071 C A1 kernel(j+1) A2T
6072 cd        do iii=1,2
6073 cd          write (iout,'(3f10.5,5x,3f10.5)')
6074 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6075 cd        enddo
6076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6077      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6078      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6079 C Following matrices are needed only for 6-th order cumulants
6080         IF (wcorr6.gt.0.0d0) THEN
6081         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6082      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6083      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6084         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6085      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6086      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6087      &   ADtEAderx(1,1,1,1,1,1))
6088         lprn=.false.
6089         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6090      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6091      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6092      &   ADtEA1derx(1,1,1,1,1,1))
6093         ENDIF
6094 C End 6-th order cumulants
6095 cd        lprn=.false.
6096 cd        if (lprn) then
6097 cd        write (2,*) 'In calc_eello6'
6098 cd        do iii=1,2
6099 cd          write (2,*) 'iii=',iii
6100 cd          do kkk=1,5
6101 cd            write (2,*) 'kkk=',kkk
6102 cd            do jjj=1,2
6103 cd              write (2,'(3(2f10.5),5x)')
6104 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6105 cd            enddo
6106 cd          enddo
6107 cd        enddo
6108 cd        endif
6109         call transpose2(EUgder(1,1,k),auxmat(1,1))
6110         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6111         call transpose2(EUg(1,1,k),auxmat(1,1))
6112         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6113         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6114         do iii=1,2
6115           do kkk=1,5
6116             do lll=1,3
6117               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6118      &          EAEAderx(1,1,lll,kkk,iii,1))
6119             enddo
6120           enddo
6121         enddo
6122 C A1T kernel(i+1) A2
6123         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6124      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6125      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6126 C Following matrices are needed only for 6-th order cumulants
6127         IF (wcorr6.gt.0.0d0) THEN
6128         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6129      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6130      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6131         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6132      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6133      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6134      &   ADtEAderx(1,1,1,1,1,2))
6135         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6136      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6137      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6138      &   ADtEA1derx(1,1,1,1,1,2))
6139         ENDIF
6140 C End 6-th order cumulants
6141         call transpose2(EUgder(1,1,l),auxmat(1,1))
6142         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6143         call transpose2(EUg(1,1,l),auxmat(1,1))
6144         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6145         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6146         do iii=1,2
6147           do kkk=1,5
6148             do lll=1,3
6149               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6150      &          EAEAderx(1,1,lll,kkk,iii,2))
6151             enddo
6152           enddo
6153         enddo
6154 C AEAb1 and AEAb2
6155 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6156 C They are needed only when the fifth- or the sixth-order cumulants are
6157 C indluded.
6158         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6159         call transpose2(AEA(1,1,1),auxmat(1,1))
6160         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6161         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6162         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6163         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6164         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6165         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6166         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6167         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6168         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6169         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6170         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6171         call transpose2(AEA(1,1,2),auxmat(1,1))
6172         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6173         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6174         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6175         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6176         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6177         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6178         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6179         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6180         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6181         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6182         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6183 C Calculate the Cartesian derivatives of the vectors.
6184         do iii=1,2
6185           do kkk=1,5
6186             do lll=1,3
6187               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6188               call matvec2(auxmat(1,1),b1(1,iti),
6189      &          AEAb1derx(1,lll,kkk,iii,1,1))
6190               call matvec2(auxmat(1,1),Ub2(1,i),
6191      &          AEAb2derx(1,lll,kkk,iii,1,1))
6192               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6193      &          AEAb1derx(1,lll,kkk,iii,2,1))
6194               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6195      &          AEAb2derx(1,lll,kkk,iii,2,1))
6196               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6197               call matvec2(auxmat(1,1),b1(1,itj),
6198      &          AEAb1derx(1,lll,kkk,iii,1,2))
6199               call matvec2(auxmat(1,1),Ub2(1,j),
6200      &          AEAb2derx(1,lll,kkk,iii,1,2))
6201               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6202      &          AEAb1derx(1,lll,kkk,iii,2,2))
6203               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6204      &          AEAb2derx(1,lll,kkk,iii,2,2))
6205             enddo
6206           enddo
6207         enddo
6208         ENDIF
6209 C End vectors
6210       else
6211 C Antiparallel orientation of the two CA-CA-CA frames.
6212         if (i.gt.1) then
6213           iti=itortyp(itype(i))
6214         else
6215           iti=ntortyp+1
6216         endif
6217         itk1=itortyp(itype(k+1))
6218         itl=itortyp(itype(l))
6219         itj=itortyp(itype(j))
6220         if (j.lt.nres-1) then
6221           itj1=itortyp(itype(j+1))
6222         else
6223           itj1=ntortyp+1
6224         endif
6225 C A2 kernel(j-1)T A1T
6226         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6227      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6228      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6229 C Following matrices are needed only for 6-th order cumulants
6230         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6231      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6232         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6233      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6234      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6235         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6236      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6237      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6238      &   ADtEAderx(1,1,1,1,1,1))
6239         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6240      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6241      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6242      &   ADtEA1derx(1,1,1,1,1,1))
6243         ENDIF
6244 C End 6-th order cumulants
6245         call transpose2(EUgder(1,1,k),auxmat(1,1))
6246         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6247         call transpose2(EUg(1,1,k),auxmat(1,1))
6248         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6249         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6250         do iii=1,2
6251           do kkk=1,5
6252             do lll=1,3
6253               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6254      &          EAEAderx(1,1,lll,kkk,iii,1))
6255             enddo
6256           enddo
6257         enddo
6258 C A2T kernel(i+1)T A1
6259         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6260      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6261      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6262 C Following matrices are needed only for 6-th order cumulants
6263         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6264      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6265         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6266      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6267      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6268         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6269      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6270      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6271      &   ADtEAderx(1,1,1,1,1,2))
6272         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6273      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6274      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6275      &   ADtEA1derx(1,1,1,1,1,2))
6276         ENDIF
6277 C End 6-th order cumulants
6278         call transpose2(EUgder(1,1,j),auxmat(1,1))
6279         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6280         call transpose2(EUg(1,1,j),auxmat(1,1))
6281         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6282         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6283         do iii=1,2
6284           do kkk=1,5
6285             do lll=1,3
6286               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6287      &          EAEAderx(1,1,lll,kkk,iii,2))
6288             enddo
6289           enddo
6290         enddo
6291 C AEAb1 and AEAb2
6292 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6293 C They are needed only when the fifth- or the sixth-order cumulants are
6294 C indluded.
6295         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6296      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6297         call transpose2(AEA(1,1,1),auxmat(1,1))
6298         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6299         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6300         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6301         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6302         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6303         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6304         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6305         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6306         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6307         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6308         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6309         call transpose2(AEA(1,1,2),auxmat(1,1))
6310         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6311         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6312         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6313         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6314         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6315         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6316         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6317         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6318         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6319         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6320         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6321 C Calculate the Cartesian derivatives of the vectors.
6322         do iii=1,2
6323           do kkk=1,5
6324             do lll=1,3
6325               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6326               call matvec2(auxmat(1,1),b1(1,iti),
6327      &          AEAb1derx(1,lll,kkk,iii,1,1))
6328               call matvec2(auxmat(1,1),Ub2(1,i),
6329      &          AEAb2derx(1,lll,kkk,iii,1,1))
6330               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6331      &          AEAb1derx(1,lll,kkk,iii,2,1))
6332               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6333      &          AEAb2derx(1,lll,kkk,iii,2,1))
6334               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6335               call matvec2(auxmat(1,1),b1(1,itl),
6336      &          AEAb1derx(1,lll,kkk,iii,1,2))
6337               call matvec2(auxmat(1,1),Ub2(1,l),
6338      &          AEAb2derx(1,lll,kkk,iii,1,2))
6339               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6340      &          AEAb1derx(1,lll,kkk,iii,2,2))
6341               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6342      &          AEAb2derx(1,lll,kkk,iii,2,2))
6343             enddo
6344           enddo
6345         enddo
6346         ENDIF
6347 C End vectors
6348       endif
6349       return
6350       end
6351 C---------------------------------------------------------------------------
6352       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6353      &  KK,KKderg,AKA,AKAderg,AKAderx)
6354       implicit none
6355       integer nderg
6356       logical transp
6357       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6358      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6359      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6360       integer iii,kkk,lll
6361       integer jjj,mmm
6362       logical lprn
6363       common /kutas/ lprn
6364       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6365       do iii=1,nderg
6366         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6367      &    AKAderg(1,1,iii))
6368       enddo
6369 cd      if (lprn) write (2,*) 'In kernel'
6370       do kkk=1,5
6371 cd        if (lprn) write (2,*) 'kkk=',kkk
6372         do lll=1,3
6373           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6374      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6375 cd          if (lprn) then
6376 cd            write (2,*) 'lll=',lll
6377 cd            write (2,*) 'iii=1'
6378 cd            do jjj=1,2
6379 cd              write (2,'(3(2f10.5),5x)')
6380 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6381 cd            enddo
6382 cd          endif
6383           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6384      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6385 cd          if (lprn) then
6386 cd            write (2,*) 'lll=',lll
6387 cd            write (2,*) 'iii=2'
6388 cd            do jjj=1,2
6389 cd              write (2,'(3(2f10.5),5x)')
6390 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6391 cd            enddo
6392 cd          endif
6393         enddo
6394       enddo
6395       return
6396       end
6397 C---------------------------------------------------------------------------
6398       double precision function eello4(i,j,k,l,jj,kk)
6399       implicit real*8 (a-h,o-z)
6400       include 'DIMENSIONS'
6401       include 'DIMENSIONS.ZSCOPT'
6402       include 'COMMON.IOUNITS'
6403       include 'COMMON.CHAIN'
6404       include 'COMMON.DERIV'
6405       include 'COMMON.INTERACT'
6406       include 'COMMON.CONTACTS'
6407       include 'COMMON.TORSION'
6408       include 'COMMON.VAR'
6409       include 'COMMON.GEO'
6410       double precision pizda(2,2),ggg1(3),ggg2(3)
6411 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6412 cd        eello4=0.0d0
6413 cd        return
6414 cd      endif
6415 cd      print *,'eello4:',i,j,k,l,jj,kk
6416 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6417 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6418 cold      eij=facont_hb(jj,i)
6419 cold      ekl=facont_hb(kk,k)
6420 cold      ekont=eij*ekl
6421       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6422       if (calc_grad) then
6423 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6424       gcorr_loc(k-1)=gcorr_loc(k-1)
6425      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6426       if (l.eq.j+1) then
6427         gcorr_loc(l-1)=gcorr_loc(l-1)
6428      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6429       else
6430         gcorr_loc(j-1)=gcorr_loc(j-1)
6431      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6432       endif
6433       do iii=1,2
6434         do kkk=1,5
6435           do lll=1,3
6436             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6437      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6438 cd            derx(lll,kkk,iii)=0.0d0
6439           enddo
6440         enddo
6441       enddo
6442 cd      gcorr_loc(l-1)=0.0d0
6443 cd      gcorr_loc(j-1)=0.0d0
6444 cd      gcorr_loc(k-1)=0.0d0
6445 cd      eel4=1.0d0
6446 cd      write (iout,*)'Contacts have occurred for peptide groups',
6447 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6448 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6449       if (j.lt.nres-1) then
6450         j1=j+1
6451         j2=j-1
6452       else
6453         j1=j-1
6454         j2=j-2
6455       endif
6456       if (l.lt.nres-1) then
6457         l1=l+1
6458         l2=l-1
6459       else
6460         l1=l-1
6461         l2=l-2
6462       endif
6463       do ll=1,3
6464 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6465         ggg1(ll)=eel4*g_contij(ll,1)
6466         ggg2(ll)=eel4*g_contij(ll,2)
6467         ghalf=0.5d0*ggg1(ll)
6468 cd        ghalf=0.0d0
6469         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6470         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6471         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6472         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6473 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6474         ghalf=0.5d0*ggg2(ll)
6475 cd        ghalf=0.0d0
6476         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6477         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6478         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6479         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6480       enddo
6481 cd      goto 1112
6482       do m=i+1,j-1
6483         do ll=1,3
6484 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6485           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6486         enddo
6487       enddo
6488       do m=k+1,l-1
6489         do ll=1,3
6490 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6491           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6492         enddo
6493       enddo
6494 1112  continue
6495       do m=i+2,j2
6496         do ll=1,3
6497           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6498         enddo
6499       enddo
6500       do m=k+2,l2
6501         do ll=1,3
6502           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6503         enddo
6504       enddo
6505 cd      do iii=1,nres-3
6506 cd        write (2,*) iii,gcorr_loc(iii)
6507 cd      enddo
6508       endif
6509       eello4=ekont*eel4
6510 cd      write (2,*) 'ekont',ekont
6511 cd      write (iout,*) 'eello4',ekont*eel4
6512       return
6513       end
6514 C---------------------------------------------------------------------------
6515       double precision function eello5(i,j,k,l,jj,kk)
6516       implicit real*8 (a-h,o-z)
6517       include 'DIMENSIONS'
6518       include 'DIMENSIONS.ZSCOPT'
6519       include 'COMMON.IOUNITS'
6520       include 'COMMON.CHAIN'
6521       include 'COMMON.DERIV'
6522       include 'COMMON.INTERACT'
6523       include 'COMMON.CONTACTS'
6524       include 'COMMON.TORSION'
6525       include 'COMMON.VAR'
6526       include 'COMMON.GEO'
6527       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6528       double precision ggg1(3),ggg2(3)
6529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6530 C                                                                              C
6531 C                            Parallel chains                                   C
6532 C                                                                              C
6533 C          o             o                   o             o                   C
6534 C         /l\           / \             \   / \           / \   /              C
6535 C        /   \         /   \             \ /   \         /   \ /               C
6536 C       j| o |l1       | o |              o| o |         | o |o                C
6537 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6538 C      \i/   \         /   \ /             /   \         /   \                 C
6539 C       o    k1             o                                                  C
6540 C         (I)          (II)                (III)          (IV)                 C
6541 C                                                                              C
6542 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6543 C                                                                              C
6544 C                            Antiparallel chains                               C
6545 C                                                                              C
6546 C          o             o                   o             o                   C
6547 C         /j\           / \             \   / \           / \   /              C
6548 C        /   \         /   \             \ /   \         /   \ /               C
6549 C      j1| o |l        | o |              o| o |         | o |o                C
6550 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6551 C      \i/   \         /   \ /             /   \         /   \                 C
6552 C       o     k1            o                                                  C
6553 C         (I)          (II)                (III)          (IV)                 C
6554 C                                                                              C
6555 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6556 C                                                                              C
6557 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6558 C                                                                              C
6559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6560 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6561 cd        eello5=0.0d0
6562 cd        return
6563 cd      endif
6564 cd      write (iout,*)
6565 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6566 cd     &   ' and',k,l
6567       itk=itortyp(itype(k))
6568       itl=itortyp(itype(l))
6569       itj=itortyp(itype(j))
6570       eello5_1=0.0d0
6571       eello5_2=0.0d0
6572       eello5_3=0.0d0
6573       eello5_4=0.0d0
6574 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6575 cd     &   eel5_3_num,eel5_4_num)
6576       do iii=1,2
6577         do kkk=1,5
6578           do lll=1,3
6579             derx(lll,kkk,iii)=0.0d0
6580           enddo
6581         enddo
6582       enddo
6583 cd      eij=facont_hb(jj,i)
6584 cd      ekl=facont_hb(kk,k)
6585 cd      ekont=eij*ekl
6586 cd      write (iout,*)'Contacts have occurred for peptide groups',
6587 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6588 cd      goto 1111
6589 C Contribution from the graph I.
6590 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6591 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6592       call transpose2(EUg(1,1,k),auxmat(1,1))
6593       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6594       vv(1)=pizda(1,1)-pizda(2,2)
6595       vv(2)=pizda(1,2)+pizda(2,1)
6596       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6597      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6598       if (calc_grad) then
6599 C Explicit gradient in virtual-dihedral angles.
6600       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6601      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6602      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6603       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6604       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6605       vv(1)=pizda(1,1)-pizda(2,2)
6606       vv(2)=pizda(1,2)+pizda(2,1)
6607       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6608      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6609      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6610       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6611       vv(1)=pizda(1,1)-pizda(2,2)
6612       vv(2)=pizda(1,2)+pizda(2,1)
6613       if (l.eq.j+1) then
6614         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6615      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6616      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6617       else
6618         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6619      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6620      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6621       endif
6622 C Cartesian gradient
6623       do iii=1,2
6624         do kkk=1,5
6625           do lll=1,3
6626             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6627      &        pizda(1,1))
6628             vv(1)=pizda(1,1)-pizda(2,2)
6629             vv(2)=pizda(1,2)+pizda(2,1)
6630             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6631      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6632      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6633           enddo
6634         enddo
6635       enddo
6636 c      goto 1112
6637       endif
6638 c1111  continue
6639 C Contribution from graph II
6640       call transpose2(EE(1,1,itk),auxmat(1,1))
6641       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6642       vv(1)=pizda(1,1)+pizda(2,2)
6643       vv(2)=pizda(2,1)-pizda(1,2)
6644       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6645      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6646       if (calc_grad) then
6647 C Explicit gradient in virtual-dihedral angles.
6648       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6649      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6650       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6651       vv(1)=pizda(1,1)+pizda(2,2)
6652       vv(2)=pizda(2,1)-pizda(1,2)
6653       if (l.eq.j+1) then
6654         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6655      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6656      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6657       else
6658         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6659      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6660      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6661       endif
6662 C Cartesian gradient
6663       do iii=1,2
6664         do kkk=1,5
6665           do lll=1,3
6666             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6667      &        pizda(1,1))
6668             vv(1)=pizda(1,1)+pizda(2,2)
6669             vv(2)=pizda(2,1)-pizda(1,2)
6670             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6671      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6672      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6673           enddo
6674         enddo
6675       enddo
6676 cd      goto 1112
6677       endif
6678 cd1111  continue
6679       if (l.eq.j+1) then
6680 cd        goto 1110
6681 C Parallel orientation
6682 C Contribution from graph III
6683         call transpose2(EUg(1,1,l),auxmat(1,1))
6684         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6685         vv(1)=pizda(1,1)-pizda(2,2)
6686         vv(2)=pizda(1,2)+pizda(2,1)
6687         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6688      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6689         if (calc_grad) then
6690 C Explicit gradient in virtual-dihedral angles.
6691         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6692      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6693      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6694         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6695         vv(1)=pizda(1,1)-pizda(2,2)
6696         vv(2)=pizda(1,2)+pizda(2,1)
6697         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6698      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6699      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6700         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6701         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6702         vv(1)=pizda(1,1)-pizda(2,2)
6703         vv(2)=pizda(1,2)+pizda(2,1)
6704         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6705      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6706      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6707 C Cartesian gradient
6708         do iii=1,2
6709           do kkk=1,5
6710             do lll=1,3
6711               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6712      &          pizda(1,1))
6713               vv(1)=pizda(1,1)-pizda(2,2)
6714               vv(2)=pizda(1,2)+pizda(2,1)
6715               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6716      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6717      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6718             enddo
6719           enddo
6720         enddo
6721 cd        goto 1112
6722         endif
6723 C Contribution from graph IV
6724 cd1110    continue
6725         call transpose2(EE(1,1,itl),auxmat(1,1))
6726         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6727         vv(1)=pizda(1,1)+pizda(2,2)
6728         vv(2)=pizda(2,1)-pizda(1,2)
6729         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6730      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6731         if (calc_grad) then
6732 C Explicit gradient in virtual-dihedral angles.
6733         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6734      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6735         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6736         vv(1)=pizda(1,1)+pizda(2,2)
6737         vv(2)=pizda(2,1)-pizda(1,2)
6738         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6739      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6740      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6741 C Cartesian gradient
6742         do iii=1,2
6743           do kkk=1,5
6744             do lll=1,3
6745               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6746      &          pizda(1,1))
6747               vv(1)=pizda(1,1)+pizda(2,2)
6748               vv(2)=pizda(2,1)-pizda(1,2)
6749               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6750      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6751      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6752             enddo
6753           enddo
6754         enddo
6755         endif
6756       else
6757 C Antiparallel orientation
6758 C Contribution from graph III
6759 c        goto 1110
6760         call transpose2(EUg(1,1,j),auxmat(1,1))
6761         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6762         vv(1)=pizda(1,1)-pizda(2,2)
6763         vv(2)=pizda(1,2)+pizda(2,1)
6764         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6765      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6766         if (calc_grad) then
6767 C Explicit gradient in virtual-dihedral angles.
6768         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6769      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6770      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6771         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6772         vv(1)=pizda(1,1)-pizda(2,2)
6773         vv(2)=pizda(1,2)+pizda(2,1)
6774         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6775      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6776      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6777         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6778         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6779         vv(1)=pizda(1,1)-pizda(2,2)
6780         vv(2)=pizda(1,2)+pizda(2,1)
6781         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6782      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6783      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6784 C Cartesian gradient
6785         do iii=1,2
6786           do kkk=1,5
6787             do lll=1,3
6788               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6789      &          pizda(1,1))
6790               vv(1)=pizda(1,1)-pizda(2,2)
6791               vv(2)=pizda(1,2)+pizda(2,1)
6792               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6793      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6794      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6795             enddo
6796           enddo
6797         enddo
6798 cd        goto 1112
6799         endif
6800 C Contribution from graph IV
6801 1110    continue
6802         call transpose2(EE(1,1,itj),auxmat(1,1))
6803         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6804         vv(1)=pizda(1,1)+pizda(2,2)
6805         vv(2)=pizda(2,1)-pizda(1,2)
6806         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6807      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6808         if (calc_grad) then
6809 C Explicit gradient in virtual-dihedral angles.
6810         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6811      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6812         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6813         vv(1)=pizda(1,1)+pizda(2,2)
6814         vv(2)=pizda(2,1)-pizda(1,2)
6815         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6816      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6817      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6818 C Cartesian gradient
6819         do iii=1,2
6820           do kkk=1,5
6821             do lll=1,3
6822               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6823      &          pizda(1,1))
6824               vv(1)=pizda(1,1)+pizda(2,2)
6825               vv(2)=pizda(2,1)-pizda(1,2)
6826               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6827      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6828      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6829             enddo
6830           enddo
6831         enddo
6832       endif
6833       endif
6834 1112  continue
6835       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6836 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6837 cd        write (2,*) 'ijkl',i,j,k,l
6838 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6839 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6840 cd      endif
6841 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6842 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6843 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6844 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6845       if (calc_grad) then
6846       if (j.lt.nres-1) then
6847         j1=j+1
6848         j2=j-1
6849       else
6850         j1=j-1
6851         j2=j-2
6852       endif
6853       if (l.lt.nres-1) then
6854         l1=l+1
6855         l2=l-1
6856       else
6857         l1=l-1
6858         l2=l-2
6859       endif
6860 cd      eij=1.0d0
6861 cd      ekl=1.0d0
6862 cd      ekont=1.0d0
6863 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6864       do ll=1,3
6865         ggg1(ll)=eel5*g_contij(ll,1)
6866         ggg2(ll)=eel5*g_contij(ll,2)
6867 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6868         ghalf=0.5d0*ggg1(ll)
6869 cd        ghalf=0.0d0
6870         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6871         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6872         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6873         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6874 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6875         ghalf=0.5d0*ggg2(ll)
6876 cd        ghalf=0.0d0
6877         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6878         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6879         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6880         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6881       enddo
6882 cd      goto 1112
6883       do m=i+1,j-1
6884         do ll=1,3
6885 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6886           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6887         enddo
6888       enddo
6889       do m=k+1,l-1
6890         do ll=1,3
6891 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6892           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6893         enddo
6894       enddo
6895 c1112  continue
6896       do m=i+2,j2
6897         do ll=1,3
6898           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6899         enddo
6900       enddo
6901       do m=k+2,l2
6902         do ll=1,3
6903           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6904         enddo
6905       enddo
6906 cd      do iii=1,nres-3
6907 cd        write (2,*) iii,g_corr5_loc(iii)
6908 cd      enddo
6909       endif
6910       eello5=ekont*eel5
6911 cd      write (2,*) 'ekont',ekont
6912 cd      write (iout,*) 'eello5',ekont*eel5
6913       return
6914       end
6915 c--------------------------------------------------------------------------
6916       double precision function eello6(i,j,k,l,jj,kk)
6917       implicit real*8 (a-h,o-z)
6918       include 'DIMENSIONS'
6919       include 'DIMENSIONS.ZSCOPT'
6920       include 'COMMON.IOUNITS'
6921       include 'COMMON.CHAIN'
6922       include 'COMMON.DERIV'
6923       include 'COMMON.INTERACT'
6924       include 'COMMON.CONTACTS'
6925       include 'COMMON.TORSION'
6926       include 'COMMON.VAR'
6927       include 'COMMON.GEO'
6928       include 'COMMON.FFIELD'
6929       double precision ggg1(3),ggg2(3)
6930 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6931 cd        eello6=0.0d0
6932 cd        return
6933 cd      endif
6934 cd      write (iout,*)
6935 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6936 cd     &   ' and',k,l
6937       eello6_1=0.0d0
6938       eello6_2=0.0d0
6939       eello6_3=0.0d0
6940       eello6_4=0.0d0
6941       eello6_5=0.0d0
6942       eello6_6=0.0d0
6943 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6944 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6945       do iii=1,2
6946         do kkk=1,5
6947           do lll=1,3
6948             derx(lll,kkk,iii)=0.0d0
6949           enddo
6950         enddo
6951       enddo
6952 cd      eij=facont_hb(jj,i)
6953 cd      ekl=facont_hb(kk,k)
6954 cd      ekont=eij*ekl
6955 cd      eij=1.0d0
6956 cd      ekl=1.0d0
6957 cd      ekont=1.0d0
6958       if (l.eq.j+1) then
6959         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6960         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6961         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6962         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6963         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6964         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6965       else
6966         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6967         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6968         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6969         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6970         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6971           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6972         else
6973           eello6_5=0.0d0
6974         endif
6975         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6976       endif
6977 C If turn contributions are considered, they will be handled separately.
6978       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6979 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6980 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6981 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6982 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6983 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6984 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6985 cd      goto 1112
6986       if (calc_grad) then
6987       if (j.lt.nres-1) then
6988         j1=j+1
6989         j2=j-1
6990       else
6991         j1=j-1
6992         j2=j-2
6993       endif
6994       if (l.lt.nres-1) then
6995         l1=l+1
6996         l2=l-1
6997       else
6998         l1=l-1
6999         l2=l-2
7000       endif
7001       do ll=1,3
7002         ggg1(ll)=eel6*g_contij(ll,1)
7003         ggg2(ll)=eel6*g_contij(ll,2)
7004 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7005         ghalf=0.5d0*ggg1(ll)
7006 cd        ghalf=0.0d0
7007         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7008         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7009         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7010         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7011         ghalf=0.5d0*ggg2(ll)
7012 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7013 cd        ghalf=0.0d0
7014         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7015         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7016         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7017         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7018       enddo
7019 cd      goto 1112
7020       do m=i+1,j-1
7021         do ll=1,3
7022 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7023           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7024         enddo
7025       enddo
7026       do m=k+1,l-1
7027         do ll=1,3
7028 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7029           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7030         enddo
7031       enddo
7032 1112  continue
7033       do m=i+2,j2
7034         do ll=1,3
7035           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7036         enddo
7037       enddo
7038       do m=k+2,l2
7039         do ll=1,3
7040           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7041         enddo
7042       enddo
7043 cd      do iii=1,nres-3
7044 cd        write (2,*) iii,g_corr6_loc(iii)
7045 cd      enddo
7046       endif
7047       eello6=ekont*eel6
7048 cd      write (2,*) 'ekont',ekont
7049 cd      write (iout,*) 'eello6',ekont*eel6
7050       return
7051       end
7052 c--------------------------------------------------------------------------
7053       double precision function eello6_graph1(i,j,k,l,imat,swap)
7054       implicit real*8 (a-h,o-z)
7055       include 'DIMENSIONS'
7056       include 'DIMENSIONS.ZSCOPT'
7057       include 'COMMON.IOUNITS'
7058       include 'COMMON.CHAIN'
7059       include 'COMMON.DERIV'
7060       include 'COMMON.INTERACT'
7061       include 'COMMON.CONTACTS'
7062       include 'COMMON.TORSION'
7063       include 'COMMON.VAR'
7064       include 'COMMON.GEO'
7065       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7066       logical swap
7067       logical lprn
7068       common /kutas/ lprn
7069 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7070 C                                                                              C
7071 C      Parallel       Antiparallel                                             C
7072 C                                                                              C
7073 C          o             o                                                     C
7074 C         /l\           /j\                                                    C
7075 C        /   \         /   \                                                   C
7076 C       /| o |         | o |\                                                  C
7077 C     \ j|/k\|  /   \  |/k\|l /                                                C
7078 C      \ /   \ /     \ /   \ /                                                 C
7079 C       o     o       o     o                                                  C
7080 C       i             i                                                        C
7081 C                                                                              C
7082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7083       itk=itortyp(itype(k))
7084       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7085       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7086       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7087       call transpose2(EUgC(1,1,k),auxmat(1,1))
7088       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7089       vv1(1)=pizda1(1,1)-pizda1(2,2)
7090       vv1(2)=pizda1(1,2)+pizda1(2,1)
7091       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7092       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7093       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7094       s5=scalar2(vv(1),Dtobr2(1,i))
7095 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7096       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7097       if (.not. calc_grad) return
7098       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7099      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7100      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7101      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7102      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7103      & +scalar2(vv(1),Dtobr2der(1,i)))
7104       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7105       vv1(1)=pizda1(1,1)-pizda1(2,2)
7106       vv1(2)=pizda1(1,2)+pizda1(2,1)
7107       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7108       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7109       if (l.eq.j+1) then
7110         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7111      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7112      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7113      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7114      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7115       else
7116         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7117      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7118      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7119      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7120      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7121       endif
7122       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7123       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7124       vv1(1)=pizda1(1,1)-pizda1(2,2)
7125       vv1(2)=pizda1(1,2)+pizda1(2,1)
7126       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7127      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7128      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7129      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7130       do iii=1,2
7131         if (swap) then
7132           ind=3-iii
7133         else
7134           ind=iii
7135         endif
7136         do kkk=1,5
7137           do lll=1,3
7138             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7139             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7140             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7141             call transpose2(EUgC(1,1,k),auxmat(1,1))
7142             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7143      &        pizda1(1,1))
7144             vv1(1)=pizda1(1,1)-pizda1(2,2)
7145             vv1(2)=pizda1(1,2)+pizda1(2,1)
7146             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7147             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7148      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7149             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7150      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7151             s5=scalar2(vv(1),Dtobr2(1,i))
7152             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7153           enddo
7154         enddo
7155       enddo
7156       return
7157       end
7158 c----------------------------------------------------------------------------
7159       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7160       implicit real*8 (a-h,o-z)
7161       include 'DIMENSIONS'
7162       include 'DIMENSIONS.ZSCOPT'
7163       include 'COMMON.IOUNITS'
7164       include 'COMMON.CHAIN'
7165       include 'COMMON.DERIV'
7166       include 'COMMON.INTERACT'
7167       include 'COMMON.CONTACTS'
7168       include 'COMMON.TORSION'
7169       include 'COMMON.VAR'
7170       include 'COMMON.GEO'
7171       logical swap
7172       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7173      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7174       logical lprn
7175       common /kutas/ lprn
7176 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7177 C                                                                              C
7178 C      Parallel       Antiparallel                                             C
7179 C                                                                              C
7180 C          o             o                                                     C
7181 C     \   /l\           /j\   /                                                C
7182 C      \ /   \         /   \ /                                                 C
7183 C       o| o |         | o |o                                                  C
7184 C     \ j|/k\|      \  |/k\|l                                                  C
7185 C      \ /   \       \ /   \                                                   C
7186 C       o             o                                                        C
7187 C       i             i                                                        C
7188 C                                                                              C
7189 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7190 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7191 C AL 7/4/01 s1 would occur in the sixth-order moment,
7192 C           but not in a cluster cumulant
7193 #ifdef MOMENT
7194       s1=dip(1,jj,i)*dip(1,kk,k)
7195 #endif
7196       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7197       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7198       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7199       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7200       call transpose2(EUg(1,1,k),auxmat(1,1))
7201       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7202       vv(1)=pizda(1,1)-pizda(2,2)
7203       vv(2)=pizda(1,2)+pizda(2,1)
7204       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7205 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7206 #ifdef MOMENT
7207       eello6_graph2=-(s1+s2+s3+s4)
7208 #else
7209       eello6_graph2=-(s2+s3+s4)
7210 #endif
7211 c      eello6_graph2=-s3
7212       if (.not. calc_grad) return
7213 C Derivatives in gamma(i-1)
7214       if (i.gt.1) then
7215 #ifdef MOMENT
7216         s1=dipderg(1,jj,i)*dip(1,kk,k)
7217 #endif
7218         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7219         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7220         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7221         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7222 #ifdef MOMENT
7223         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7224 #else
7225         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7226 #endif
7227 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7228       endif
7229 C Derivatives in gamma(k-1)
7230 #ifdef MOMENT
7231       s1=dip(1,jj,i)*dipderg(1,kk,k)
7232 #endif
7233       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7234       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7235       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7236       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7237       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7238       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7239       vv(1)=pizda(1,1)-pizda(2,2)
7240       vv(2)=pizda(1,2)+pizda(2,1)
7241       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7242 #ifdef MOMENT
7243       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7244 #else
7245       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7246 #endif
7247 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7248 C Derivatives in gamma(j-1) or gamma(l-1)
7249       if (j.gt.1) then
7250 #ifdef MOMENT
7251         s1=dipderg(3,jj,i)*dip(1,kk,k)
7252 #endif
7253         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7254         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7255         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7256         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7257         vv(1)=pizda(1,1)-pizda(2,2)
7258         vv(2)=pizda(1,2)+pizda(2,1)
7259         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7260 #ifdef MOMENT
7261         if (swap) then
7262           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7263         else
7264           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7265         endif
7266 #endif
7267         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7268 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7269       endif
7270 C Derivatives in gamma(l-1) or gamma(j-1)
7271       if (l.gt.1) then
7272 #ifdef MOMENT
7273         s1=dip(1,jj,i)*dipderg(3,kk,k)
7274 #endif
7275         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7276         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7277         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7278         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7279         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7280         vv(1)=pizda(1,1)-pizda(2,2)
7281         vv(2)=pizda(1,2)+pizda(2,1)
7282         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7283 #ifdef MOMENT
7284         if (swap) then
7285           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7286         else
7287           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7288         endif
7289 #endif
7290         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7291 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7292       endif
7293 C Cartesian derivatives.
7294       if (lprn) then
7295         write (2,*) 'In eello6_graph2'
7296         do iii=1,2
7297           write (2,*) 'iii=',iii
7298           do kkk=1,5
7299             write (2,*) 'kkk=',kkk
7300             do jjj=1,2
7301               write (2,'(3(2f10.5),5x)')
7302      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7303             enddo
7304           enddo
7305         enddo
7306       endif
7307       do iii=1,2
7308         do kkk=1,5
7309           do lll=1,3
7310 #ifdef MOMENT
7311             if (iii.eq.1) then
7312               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7313             else
7314               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7315             endif
7316 #endif
7317             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7318      &        auxvec(1))
7319             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7320             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7321      &        auxvec(1))
7322             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7323             call transpose2(EUg(1,1,k),auxmat(1,1))
7324             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7325      &        pizda(1,1))
7326             vv(1)=pizda(1,1)-pizda(2,2)
7327             vv(2)=pizda(1,2)+pizda(2,1)
7328             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7329 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7330 #ifdef MOMENT
7331             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7332 #else
7333             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7334 #endif
7335             if (swap) then
7336               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7337             else
7338               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7339             endif
7340           enddo
7341         enddo
7342       enddo
7343       return
7344       end
7345 c----------------------------------------------------------------------------
7346       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7347       implicit real*8 (a-h,o-z)
7348       include 'DIMENSIONS'
7349       include 'DIMENSIONS.ZSCOPT'
7350       include 'COMMON.IOUNITS'
7351       include 'COMMON.CHAIN'
7352       include 'COMMON.DERIV'
7353       include 'COMMON.INTERACT'
7354       include 'COMMON.CONTACTS'
7355       include 'COMMON.TORSION'
7356       include 'COMMON.VAR'
7357       include 'COMMON.GEO'
7358       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7359       logical swap
7360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7361 C                                                                              C
7362 C      Parallel       Antiparallel                                             C
7363 C                                                                              C
7364 C          o             o                                                     C
7365 C         /l\   /   \   /j\                                                    C
7366 C        /   \ /     \ /   \                                                   C
7367 C       /| o |o       o| o |\                                                  C
7368 C       j|/k\|  /      |/k\|l /                                                C
7369 C        /   \ /       /   \ /                                                 C
7370 C       /     o       /     o                                                  C
7371 C       i             i                                                        C
7372 C                                                                              C
7373 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7374 C
7375 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7376 C           energy moment and not to the cluster cumulant.
7377       iti=itortyp(itype(i))
7378       if (j.lt.nres-1) then
7379         itj1=itortyp(itype(j+1))
7380       else
7381         itj1=ntortyp+1
7382       endif
7383       itk=itortyp(itype(k))
7384       itk1=itortyp(itype(k+1))
7385       if (l.lt.nres-1) then
7386         itl1=itortyp(itype(l+1))
7387       else
7388         itl1=ntortyp+1
7389       endif
7390 #ifdef MOMENT
7391       s1=dip(4,jj,i)*dip(4,kk,k)
7392 #endif
7393       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7394       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7395       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7396       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7397       call transpose2(EE(1,1,itk),auxmat(1,1))
7398       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7399       vv(1)=pizda(1,1)+pizda(2,2)
7400       vv(2)=pizda(2,1)-pizda(1,2)
7401       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7402 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7403 #ifdef MOMENT
7404       eello6_graph3=-(s1+s2+s3+s4)
7405 #else
7406       eello6_graph3=-(s2+s3+s4)
7407 #endif
7408 c      eello6_graph3=-s4
7409       if (.not. calc_grad) return
7410 C Derivatives in gamma(k-1)
7411       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7412       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7413       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7414       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7415 C Derivatives in gamma(l-1)
7416       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7417       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7418       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7419       vv(1)=pizda(1,1)+pizda(2,2)
7420       vv(2)=pizda(2,1)-pizda(1,2)
7421       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7422       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7423 C Cartesian derivatives.
7424       do iii=1,2
7425         do kkk=1,5
7426           do lll=1,3
7427 #ifdef MOMENT
7428             if (iii.eq.1) then
7429               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7430             else
7431               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7432             endif
7433 #endif
7434             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7435      &        auxvec(1))
7436             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7437             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7438      &        auxvec(1))
7439             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7440             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7441      &        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 #ifdef MOMENT
7446             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7447 #else
7448             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7449 #endif
7450             if (swap) then
7451               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7452             else
7453               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7454             endif
7455 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7456           enddo
7457         enddo
7458       enddo
7459       return
7460       end
7461 c----------------------------------------------------------------------------
7462       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7463       implicit real*8 (a-h,o-z)
7464       include 'DIMENSIONS'
7465       include 'DIMENSIONS.ZSCOPT'
7466       include 'COMMON.IOUNITS'
7467       include 'COMMON.CHAIN'
7468       include 'COMMON.DERIV'
7469       include 'COMMON.INTERACT'
7470       include 'COMMON.CONTACTS'
7471       include 'COMMON.TORSION'
7472       include 'COMMON.VAR'
7473       include 'COMMON.GEO'
7474       include 'COMMON.FFIELD'
7475       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7476      & auxvec1(2),auxmat1(2,2)
7477       logical swap
7478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7479 C                                                                              C
7480 C      Parallel       Antiparallel                                             C
7481 C                                                                              C
7482 C          o             o                                                     C
7483 C         /l\   /   \   /j\                                                    C
7484 C        /   \ /     \ /   \                                                   C
7485 C       /| o |o       o| o |\                                                  C
7486 C     \ j|/k\|      \  |/k\|l                                                  C
7487 C      \ /   \       \ /   \                                                   C
7488 C       o     \       o     \                                                  C
7489 C       i             i                                                        C
7490 C                                                                              C
7491 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7492 C
7493 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7494 C           energy moment and not to the cluster cumulant.
7495 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7496       iti=itortyp(itype(i))
7497       itj=itortyp(itype(j))
7498       if (j.lt.nres-1) then
7499         itj1=itortyp(itype(j+1))
7500       else
7501         itj1=ntortyp+1
7502       endif
7503       itk=itortyp(itype(k))
7504       if (k.lt.nres-1) then
7505         itk1=itortyp(itype(k+1))
7506       else
7507         itk1=ntortyp+1
7508       endif
7509       itl=itortyp(itype(l))
7510       if (l.lt.nres-1) then
7511         itl1=itortyp(itype(l+1))
7512       else
7513         itl1=ntortyp+1
7514       endif
7515 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7516 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7517 cd     & ' itl',itl,' itl1',itl1
7518 #ifdef MOMENT
7519       if (imat.eq.1) then
7520         s1=dip(3,jj,i)*dip(3,kk,k)
7521       else
7522         s1=dip(2,jj,j)*dip(2,kk,l)
7523       endif
7524 #endif
7525       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7526       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7527       if (j.eq.l+1) then
7528         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7529         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7530       else
7531         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7532         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7533       endif
7534       call transpose2(EUg(1,1,k),auxmat(1,1))
7535       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7536       vv(1)=pizda(1,1)-pizda(2,2)
7537       vv(2)=pizda(2,1)+pizda(1,2)
7538       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7539 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7540 #ifdef MOMENT
7541       eello6_graph4=-(s1+s2+s3+s4)
7542 #else
7543       eello6_graph4=-(s2+s3+s4)
7544 #endif
7545       if (.not. calc_grad) return
7546 C Derivatives in gamma(i-1)
7547       if (i.gt.1) then
7548 #ifdef MOMENT
7549         if (imat.eq.1) then
7550           s1=dipderg(2,jj,i)*dip(3,kk,k)
7551         else
7552           s1=dipderg(4,jj,j)*dip(2,kk,l)
7553         endif
7554 #endif
7555         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7556         if (j.eq.l+1) then
7557           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7558           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7559         else
7560           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7561           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7562         endif
7563         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7564         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7565 cd          write (2,*) 'turn6 derivatives'
7566 #ifdef MOMENT
7567           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7568 #else
7569           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7570 #endif
7571         else
7572 #ifdef MOMENT
7573           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7574 #else
7575           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7576 #endif
7577         endif
7578       endif
7579 C Derivatives in gamma(k-1)
7580 #ifdef MOMENT
7581       if (imat.eq.1) then
7582         s1=dip(3,jj,i)*dipderg(2,kk,k)
7583       else
7584         s1=dip(2,jj,j)*dipderg(4,kk,l)
7585       endif
7586 #endif
7587       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7588       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7589       if (j.eq.l+1) then
7590         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7591         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7592       else
7593         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7594         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7595       endif
7596       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7597       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7598       vv(1)=pizda(1,1)-pizda(2,2)
7599       vv(2)=pizda(2,1)+pizda(1,2)
7600       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7601       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7602 #ifdef MOMENT
7603         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7604 #else
7605         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7606 #endif
7607       else
7608 #ifdef MOMENT
7609         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7610 #else
7611         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7612 #endif
7613       endif
7614 C Derivatives in gamma(j-1) or gamma(l-1)
7615       if (l.eq.j+1 .and. l.gt.1) then
7616         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7617         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7618         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7619         vv(1)=pizda(1,1)-pizda(2,2)
7620         vv(2)=pizda(2,1)+pizda(1,2)
7621         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7622         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7623       else if (j.gt.1) then
7624         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7625         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7626         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7627         vv(1)=pizda(1,1)-pizda(2,2)
7628         vv(2)=pizda(2,1)+pizda(1,2)
7629         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7630         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7631           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7632         else
7633           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7634         endif
7635       endif
7636 C Cartesian derivatives.
7637       do iii=1,2
7638         do kkk=1,5
7639           do lll=1,3
7640 #ifdef MOMENT
7641             if (iii.eq.1) then
7642               if (imat.eq.1) then
7643                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7644               else
7645                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7646               endif
7647             else
7648               if (imat.eq.1) then
7649                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7650               else
7651                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7652               endif
7653             endif
7654 #endif
7655             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7656      &        auxvec(1))
7657             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7658             if (j.eq.l+1) then
7659               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7660      &          b1(1,itj1),auxvec(1))
7661               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7662             else
7663               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7664      &          b1(1,itl1),auxvec(1))
7665               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7666             endif
7667             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7668      &        pizda(1,1))
7669             vv(1)=pizda(1,1)-pizda(2,2)
7670             vv(2)=pizda(2,1)+pizda(1,2)
7671             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7672             if (swap) then
7673               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7674 #ifdef MOMENT
7675                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7676      &             -(s1+s2+s4)
7677 #else
7678                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7679      &             -(s2+s4)
7680 #endif
7681                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7682               else
7683 #ifdef MOMENT
7684                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7685 #else
7686                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7687 #endif
7688                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7689               endif
7690             else
7691 #ifdef MOMENT
7692               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7693 #else
7694               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7695 #endif
7696               if (l.eq.j+1) then
7697                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7698               else
7699                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7700               endif
7701             endif
7702           enddo
7703         enddo
7704       enddo
7705       return
7706       end
7707 c----------------------------------------------------------------------------
7708       double precision function eello_turn6(i,jj,kk)
7709       implicit real*8 (a-h,o-z)
7710       include 'DIMENSIONS'
7711       include 'DIMENSIONS.ZSCOPT'
7712       include 'COMMON.IOUNITS'
7713       include 'COMMON.CHAIN'
7714       include 'COMMON.DERIV'
7715       include 'COMMON.INTERACT'
7716       include 'COMMON.CONTACTS'
7717       include 'COMMON.TORSION'
7718       include 'COMMON.VAR'
7719       include 'COMMON.GEO'
7720       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7721      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7722      &  ggg1(3),ggg2(3)
7723       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7724      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7725 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7726 C           the respective energy moment and not to the cluster cumulant.
7727       eello_turn6=0.0d0
7728       j=i+4
7729       k=i+1
7730       l=i+3
7731       iti=itortyp(itype(i))
7732       itk=itortyp(itype(k))
7733       itk1=itortyp(itype(k+1))
7734       itl=itortyp(itype(l))
7735       itj=itortyp(itype(j))
7736 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7737 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7738 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7739 cd        eello6=0.0d0
7740 cd        return
7741 cd      endif
7742 cd      write (iout,*)
7743 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7744 cd     &   ' and',k,l
7745 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7746       do iii=1,2
7747         do kkk=1,5
7748           do lll=1,3
7749             derx_turn(lll,kkk,iii)=0.0d0
7750           enddo
7751         enddo
7752       enddo
7753 cd      eij=1.0d0
7754 cd      ekl=1.0d0
7755 cd      ekont=1.0d0
7756       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7757 cd      eello6_5=0.0d0
7758 cd      write (2,*) 'eello6_5',eello6_5
7759 #ifdef MOMENT
7760       call transpose2(AEA(1,1,1),auxmat(1,1))
7761       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7762       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7763       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7764 #else
7765       s1 = 0.0d0
7766 #endif
7767       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7768       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7769       s2 = scalar2(b1(1,itk),vtemp1(1))
7770 #ifdef MOMENT
7771       call transpose2(AEA(1,1,2),atemp(1,1))
7772       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7773       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7774       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7775 #else
7776       s8=0.0d0
7777 #endif
7778       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7779       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7780       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7781 #ifdef MOMENT
7782       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7783       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7784       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7785       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7786       ss13 = scalar2(b1(1,itk),vtemp4(1))
7787       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7788 #else
7789       s13=0.0d0
7790 #endif
7791 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7792 c      s1=0.0d0
7793 c      s2=0.0d0
7794 c      s8=0.0d0
7795 c      s12=0.0d0
7796 c      s13=0.0d0
7797       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7798       if (calc_grad) then
7799 C Derivatives in gamma(i+2)
7800 #ifdef MOMENT
7801       call transpose2(AEA(1,1,1),auxmatd(1,1))
7802       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7803       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7804       call transpose2(AEAderg(1,1,2),atempd(1,1))
7805       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7806       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7807 #else
7808       s8d=0.0d0
7809 #endif
7810       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7811       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7812       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7813 c      s1d=0.0d0
7814 c      s2d=0.0d0
7815 c      s8d=0.0d0
7816 c      s12d=0.0d0
7817 c      s13d=0.0d0
7818       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7819 C Derivatives in gamma(i+3)
7820 #ifdef MOMENT
7821       call transpose2(AEA(1,1,1),auxmatd(1,1))
7822       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7823       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7824       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7825 #else
7826       s1d=0.0d0
7827 #endif
7828       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7829       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7830       s2d = scalar2(b1(1,itk),vtemp1d(1))
7831 #ifdef MOMENT
7832       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7833       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7834 #endif
7835       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7836 #ifdef MOMENT
7837       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7838       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7839       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7840 #else
7841       s13d=0.0d0
7842 #endif
7843 c      s1d=0.0d0
7844 c      s2d=0.0d0
7845 c      s8d=0.0d0
7846 c      s12d=0.0d0
7847 c      s13d=0.0d0
7848 #ifdef MOMENT
7849       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7850      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7851 #else
7852       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7853      &               -0.5d0*ekont*(s2d+s12d)
7854 #endif
7855 C Derivatives in gamma(i+4)
7856       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7857       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7858       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7859 #ifdef MOMENT
7860       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7861       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7862       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7863 #else
7864       s13d = 0.0d0
7865 #endif
7866 c      s1d=0.0d0
7867 c      s2d=0.0d0
7868 c      s8d=0.0d0
7869 C      s12d=0.0d0
7870 c      s13d=0.0d0
7871 #ifdef MOMENT
7872       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7873 #else
7874       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7875 #endif
7876 C Derivatives in gamma(i+5)
7877 #ifdef MOMENT
7878       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7879       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7880       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7881 #else
7882       s1d = 0.0d0
7883 #endif
7884       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7885       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7886       s2d = scalar2(b1(1,itk),vtemp1d(1))
7887 #ifdef MOMENT
7888       call transpose2(AEA(1,1,2),atempd(1,1))
7889       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7890       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7891 #else
7892       s8d = 0.0d0
7893 #endif
7894       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7895       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7896 #ifdef MOMENT
7897       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7898       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7899       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7900 #else
7901       s13d = 0.0d0
7902 #endif
7903 c      s1d=0.0d0
7904 c      s2d=0.0d0
7905 c      s8d=0.0d0
7906 c      s12d=0.0d0
7907 c      s13d=0.0d0
7908 #ifdef MOMENT
7909       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7910      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7911 #else
7912       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7913      &               -0.5d0*ekont*(s2d+s12d)
7914 #endif
7915 C Cartesian derivatives
7916       do iii=1,2
7917         do kkk=1,5
7918           do lll=1,3
7919 #ifdef MOMENT
7920             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7921             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7922             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7923 #else
7924             s1d = 0.0d0
7925 #endif
7926             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7927             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7928      &          vtemp1d(1))
7929             s2d = scalar2(b1(1,itk),vtemp1d(1))
7930 #ifdef MOMENT
7931             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7932             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7933             s8d = -(atempd(1,1)+atempd(2,2))*
7934      &           scalar2(cc(1,1,itl),vtemp2(1))
7935 #else
7936             s8d = 0.0d0
7937 #endif
7938             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7939      &           auxmatd(1,1))
7940             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7941             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7942 c      s1d=0.0d0
7943 c      s2d=0.0d0
7944 c      s8d=0.0d0
7945 c      s12d=0.0d0
7946 c      s13d=0.0d0
7947 #ifdef MOMENT
7948             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7949      &        - 0.5d0*(s1d+s2d)
7950 #else
7951             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7952      &        - 0.5d0*s2d
7953 #endif
7954 #ifdef MOMENT
7955             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7956      &        - 0.5d0*(s8d+s12d)
7957 #else
7958             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7959      &        - 0.5d0*s12d
7960 #endif
7961           enddo
7962         enddo
7963       enddo
7964 #ifdef MOMENT
7965       do kkk=1,5
7966         do lll=1,3
7967           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7968      &      achuj_tempd(1,1))
7969           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7970           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7971           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7972           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7973           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7974      &      vtemp4d(1))
7975           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7976           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7977           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7978         enddo
7979       enddo
7980 #endif
7981 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7982 cd     &  16*eel_turn6_num
7983 cd      goto 1112
7984       if (j.lt.nres-1) then
7985         j1=j+1
7986         j2=j-1
7987       else
7988         j1=j-1
7989         j2=j-2
7990       endif
7991       if (l.lt.nres-1) then
7992         l1=l+1
7993         l2=l-1
7994       else
7995         l1=l-1
7996         l2=l-2
7997       endif
7998       do ll=1,3
7999         ggg1(ll)=eel_turn6*g_contij(ll,1)
8000         ggg2(ll)=eel_turn6*g_contij(ll,2)
8001         ghalf=0.5d0*ggg1(ll)
8002 cd        ghalf=0.0d0
8003         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8004      &    +ekont*derx_turn(ll,2,1)
8005         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8006         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8007      &    +ekont*derx_turn(ll,4,1)
8008         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8009         ghalf=0.5d0*ggg2(ll)
8010 cd        ghalf=0.0d0
8011         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8012      &    +ekont*derx_turn(ll,2,2)
8013         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8014         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8015      &    +ekont*derx_turn(ll,4,2)
8016         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8017       enddo
8018 cd      goto 1112
8019       do m=i+1,j-1
8020         do ll=1,3
8021           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8022         enddo
8023       enddo
8024       do m=k+1,l-1
8025         do ll=1,3
8026           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8027         enddo
8028       enddo
8029 1112  continue
8030       do m=i+2,j2
8031         do ll=1,3
8032           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8033         enddo
8034       enddo
8035       do m=k+2,l2
8036         do ll=1,3
8037           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8038         enddo
8039       enddo
8040 cd      do iii=1,nres-3
8041 cd        write (2,*) iii,g_corr6_loc(iii)
8042 cd      enddo
8043       endif
8044       eello_turn6=ekont*eel_turn6
8045 cd      write (2,*) 'ekont',ekont
8046 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8047       return
8048       end
8049 crc-------------------------------------------------
8050       SUBROUTINE MATVEC2(A1,V1,V2)
8051       implicit real*8 (a-h,o-z)
8052       include 'DIMENSIONS'
8053       DIMENSION A1(2,2),V1(2),V2(2)
8054 c      DO 1 I=1,2
8055 c        VI=0.0
8056 c        DO 3 K=1,2
8057 c    3     VI=VI+A1(I,K)*V1(K)
8058 c        Vaux(I)=VI
8059 c    1 CONTINUE
8060
8061       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8062       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8063
8064       v2(1)=vaux1
8065       v2(2)=vaux2
8066       END
8067 C---------------------------------------
8068       SUBROUTINE MATMAT2(A1,A2,A3)
8069       implicit real*8 (a-h,o-z)
8070       include 'DIMENSIONS'
8071       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8072 c      DIMENSION AI3(2,2)
8073 c        DO  J=1,2
8074 c          A3IJ=0.0
8075 c          DO K=1,2
8076 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8077 c          enddo
8078 c          A3(I,J)=A3IJ
8079 c       enddo
8080 c      enddo
8081
8082       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8083       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8084       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8085       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8086
8087       A3(1,1)=AI3_11
8088       A3(2,1)=AI3_21
8089       A3(1,2)=AI3_12
8090       A3(2,2)=AI3_22
8091       END
8092
8093 c-------------------------------------------------------------------------
8094       double precision function scalar2(u,v)
8095       implicit none
8096       double precision u(2),v(2)
8097       double precision sc
8098       integer i
8099       scalar2=u(1)*v(1)+u(2)*v(2)
8100       return
8101       end
8102
8103 C-----------------------------------------------------------------------------
8104
8105       subroutine transpose2(a,at)
8106       implicit none
8107       double precision a(2,2),at(2,2)
8108       at(1,1)=a(1,1)
8109       at(1,2)=a(2,1)
8110       at(2,1)=a(1,2)
8111       at(2,2)=a(2,2)
8112       return
8113       end
8114 c--------------------------------------------------------------------------
8115       subroutine transpose(n,a,at)
8116       implicit none
8117       integer n,i,j
8118       double precision a(n,n),at(n,n)
8119       do i=1,n
8120         do j=1,n
8121           at(j,i)=a(i,j)
8122         enddo
8123       enddo
8124       return
8125       end
8126 C---------------------------------------------------------------------------
8127       subroutine prodmat3(a1,a2,kk,transp,prod)
8128       implicit none
8129       integer i,j
8130       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8131       logical transp
8132 crc      double precision auxmat(2,2),prod_(2,2)
8133
8134       if (transp) then
8135 crc        call transpose2(kk(1,1),auxmat(1,1))
8136 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8137 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8138
8139            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8140      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8141            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8142      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8143            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8144      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8145            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8146      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8147
8148       else
8149 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8150 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8151
8152            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8153      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8154            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8155      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8156            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8157      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8158            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8159      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8160
8161       endif
8162 c      call transpose2(a2(1,1),a2t(1,1))
8163
8164 crc      print *,transp
8165 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8166 crc      print *,((prod(i,j),i=1,2),j=1,2)
8167
8168       return
8169       end
8170 C-----------------------------------------------------------------------------
8171       double precision function scalar(u,v)
8172       implicit none
8173       double precision u(3),v(3)
8174       double precision sc
8175       integer i
8176       sc=0.0d0
8177       do i=1,3
8178         sc=sc+u(i)*v(i)
8179       enddo
8180       scalar=sc
8181       return
8182       end
8183