source/wham/src-old/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
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.CONTROL'
  26       double precision fact(6)
  27 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  28 cd    print *,'nnt=',nnt,' nct=',nct
  29 C
  30 C Compute the side-chain and electrostatic interaction energy
  31 C
  32       goto (101,102,103,104,105) ipot
  33 C Lennard-Jones potential.
  34   101 call elj(evdw,evdw_t)
  35 cd    print '(a)','Exit ELJ'
  36       goto 106
  37 C Lennard-Jones-Kihara potential (shifted).
  38   102 call eljk(evdw,evdw_t)
  39       goto 106
  40 C Berne-Pechukas potential (dilated LJ, angular dependence).
  41   103 call ebp(evdw,evdw_t)
  42       goto 106
  43 C Gay-Berne potential (shifted LJ, angular dependence).
  44   104 call egb(evdw,evdw_t)
  45       goto 106
  46 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  47   105 call egbv(evdw,evdw_t)
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  52 C
  53 C Calculate excluded-volume interaction energy between peptide groups
  54 C and side chains.
  55 C
  56       call escp(evdw2,evdw2_14)
  57 c
  58 c Calculate the bond-stretching energy
  59 c
  60       call ebond(estr)
  61 c      write (iout,*) "estr",estr
  62 C
  63 C Calculate the disulfide-bridge and other energy and the contributions
  64 C from other distance constraints.
  65 cd    print *,'Calling EHPB'
  66       call edis(ehpb)
  67 cd    print *,'EHPB exitted succesfully.'
  68 C
  69 C Calculate the virtual-bond-angle energy.
  70 C
  71       call ebend(ebe)
  72 cd    print *,'Bend energy finished.'
  73 C
  74 C Calculate the SC local energy.
  75 C
  76       call esc(escloc)
  77 cd    print *,'SCLOC energy finished.'
  78 C
  79 C Calculate the virtual-bond torsional energy.
  80 C
  81 cd    print *,'nterm=',nterm
  82       call etor(etors,edihcnstr,fact(1))
  83 C
  84 C 6/23/01 Calculate double-torsional energy
  85 C
  86       call etor_d(etors_d,fact(2))
  87 C
  88 C 21/5/07 Calculate local sicdechain correlation energy
  89 C
  90       call eback_sc_corr(esccor)
  91 C
  92 C 12/1/95 Multi-body terms
  93 C
  94       n_corr=0
  95       n_corr1=0
  96       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  97      &    .or. wturn6.gt.0.0d0) then
  98 c         print *,"calling multibody_eello"
  99          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 100 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 101 c         print *,ecorr,ecorr5,ecorr6,eturn6
 102       endif
 103       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 104          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 105       endif
 106
 107
 108 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 109       if (constr_homology.ge.1) then
 110         call e_modeller(ehomology_constr)
 111       else
 112         ehomology_constr=0.0d0
 113       endif
 114
 115 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 116
 117 C     BARTEK for dfa test!
 118       if (wdfa_dist.gt.0) call edfad(edfadis)
 119 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 120       if (wdfa_tor.gt.0) call edfat(edfator)
 121 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 122       if (wdfa_nei.gt.0) call edfan(edfanei)
 123 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 124       if (wdfa_beta.gt.0) call edfab(edfabet)
 125 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 126
 127 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 128 #ifdef SPLITELE
 129       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 130      & +wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 141      & +welec*fact(1)*(ees+evdw1)
 142      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 143      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 144      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 145      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 146      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 147      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 148      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 149      & +wdfa_beta*edfabet
 150 #endif
 151       energia(0)=etot
 152       energia(1)=evdw
 153 #ifdef SCP14
 154       energia(2)=evdw2-evdw2_14
 155       energia(17)=evdw2_14
 156 #else
 157       energia(2)=evdw2
 158       energia(17)=0.0d0
 159 #endif
 160 #ifdef SPLITELE
 161       energia(3)=ees
 162       energia(16)=evdw1
 163 #else
 164       energia(3)=ees+evdw1
 165       energia(16)=0.0d0
 166 #endif
 167       energia(4)=ecorr
 168       energia(5)=ecorr5
 169       energia(6)=ecorr6
 170       energia(7)=eel_loc
 171       energia(8)=eello_turn3
 172       energia(9)=eello_turn4
 173       energia(10)=eturn6
 174       energia(11)=ebe
 175       energia(12)=escloc
 176       energia(13)=etors
 177       energia(14)=etors_d
 178       energia(15)=ehpb
 179       energia(18)=estr
 180       energia(19)=esccor
 181       energia(20)=edihcnstr
 182       energia(21)=evdw_t
 183       energia(22)=ehomology_constr
 184       energia(23)=edfadis
 185       energia(24)=edfator
 186       energia(25)=edfanei
 187       energia(26)=edfabet
 188 c      if (dyn_ss) call dyn_set_nss
 189 c detecting NaNQ
 190 #ifdef ISNAN
 191 #ifdef AIX
 192       if (isnan(etot).ne.0) energia(0)=1.0d+99
 193 #else
 194       if (isnan(etot)) energia(0)=1.0d+99
 195 #endif
 196 #else
 197       i=0
 198 #ifdef WINPGI
 199       idumm=proc_proc(etot,i)
 200 #else
 201       call proc_proc(etot,i)
 202 #endif
 203       if(i.eq.1)energia(0)=1.0d+99
 204 #endif
 205 #ifdef MPL
 206 c     endif
 207 #endif
 208       if (calc_grad) then
 209 C
 210 C Sum up the components of the Cartesian gradient.
 211 C
 212 #ifdef SPLITELE
 213       do i=1,nct
 214         do j=1,3
 215           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 216      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 217      &                wbond*gradb(j,i)+
 218      &                wstrain*ghpbc(j,i)+
 219      &                wcorr*fact(3)*gradcorr(j,i)+
 220      &                wel_loc*fact(2)*gel_loc(j,i)+
 221      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 222      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 223      &                wcorr5*fact(4)*gradcorr5(j,i)+
 224      &                wcorr6*fact(5)*gradcorr6(j,i)+
 225      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 226      &                wsccor*fact(2)*gsccorc(j,i)+
 227      &                wdfa_dist*gdfad(j,i)+
 228      &                wdfa_tor*gdfat(j,i)+
 229      &                wdfa_nei*gdfan(j,i)+
 230      &                wdfa_beta*gdfab(j,i)
 231           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 232      &                  wbond*gradbx(j,i)+
 233      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 234      &                  wsccor*fact(2)*gsccorx(j,i)
 235         enddo
 236 #else
 237       do i=1,nct
 238         do j=1,3
 239           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 240      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 241      &                wbond*gradb(j,i)+
 242      &                wcorr*fact(3)*gradcorr(j,i)+
 243      &                wel_loc*fact(2)*gel_loc(j,i)+
 244      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 245      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 246      &                wcorr5*fact(4)*gradcorr5(j,i)+
 247      &                wcorr6*fact(5)*gradcorr6(j,i)+
 248      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 249      &                wsccor*fact(2)*gsccorc(j,i)+
 250      &                wdfa_dist*gdfad(j,i)+
 251      &                wdfa_tor*gdfat(j,i)+
 252      &                wdfa_nei*gdfan(j,i)+
 253      &                wdfa_beta*gdfab(j,i)
 254           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 255      &                  wbond*gradbx(j,i)+
 256      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 257      &                  wsccor*fact(1)*gsccorx(j,i)
 258         enddo
 259 #endif
 260       enddo
 261
 262
 263       do i=1,nres-3
 264         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 265      &   +wcorr5*fact(4)*g_corr5_loc(i)
 266      &   +wcorr6*fact(5)*g_corr6_loc(i)
 267      &   +wturn4*fact(3)*gel_loc_turn4(i)
 268      &   +wturn3*fact(2)*gel_loc_turn3(i)
 269      &   +wturn6*fact(5)*gel_loc_turn6(i)
 270      &   +wel_loc*fact(2)*gel_loc_loc(i)
 271      &   +wsccor*fact(1)*gsccor_loc(i)
 272       enddo
 273       endif
 274       return
 275       end
 276 C------------------------------------------------------------------------
 277       subroutine enerprint(energia,fact)
 278       implicit real*8 (a-h,o-z)
 279       include 'DIMENSIONS'
 280       include 'DIMENSIONS.ZSCOPT'
 281       include 'COMMON.IOUNITS'
 282       include 'COMMON.FFIELD'
 283       include 'COMMON.SBRIDGE'
 284       double precision energia(0:max_ene),fact(6)
 285       etot=energia(0)
 286       evdw=energia(1)+fact(6)*energia(21)
 287 #ifdef SCP14
 288       evdw2=energia(2)+energia(17)
 289 #else
 290       evdw2=energia(2)
 291 #endif
 292       ees=energia(3)
 293 #ifdef SPLITELE
 294       evdw1=energia(16)
 295 #endif
 296       ecorr=energia(4)
 297       ecorr5=energia(5)
 298       ecorr6=energia(6)
 299       eel_loc=energia(7)
 300       eello_turn3=energia(8)
 301       eello_turn4=energia(9)
 302       eello_turn6=energia(10)
 303       ebe=energia(11)
 304       escloc=energia(12)
 305       etors=energia(13)
 306       etors_d=energia(14)
 307       ehpb=energia(15)
 308       esccor=energia(19)
 309       edihcnstr=energia(20)
 310       estr=energia(18)
 311       ehomology_constr=energia(22)
 312       edfadis=energia(23)
 313       edfator=energia(24)
 314       edfanei=energia(25)
 315       edfabet=energia(26)
 316 #ifdef SPLITELE
 317       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 318      &  wvdwpp,
 319      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 320      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 321      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 322      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 323      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 324      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 325      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 326      &  wdfa_beta,etot
 327    10 format (/'Virtual-chain energies:'//
 328      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 329      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 330      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 331      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 332      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 333      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 334      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 335      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 336      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 337      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 338      & ' (SS bridges & dist. cnstr.)'/
 339      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 340      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 343      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 344      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 345      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 346      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 347      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 348      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 349      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 350      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 351      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 352      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 353      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 354      & 'ETOT=  ',1pE16.6,' (total)')
 355 #else
 356       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 357      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 358      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 359      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 360      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 361      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 362      &  edihcnstr,ehomology_constr,ebr*nss,
 363      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 364      &  wdfa_beta,etot
 365    10 format (/'Virtual-chain energies:'//
 366      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 367      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 368      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 369      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 370      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 371      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 372      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 373      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 374      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 375      & ' (SS bridges & dist. cnstr.)'/
 376      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 377      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 380      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 381      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 382      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 383      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 384      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 385      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 386      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 387      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 388      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 389      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 390      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 391      & 'ETOT=  ',1pE16.6,' (total)')
 392 #endif
 393       return
 394       end
 395 C-----------------------------------------------------------------------
 396       subroutine elj(evdw,evdw_t)
 397 C
 398 C This subroutine calculates the interaction energy of nonbonded side chains
 399 C assuming the LJ potential of interaction.
 400 C
 401       implicit real*8 (a-h,o-z)
 402       include 'DIMENSIONS'
 403       include 'DIMENSIONS.ZSCOPT'
 404       include "DIMENSIONS.COMPAR"
 405       parameter (accur=1.0d-10)
 406       include 'COMMON.GEO'
 407       include 'COMMON.VAR'
 408       include 'COMMON.LOCAL'
 409       include 'COMMON.CHAIN'
 410       include 'COMMON.DERIV'
 411       include 'COMMON.INTERACT'
 412       include 'COMMON.TORSION'
 413       include 'COMMON.ENEPS'
 414       include 'COMMON.SBRIDGE'
 415       include 'COMMON.NAMES'
 416       include 'COMMON.IOUNITS'
 417       include 'COMMON.CONTACTS'
 418       dimension gg(3)
 419       integer icant
 420       external icant
 421 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 422       do i=1,210
 423         do j=1,2
 424           eneps_temp(j,i)=0.0d0
 425         enddo
 426       enddo
 427       evdw=0.0D0
 428       evdw_t=0.0d0
 429       do i=iatsc_s,iatsc_e
 430         itypi=itype(i)
 431         itypi1=itype(i+1)
 432         xi=c(1,nres+i)
 433         yi=c(2,nres+i)
 434         zi=c(3,nres+i)
 435 C Change 12/1/95
 436         num_conti=0
 437 C
 438 C Calculate SC interaction energy.
 439 C
 440         do iint=1,nint_gr(i)
 441 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 442 cd   &                  'iend=',iend(i,iint)
 443           do j=istart(i,iint),iend(i,iint)
 444             itypj=itype(j)
 445             xj=c(1,nres+j)-xi
 446             yj=c(2,nres+j)-yi
 447             zj=c(3,nres+j)-zi
 448 C Change 12/1/95 to calculate four-body interactions
 449             rij=xj*xj+yj*yj+zj*zj
 450             rrij=1.0D0/rij
 451 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 452             eps0ij=eps(itypi,itypj)
 453             fac=rrij**expon2
 454             e1=fac*fac*aa(itypi,itypj)
 455             e2=fac*bb(itypi,itypj)
 456             evdwij=e1+e2
 457             ij=icant(itypi,itypj)
 458             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 459             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 460 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 461 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 462 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 463 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 464 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 465 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 466             if (bb(itypi,itypj).gt.0.0d0) then
 467               evdw=evdw+evdwij
 468             else
 469               evdw_t=evdw_t+evdwij
 470             endif
 471             if (calc_grad) then
 472 C
 473 C Calculate the components of the gradient in DC and X
 474 C
 475             fac=-rrij*(e1+evdwij)
 476             gg(1)=xj*fac
 477             gg(2)=yj*fac
 478             gg(3)=zj*fac
 479             do k=1,3
 480               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 481               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 482             enddo
 483             do k=i,j-1
 484               do l=1,3
 485                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 486               enddo
 487             enddo
 488             endif
 489 C
 490 C 12/1/95, revised on 5/20/97
 491 C
 492 C Calculate the contact function. The ith column of the array JCONT will
 493 C contain the numbers of atoms that make contacts with the atom I (of numbers
 494 C greater than I). The arrays FACONT and GACONT will contain the values of
 495 C the contact function and its derivative.
 496 C
 497 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 498 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 499 C Uncomment next line, if the correlation interactions are contact function only
 500             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 501               rij=dsqrt(rij)
 502               sigij=sigma(itypi,itypj)
 503               r0ij=rs0(itypi,itypj)
 504 C
 505 C Check whether the SC's are not too far to make a contact.
 506 C
 507               rcut=1.5d0*r0ij
 508               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 509 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 510 C
 511               if (fcont.gt.0.0D0) then
 512 C If the SC-SC distance if close to sigma, apply spline.
 513 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 514 cAdam &             fcont1,fprimcont1)
 515 cAdam           fcont1=1.0d0-fcont1
 516 cAdam           if (fcont1.gt.0.0d0) then
 517 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 518 cAdam             fcont=fcont*fcont1
 519 cAdam           endif
 520 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 521 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 522 cga             do k=1,3
 523 cga               gg(k)=gg(k)*eps0ij
 524 cga             enddo
 525 cga             eps0ij=-evdwij*eps0ij
 526 C Uncomment for AL's type of SC correlation interactions.
 527 cadam           eps0ij=-evdwij
 528                 num_conti=num_conti+1
 529                 jcont(num_conti,i)=j
 530                 facont(num_conti,i)=fcont*eps0ij
 531                 fprimcont=eps0ij*fprimcont/rij
 532                 fcont=expon*fcont
 533 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 534 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 535 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 536 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 537                 gacont(1,num_conti,i)=-fprimcont*xj
 538                 gacont(2,num_conti,i)=-fprimcont*yj
 539                 gacont(3,num_conti,i)=-fprimcont*zj
 540 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 541 cd              write (iout,'(2i3,3f10.5)')
 542 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 543               endif
 544             endif
 545           enddo      ! j
 546         enddo        ! iint
 547 C Change 12/1/95
 548         num_cont(i)=num_conti
 549       enddo          ! i
 550       if (calc_grad) then
 551       do i=1,nct
 552         do j=1,3
 553           gvdwc(j,i)=expon*gvdwc(j,i)
 554           gvdwx(j,i)=expon*gvdwx(j,i)
 555         enddo
 556       enddo
 557       endif
 558 C******************************************************************************
 559 C
 560 C                              N O T E !!!
 561 C
 562 C To save time, the factor of EXPON has been extracted from ALL components
 563 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 564 C use!
 565 C
 566 C******************************************************************************
 567       return
 568       end
 569 C-----------------------------------------------------------------------------
 570       subroutine eljk(evdw,evdw_t)
 571 C
 572 C This subroutine calculates the interaction energy of nonbonded side chains
 573 C assuming the LJK potential of interaction.
 574 C
 575       implicit real*8 (a-h,o-z)
 576       include 'DIMENSIONS'
 577       include 'DIMENSIONS.ZSCOPT'
 578       include "DIMENSIONS.COMPAR"
 579       include 'COMMON.GEO'
 580       include 'COMMON.VAR'
 581       include 'COMMON.LOCAL'
 582       include 'COMMON.CHAIN'
 583       include 'COMMON.DERIV'
 584       include 'COMMON.INTERACT'
 585       include 'COMMON.ENEPS'
 586       include 'COMMON.IOUNITS'
 587       include 'COMMON.NAMES'
 588       dimension gg(3)
 589       logical scheck
 590       integer icant
 591       external icant
 592 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 593       do i=1,210
 594         do j=1,2
 595           eneps_temp(j,i)=0.0d0
 596         enddo
 597       enddo
 598       evdw=0.0D0
 599       evdw_t=0.0d0
 600       do i=iatsc_s,iatsc_e
 601         itypi=itype(i)
 602         itypi1=itype(i+1)
 603         xi=c(1,nres+i)
 604         yi=c(2,nres+i)
 605         zi=c(3,nres+i)
 606 C
 607 C Calculate SC interaction energy.
 608 C
 609         do iint=1,nint_gr(i)
 610           do j=istart(i,iint),iend(i,iint)
 611             itypj=itype(j)
 612             xj=c(1,nres+j)-xi
 613             yj=c(2,nres+j)-yi
 614             zj=c(3,nres+j)-zi
 615             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 616             fac_augm=rrij**expon
 617             e_augm=augm(itypi,itypj)*fac_augm
 618             r_inv_ij=dsqrt(rrij)
 619             rij=1.0D0/r_inv_ij
 620             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 621             fac=r_shift_inv**expon
 622             e1=fac*fac*aa(itypi,itypj)
 623             e2=fac*bb(itypi,itypj)
 624             evdwij=e_augm+e1+e2
 625             ij=icant(itypi,itypj)
 626             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 627      &        /dabs(eps(itypi,itypj))
 628             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 629 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 630 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 631 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 632 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 633 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 634 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 635 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 636             if (bb(itypi,itypj).gt.0.0d0) then
 637               evdw=evdw+evdwij
 638             else
 639               evdw_t=evdw_t+evdwij
 640             endif
 641             if (calc_grad) then
 642 C
 643 C Calculate the components of the gradient in DC and X
 644 C
 645             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 646             gg(1)=xj*fac
 647             gg(2)=yj*fac
 648             gg(3)=zj*fac
 649             do k=1,3
 650               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 651               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 652             enddo
 653             do k=i,j-1
 654               do l=1,3
 655                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 656               enddo
 657             enddo
 658             endif
 659           enddo      ! j
 660         enddo        ! iint
 661       enddo          ! i
 662       if (calc_grad) then
 663       do i=1,nct
 664         do j=1,3
 665           gvdwc(j,i)=expon*gvdwc(j,i)
 666           gvdwx(j,i)=expon*gvdwx(j,i)
 667         enddo
 668       enddo
 669       endif
 670       return
 671       end
 672 C-----------------------------------------------------------------------------
 673       subroutine ebp(evdw,evdw_t)
 674 C
 675 C This subroutine calculates the interaction energy of nonbonded side chains
 676 C assuming the Berne-Pechukas potential of interaction.
 677 C
 678       implicit real*8 (a-h,o-z)
 679       include 'DIMENSIONS'
 680       include 'DIMENSIONS.ZSCOPT'
 681       include "DIMENSIONS.COMPAR"
 682       include 'COMMON.GEO'
 683       include 'COMMON.VAR'
 684       include 'COMMON.LOCAL'
 685       include 'COMMON.CHAIN'
 686       include 'COMMON.DERIV'
 687       include 'COMMON.NAMES'
 688       include 'COMMON.INTERACT'
 689       include 'COMMON.ENEPS'
 690       include 'COMMON.IOUNITS'
 691       include 'COMMON.CALC'
 692       common /srutu/ icall
 693 c     double precision rrsave(maxdim)
 694       logical lprn
 695       integer icant
 696       external icant
 697       do i=1,210
 698         do j=1,2
 699           eneps_temp(j,i)=0.0d0
 700         enddo
 701       enddo
 702       evdw=0.0D0
 703       evdw_t=0.0d0
 704 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 705 c     if (icall.eq.0) then
 706 c       lprn=.true.
 707 c     else
 708         lprn=.false.
 709 c     endif
 710       ind=0
 711       do i=iatsc_s,iatsc_e
 712         itypi=itype(i)
 713         itypi1=itype(i+1)
 714         xi=c(1,nres+i)
 715         yi=c(2,nres+i)
 716         zi=c(3,nres+i)
 717         dxi=dc_norm(1,nres+i)
 718         dyi=dc_norm(2,nres+i)
 719         dzi=dc_norm(3,nres+i)
 720         dsci_inv=vbld_inv(i+nres)
 721 C
 722 C Calculate SC interaction energy.
 723 C
 724         do iint=1,nint_gr(i)
 725           do j=istart(i,iint),iend(i,iint)
 726             ind=ind+1
 727             itypj=itype(j)
 728             dscj_inv=vbld_inv(j+nres)
 729             chi1=chi(itypi,itypj)
 730             chi2=chi(itypj,itypi)
 731             chi12=chi1*chi2
 732             chip1=chip(itypi)
 733             chip2=chip(itypj)
 734             chip12=chip1*chip2
 735             alf1=alp(itypi)
 736             alf2=alp(itypj)
 737             alf12=0.5D0*(alf1+alf2)
 738 C For diagnostics only!!!
 739 c           chi1=0.0D0
 740 c           chi2=0.0D0
 741 c           chi12=0.0D0
 742 c           chip1=0.0D0
 743 c           chip2=0.0D0
 744 c           chip12=0.0D0
 745 c           alf1=0.0D0
 746 c           alf2=0.0D0
 747 c           alf12=0.0D0
 748             xj=c(1,nres+j)-xi
 749             yj=c(2,nres+j)-yi
 750             zj=c(3,nres+j)-zi
 751             dxj=dc_norm(1,nres+j)
 752             dyj=dc_norm(2,nres+j)
 753             dzj=dc_norm(3,nres+j)
 754             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 755 cd          if (icall.eq.0) then
 756 cd            rrsave(ind)=rrij
 757 cd          else
 758 cd            rrij=rrsave(ind)
 759 cd          endif
 760             rij=dsqrt(rrij)
 761 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 762             call sc_angular
 763 C Calculate whole angle-dependent part of epsilon and contributions
 764 C to its derivatives
 765             fac=(rrij*sigsq)**expon2
 766             e1=fac*fac*aa(itypi,itypj)
 767             e2=fac*bb(itypi,itypj)
 768             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 769             eps2der=evdwij*eps3rt
 770             eps3der=evdwij*eps2rt
 771             evdwij=evdwij*eps2rt*eps3rt
 772             ij=icant(itypi,itypj)
 773             aux=eps1*eps2rt**2*eps3rt**2
 774             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 775      &        /dabs(eps(itypi,itypj))
 776             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 777             if (bb(itypi,itypj).gt.0.0d0) then
 778               evdw=evdw+evdwij
 779             else
 780               evdw_t=evdw_t+evdwij
 781             endif
 782             if (calc_grad) then
 783             if (lprn) then
 784             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 785             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 786 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 787 cd     &        restyp(itypi),i,restyp(itypj),j,
 788 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 789 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 790 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 791 cd     &        evdwij
 792             endif
 793 C Calculate gradient components.
 794             e1=e1*eps1*eps2rt**2*eps3rt**2
 795             fac=-expon*(e1+evdwij)
 796             sigder=fac/sigsq
 797             fac=rrij*fac
 798 C Calculate radial part of the gradient
 799             gg(1)=xj*fac
 800             gg(2)=yj*fac
 801             gg(3)=zj*fac
 802 C Calculate the angular part of the gradient and sum add the contributions
 803 C to the appropriate components of the Cartesian gradient.
 804             call sc_grad
 805             endif
 806           enddo      ! j
 807         enddo        ! iint
 808       enddo          ! i
 809 c     stop
 810       return
 811       end
 812 C-----------------------------------------------------------------------------
 813       subroutine egb(evdw,evdw_t)
 814 C
 815 C This subroutine calculates the interaction energy of nonbonded side chains
 816 C assuming the Gay-Berne potential of interaction.
 817 C
 818       implicit real*8 (a-h,o-z)
 819       include 'DIMENSIONS'
 820       include 'DIMENSIONS.ZSCOPT'
 821       include "DIMENSIONS.COMPAR"
 822       include 'COMMON.GEO'
 823       include 'COMMON.VAR'
 824       include 'COMMON.LOCAL'
 825       include 'COMMON.CHAIN'
 826       include 'COMMON.DERIV'
 827       include 'COMMON.NAMES'
 828       include 'COMMON.INTERACT'
 829       include 'COMMON.ENEPS'
 830       include 'COMMON.IOUNITS'
 831       include 'COMMON.CALC'
 832       include 'COMMON.SBRIDGE'
 833       logical lprn
 834       common /srutu/icall
 835       integer icant
 836       external icant
 837       do i=1,210
 838         do j=1,2
 839           eneps_temp(j,i)=0.0d0
 840         enddo
 841       enddo
 842 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 843       evdw=0.0D0
 844       evdw_t=0.0d0
 845       lprn=.false.
 846 c      if (icall.gt.0) lprn=.true.
 847       ind=0
 848       do i=iatsc_s,iatsc_e
 849         itypi=itype(i)
 850         itypi1=itype(i+1)
 851         xi=c(1,nres+i)
 852         yi=c(2,nres+i)
 853         zi=c(3,nres+i)
 854         dxi=dc_norm(1,nres+i)
 855         dyi=dc_norm(2,nres+i)
 856         dzi=dc_norm(3,nres+i)
 857         dsci_inv=vbld_inv(i+nres)
 858 C
 859 C Calculate SC interaction energy.
 860 C
 861         do iint=1,nint_gr(i)
 862           do j=istart(i,iint),iend(i,iint)
 863 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 864 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 865 C formation no electrostatic interactions should be calculated. If it
 866 C would be allowed NaN would appear
 867             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 868 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 869 C residue can or cannot form disulfide bond. There is still bug allowing
 870 C Cys...Cys...Cys bond formation
 871               call dyn_ssbond_ene(i,j,evdwij)
 872 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 873 C function in ssMD.F
 874               evdw=evdw+evdwij
 875 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 876 c     &                        'evdw',i,j,evdwij,' ss'
 877             ELSE
 878             ind=ind+1
 879             itypj=itype(j)
 880             dscj_inv=vbld_inv(j+nres)
 881             sig0ij=sigma(itypi,itypj)
 882             chi1=chi(itypi,itypj)
 883             chi2=chi(itypj,itypi)
 884             chi12=chi1*chi2
 885             chip1=chip(itypi)
 886             chip2=chip(itypj)
 887             chip12=chip1*chip2
 888             alf1=alp(itypi)
 889             alf2=alp(itypj)
 890             alf12=0.5D0*(alf1+alf2)
 891 C For diagnostics only!!!
 892 c           chi1=0.0D0
 893 c           chi2=0.0D0
 894 c           chi12=0.0D0
 895 c           chip1=0.0D0
 896 c           chip2=0.0D0
 897 c           chip12=0.0D0
 898 c           alf1=0.0D0
 899 c           alf2=0.0D0
 900 c           alf12=0.0D0
 901             xj=c(1,nres+j)-xi
 902             yj=c(2,nres+j)-yi
 903             zj=c(3,nres+j)-zi
 904             dxj=dc_norm(1,nres+j)
 905             dyj=dc_norm(2,nres+j)
 906             dzj=dc_norm(3,nres+j)
 907 c            write (iout,*) i,j,xj,yj,zj
 908             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 909             rij=dsqrt(rrij)
 910 C Calculate angle-dependent terms of energy and contributions to their
 911 C derivatives.
 912             call sc_angular
 913             sigsq=1.0D0/sigsq
 914             sig=sig0ij*dsqrt(sigsq)
 915             rij_shift=1.0D0/rij-sig+sig0ij
 916 C I hate to put IF's in the loops, but here don't have another choice!!!!
 917             if (rij_shift.le.0.0D0) then
 918               evdw=1.0D20
 919               return
 920             endif
 921             sigder=-sig*sigsq
 922 c---------------------------------------------------------------
 923             rij_shift=1.0D0/rij_shift
 924             fac=rij_shift**expon
 925             e1=fac*fac*aa(itypi,itypj)
 926             e2=fac*bb(itypi,itypj)
 927             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 928             eps2der=evdwij*eps3rt
 929             eps3der=evdwij*eps2rt
 930             evdwij=evdwij*eps2rt*eps3rt
 931             if (bb(itypi,itypj).gt.0) then
 932               evdw=evdw+evdwij
 933             else
 934               evdw_t=evdw_t+evdwij
 935             endif
 936             ij=icant(itypi,itypj)
 937             aux=eps1*eps2rt**2*eps3rt**2
 938             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 939      &        /dabs(eps(itypi,itypj))
 940             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 941 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 942 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 943 c     &         aux*e2/eps(itypi,itypj)
 944 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 945             if (lprn) then
 946             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 947             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 948             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 949      &        restyp(itypi),i,restyp(itypj),j,
 950      &        epsi,sigm,chi1,chi2,chip1,chip2,
 951      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 952      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 953      &        evdwij
 954             endif
 955             if (calc_grad) then
 956 C Calculate gradient components.
 957             e1=e1*eps1*eps2rt**2*eps3rt**2
 958             fac=-expon*(e1+evdwij)*rij_shift
 959             sigder=fac*sigder
 960             fac=rij*fac
 961 C Calculate the radial part of the gradient
 962             gg(1)=xj*fac
 963             gg(2)=yj*fac
 964             gg(3)=zj*fac
 965 C Calculate angular part of the gradient.
 966             call sc_grad
 967             endif
 968             ENDIF    ! dyn_ss
 969           enddo      ! j
 970         enddo        ! iint
 971       enddo          ! i
 972       return
 973       end
 974 C-----------------------------------------------------------------------------
 975       subroutine egbv(evdw,evdw_t)
 976 C
 977 C This subroutine calculates the interaction energy of nonbonded side chains
 978 C assuming the Gay-Berne-Vorobjev potential of interaction.
 979 C
 980       implicit real*8 (a-h,o-z)
 981       include 'DIMENSIONS'
 982       include 'DIMENSIONS.ZSCOPT'
 983       include "DIMENSIONS.COMPAR"
 984       include 'COMMON.GEO'
 985       include 'COMMON.VAR'
 986       include 'COMMON.LOCAL'
 987       include 'COMMON.CHAIN'
 988       include 'COMMON.DERIV'
 989       include 'COMMON.NAMES'
 990       include 'COMMON.INTERACT'
 991       include 'COMMON.ENEPS'
 992       include 'COMMON.IOUNITS'
 993       include 'COMMON.CALC'
 994       common /srutu/ icall
 995       logical lprn
 996       integer icant
 997       external icant
 998       do i=1,210
 999         do j=1,2
1000           eneps_temp(j,i)=0.0d0
1001         enddo
1002       enddo
1003       evdw=0.0D0
1004       evdw_t=0.0d0
1005 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1006       evdw=0.0D0
1007       lprn=.false.
1008 c      if (icall.gt.0) lprn=.true.
1009       ind=0
1010       do i=iatsc_s,iatsc_e
1011         itypi=itype(i)
1012         itypi1=itype(i+1)
1013         xi=c(1,nres+i)
1014         yi=c(2,nres+i)
1015         zi=c(3,nres+i)
1016         dxi=dc_norm(1,nres+i)
1017         dyi=dc_norm(2,nres+i)
1018         dzi=dc_norm(3,nres+i)
1019         dsci_inv=vbld_inv(i+nres)
1020 C
1021 C Calculate SC interaction energy.
1022 C
1023         do iint=1,nint_gr(i)
1024           do j=istart(i,iint),iend(i,iint)
1025             ind=ind+1
1026             itypj=itype(j)
1027             dscj_inv=vbld_inv(j+nres)
1028             sig0ij=sigma(itypi,itypj)
1029             r0ij=r0(itypi,itypj)
1030             chi1=chi(itypi,itypj)
1031             chi2=chi(itypj,itypi)
1032             chi12=chi1*chi2
1033             chip1=chip(itypi)
1034             chip2=chip(itypj)
1035             chip12=chip1*chip2
1036             alf1=alp(itypi)
1037             alf2=alp(itypj)
1038             alf12=0.5D0*(alf1+alf2)
1039 C For diagnostics only!!!
1040 c           chi1=0.0D0
1041 c           chi2=0.0D0
1042 c           chi12=0.0D0
1043 c           chip1=0.0D0
1044 c           chip2=0.0D0
1045 c           chip12=0.0D0
1046 c           alf1=0.0D0
1047 c           alf2=0.0D0
1048 c           alf12=0.0D0
1049             xj=c(1,nres+j)-xi
1050             yj=c(2,nres+j)-yi
1051             zj=c(3,nres+j)-zi
1052             dxj=dc_norm(1,nres+j)
1053             dyj=dc_norm(2,nres+j)
1054             dzj=dc_norm(3,nres+j)
1055             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1056             rij=dsqrt(rrij)
1057 C Calculate angle-dependent terms of energy and contributions to their
1058 C derivatives.
1059             call sc_angular
1060             sigsq=1.0D0/sigsq
1061             sig=sig0ij*dsqrt(sigsq)
1062             rij_shift=1.0D0/rij-sig+r0ij
1063 C I hate to put IF's in the loops, but here don't have another choice!!!!
1064             if (rij_shift.le.0.0D0) then
1065               evdw=1.0D20
1066               return
1067             endif
1068             sigder=-sig*sigsq
1069 c---------------------------------------------------------------
1070             rij_shift=1.0D0/rij_shift
1071             fac=rij_shift**expon
1072             e1=fac*fac*aa(itypi,itypj)
1073             e2=fac*bb(itypi,itypj)
1074             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1075             eps2der=evdwij*eps3rt
1076             eps3der=evdwij*eps2rt
1077             fac_augm=rrij**expon
1078             e_augm=augm(itypi,itypj)*fac_augm
1079             evdwij=evdwij*eps2rt*eps3rt
1080             if (bb(itypi,itypj).gt.0.0d0) then
1081               evdw=evdw+evdwij+e_augm
1082             else
1083               evdw_t=evdw_t+evdwij+e_augm
1084             endif
1085             ij=icant(itypi,itypj)
1086             aux=eps1*eps2rt**2*eps3rt**2
1087             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1088      &        /dabs(eps(itypi,itypj))
1089             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1090 c            eneps_temp(ij)=eneps_temp(ij)
1091 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1092 c            if (lprn) then
1093 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1096 c     &        restyp(itypi),i,restyp(itypj),j,
1097 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1098 c     &        chi1,chi2,chip1,chip2,
1099 c     &        eps1,eps2rt**2,eps3rt**2,
1100 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1101 c     &        evdwij+e_augm
1102 c            endif
1103             if (calc_grad) then
1104 C Calculate gradient components.
1105             e1=e1*eps1*eps2rt**2*eps3rt**2
1106             fac=-expon*(e1+evdwij)*rij_shift
1107             sigder=fac*sigder
1108             fac=rij*fac-2*expon*rrij*e_augm
1109 C Calculate the radial part of the gradient
1110             gg(1)=xj*fac
1111             gg(2)=yj*fac
1112             gg(3)=zj*fac
1113 C Calculate angular part of the gradient.
1114             call sc_grad
1115             endif
1116           enddo      ! j
1117         enddo        ! iint
1118       enddo          ! i
1119       return
1120       end
1121 C-----------------------------------------------------------------------------
1122       subroutine sc_angular
1123 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1124 C om12. Called by ebp, egb, and egbv.
1125       implicit none
1126       include 'COMMON.CALC'
1127       erij(1)=xj*rij
1128       erij(2)=yj*rij
1129       erij(3)=zj*rij
1130       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1131       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1132       om12=dxi*dxj+dyi*dyj+dzi*dzj
1133       chiom12=chi12*om12
1134 C Calculate eps1(om12) and its derivative in om12
1135       faceps1=1.0D0-om12*chiom12
1136       faceps1_inv=1.0D0/faceps1
1137       eps1=dsqrt(faceps1_inv)
1138 C Following variable is eps1*deps1/dom12
1139       eps1_om12=faceps1_inv*chiom12
1140 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1141 C and om12.
1142       om1om2=om1*om2
1143       chiom1=chi1*om1
1144       chiom2=chi2*om2
1145       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1146       sigsq=1.0D0-facsig*faceps1_inv
1147       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1148       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1149       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1150 C Calculate eps2 and its derivatives in om1, om2, and om12.
1151       chipom1=chip1*om1
1152       chipom2=chip2*om2
1153       chipom12=chip12*om12
1154       facp=1.0D0-om12*chipom12
1155       facp_inv=1.0D0/facp
1156       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1157 C Following variable is the square root of eps2
1158       eps2rt=1.0D0-facp1*facp_inv
1159 C Following three variables are the derivatives of the square root of eps
1160 C in om1, om2, and om12.
1161       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1162       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1163       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1164 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1165       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1166 C Calculate whole angle-dependent part of epsilon and contributions
1167 C to its derivatives
1168       return
1169       end
1170 C----------------------------------------------------------------------------
1171       subroutine sc_grad
1172       implicit real*8 (a-h,o-z)
1173       include 'DIMENSIONS'
1174       include 'DIMENSIONS.ZSCOPT'
1175       include 'COMMON.CHAIN'
1176       include 'COMMON.DERIV'
1177       include 'COMMON.CALC'
1178       double precision dcosom1(3),dcosom2(3)
1179       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1180       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1181       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1182      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1183       do k=1,3
1184         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1185         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1186       enddo
1187       do k=1,3
1188         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1189       enddo
1190       do k=1,3
1191         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1192      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1193      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1194         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1196      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1197       enddo
1198 C
1199 C Calculate the components of the gradient in DC and X
1200 C
1201       do k=i,j-1
1202         do l=1,3
1203           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1204         enddo
1205       enddo
1206       return
1207       end
1208 c------------------------------------------------------------------------------
1209       subroutine vec_and_deriv
1210       implicit real*8 (a-h,o-z)
1211       include 'DIMENSIONS'
1212       include 'DIMENSIONS.ZSCOPT'
1213       include 'COMMON.IOUNITS'
1214       include 'COMMON.GEO'
1215       include 'COMMON.VAR'
1216       include 'COMMON.LOCAL'
1217       include 'COMMON.CHAIN'
1218       include 'COMMON.VECTORS'
1219       include 'COMMON.DERIV'
1220       include 'COMMON.INTERACT'
1221       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1222 C Compute the local reference systems. For reference system (i), the
1223 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1224 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1225       do i=1,nres-1
1226 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1227           if (i.eq.nres-1) then
1228 C Case of the last full residue
1229 C Compute the Z-axis
1230             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1231             costh=dcos(pi-theta(nres))
1232             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1233             do k=1,3
1234               uz(k,i)=fac*uz(k,i)
1235             enddo
1236             if (calc_grad) then
1237 C Compute the derivatives of uz
1238             uzder(1,1,1)= 0.0d0
1239             uzder(2,1,1)=-dc_norm(3,i-1)
1240             uzder(3,1,1)= dc_norm(2,i-1)
1241             uzder(1,2,1)= dc_norm(3,i-1)
1242             uzder(2,2,1)= 0.0d0
1243             uzder(3,2,1)=-dc_norm(1,i-1)
1244             uzder(1,3,1)=-dc_norm(2,i-1)
1245             uzder(2,3,1)= dc_norm(1,i-1)
1246             uzder(3,3,1)= 0.0d0
1247             uzder(1,1,2)= 0.0d0
1248             uzder(2,1,2)= dc_norm(3,i)
1249             uzder(3,1,2)=-dc_norm(2,i)
1250             uzder(1,2,2)=-dc_norm(3,i)
1251             uzder(2,2,2)= 0.0d0
1252             uzder(3,2,2)= dc_norm(1,i)
1253             uzder(1,3,2)= dc_norm(2,i)
1254             uzder(2,3,2)=-dc_norm(1,i)
1255             uzder(3,3,2)= 0.0d0
1256             endif
1257 C Compute the Y-axis
1258             facy=fac
1259             do k=1,3
1260               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1261             enddo
1262             if (calc_grad) then
1263 C Compute the derivatives of uy
1264             do j=1,3
1265               do k=1,3
1266                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1267      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1268                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1269               enddo
1270               uyder(j,j,1)=uyder(j,j,1)-costh
1271               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1272             enddo
1273             do j=1,2
1274               do k=1,3
1275                 do l=1,3
1276                   uygrad(l,k,j,i)=uyder(l,k,j)
1277                   uzgrad(l,k,j,i)=uzder(l,k,j)
1278                 enddo
1279               enddo
1280             enddo
1281             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1282             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1283             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1284             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1285             endif
1286           else
1287 C Other residues
1288 C Compute the Z-axis
1289             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1290             costh=dcos(pi-theta(i+2))
1291             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1292             do k=1,3
1293               uz(k,i)=fac*uz(k,i)
1294             enddo
1295             if (calc_grad) then
1296 C Compute the derivatives of uz
1297             uzder(1,1,1)= 0.0d0
1298             uzder(2,1,1)=-dc_norm(3,i+1)
1299             uzder(3,1,1)= dc_norm(2,i+1)
1300             uzder(1,2,1)= dc_norm(3,i+1)
1301             uzder(2,2,1)= 0.0d0
1302             uzder(3,2,1)=-dc_norm(1,i+1)
1303             uzder(1,3,1)=-dc_norm(2,i+1)
1304             uzder(2,3,1)= dc_norm(1,i+1)
1305             uzder(3,3,1)= 0.0d0
1306             uzder(1,1,2)= 0.0d0
1307             uzder(2,1,2)= dc_norm(3,i)
1308             uzder(3,1,2)=-dc_norm(2,i)
1309             uzder(1,2,2)=-dc_norm(3,i)
1310             uzder(2,2,2)= 0.0d0
1311             uzder(3,2,2)= dc_norm(1,i)
1312             uzder(1,3,2)= dc_norm(2,i)
1313             uzder(2,3,2)=-dc_norm(1,i)
1314             uzder(3,3,2)= 0.0d0
1315             endif
1316 C Compute the Y-axis
1317             facy=fac
1318             do k=1,3
1319               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1320             enddo
1321             if (calc_grad) then
1322 C Compute the derivatives of uy
1323             do j=1,3
1324               do k=1,3
1325                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1326      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1327                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1328               enddo
1329               uyder(j,j,1)=uyder(j,j,1)-costh
1330               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1331             enddo
1332             do j=1,2
1333               do k=1,3
1334                 do l=1,3
1335                   uygrad(l,k,j,i)=uyder(l,k,j)
1336                   uzgrad(l,k,j,i)=uzder(l,k,j)
1337                 enddo
1338               enddo
1339             enddo
1340             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1341             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1342             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1343             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1344           endif
1345           endif
1346       enddo
1347       if (calc_grad) then
1348       do i=1,nres-1
1349         vbld_inv_temp(1)=vbld_inv(i+1)
1350         if (i.lt.nres-1) then
1351           vbld_inv_temp(2)=vbld_inv(i+2)
1352         else
1353           vbld_inv_temp(2)=vbld_inv(i)
1354         endif
1355         do j=1,2
1356           do k=1,3
1357             do l=1,3
1358               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1359               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1360             enddo
1361           enddo
1362         enddo
1363       enddo
1364       endif
1365       return
1366       end
1367 C-----------------------------------------------------------------------------
1368       subroutine vec_and_deriv_test
1369       implicit real*8 (a-h,o-z)
1370       include 'DIMENSIONS'
1371       include 'DIMENSIONS.ZSCOPT'
1372       include 'COMMON.IOUNITS'
1373       include 'COMMON.GEO'
1374       include 'COMMON.VAR'
1375       include 'COMMON.LOCAL'
1376       include 'COMMON.CHAIN'
1377       include 'COMMON.VECTORS'
1378       dimension uyder(3,3,2),uzder(3,3,2)
1379 C Compute the local reference systems. For reference system (i), the
1380 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1381 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1382       do i=1,nres-1
1383           if (i.eq.nres-1) then
1384 C Case of the last full residue
1385 C Compute the Z-axis
1386             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1387             costh=dcos(pi-theta(nres))
1388             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1389 c            write (iout,*) 'fac',fac,
1390 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1391             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             do k=1,3
1393               uz(k,i)=fac*uz(k,i)
1394             enddo
1395 C Compute the derivatives of uz
1396             uzder(1,1,1)= 0.0d0
1397             uzder(2,1,1)=-dc_norm(3,i-1)
1398             uzder(3,1,1)= dc_norm(2,i-1)
1399             uzder(1,2,1)= dc_norm(3,i-1)
1400             uzder(2,2,1)= 0.0d0
1401             uzder(3,2,1)=-dc_norm(1,i-1)
1402             uzder(1,3,1)=-dc_norm(2,i-1)
1403             uzder(2,3,1)= dc_norm(1,i-1)
1404             uzder(3,3,1)= 0.0d0
1405             uzder(1,1,2)= 0.0d0
1406             uzder(2,1,2)= dc_norm(3,i)
1407             uzder(3,1,2)=-dc_norm(2,i)
1408             uzder(1,2,2)=-dc_norm(3,i)
1409             uzder(2,2,2)= 0.0d0
1410             uzder(3,2,2)= dc_norm(1,i)
1411             uzder(1,3,2)= dc_norm(2,i)
1412             uzder(2,3,2)=-dc_norm(1,i)
1413             uzder(3,3,2)= 0.0d0
1414 C Compute the Y-axis
1415             do k=1,3
1416               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1417             enddo
1418             facy=fac
1419             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1420      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1421      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1422             do k=1,3
1423 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1424               uy(k,i)=
1425 c     &        facy*(
1426      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1427      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1428 c     &        )
1429             enddo
1430 c            write (iout,*) 'facy',facy,
1431 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1432             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             do k=1,3
1434               uy(k,i)=facy*uy(k,i)
1435             enddo
1436 C Compute the derivatives of uy
1437             do j=1,3
1438               do k=1,3
1439                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1440      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1441                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1442               enddo
1443 c              uyder(j,j,1)=uyder(j,j,1)-costh
1444 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1445               uyder(j,j,1)=uyder(j,j,1)
1446      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1447               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1448      &          +uyder(j,j,2)
1449             enddo
1450             do j=1,2
1451               do k=1,3
1452                 do l=1,3
1453                   uygrad(l,k,j,i)=uyder(l,k,j)
1454                   uzgrad(l,k,j,i)=uzder(l,k,j)
1455                 enddo
1456               enddo
1457             enddo
1458             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1459             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1460             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1461             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1462           else
1463 C Other residues
1464 C Compute the Z-axis
1465             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1466             costh=dcos(pi-theta(i+2))
1467             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1468             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1469             do k=1,3
1470               uz(k,i)=fac*uz(k,i)
1471             enddo
1472 C Compute the derivatives of uz
1473             uzder(1,1,1)= 0.0d0
1474             uzder(2,1,1)=-dc_norm(3,i+1)
1475             uzder(3,1,1)= dc_norm(2,i+1)
1476             uzder(1,2,1)= dc_norm(3,i+1)
1477             uzder(2,2,1)= 0.0d0
1478             uzder(3,2,1)=-dc_norm(1,i+1)
1479             uzder(1,3,1)=-dc_norm(2,i+1)
1480             uzder(2,3,1)= dc_norm(1,i+1)
1481             uzder(3,3,1)= 0.0d0
1482             uzder(1,1,2)= 0.0d0
1483             uzder(2,1,2)= dc_norm(3,i)
1484             uzder(3,1,2)=-dc_norm(2,i)
1485             uzder(1,2,2)=-dc_norm(3,i)
1486             uzder(2,2,2)= 0.0d0
1487             uzder(3,2,2)= dc_norm(1,i)
1488             uzder(1,3,2)= dc_norm(2,i)
1489             uzder(2,3,2)=-dc_norm(1,i)
1490             uzder(3,3,2)= 0.0d0
1491 C Compute the Y-axis
1492             facy=fac
1493             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1494      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1495      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1496             do k=1,3
1497 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1498               uy(k,i)=
1499 c     &        facy*(
1500      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1501      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1502 c     &        )
1503             enddo
1504 c            write (iout,*) 'facy',facy,
1505 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1506             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             do k=1,3
1508               uy(k,i)=facy*uy(k,i)
1509             enddo
1510 C Compute the derivatives of uy
1511             do j=1,3
1512               do k=1,3
1513                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1514      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1515                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1516               enddo
1517 c              uyder(j,j,1)=uyder(j,j,1)-costh
1518 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1519               uyder(j,j,1)=uyder(j,j,1)
1520      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1521               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1522      &          +uyder(j,j,2)
1523             enddo
1524             do j=1,2
1525               do k=1,3
1526                 do l=1,3
1527                   uygrad(l,k,j,i)=uyder(l,k,j)
1528                   uzgrad(l,k,j,i)=uzder(l,k,j)
1529                 enddo
1530               enddo
1531             enddo
1532             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1533             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1534             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1535             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1536           endif
1537       enddo
1538       do i=1,nres-1
1539         do j=1,2
1540           do k=1,3
1541             do l=1,3
1542               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1543               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1544             enddo
1545           enddo
1546         enddo
1547       enddo
1548       return
1549       end
1550 C-----------------------------------------------------------------------------
1551       subroutine check_vecgrad
1552       implicit real*8 (a-h,o-z)
1553       include 'DIMENSIONS'
1554       include 'DIMENSIONS.ZSCOPT'
1555       include 'COMMON.IOUNITS'
1556       include 'COMMON.GEO'
1557       include 'COMMON.VAR'
1558       include 'COMMON.LOCAL'
1559       include 'COMMON.CHAIN'
1560       include 'COMMON.VECTORS'
1561       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1562       dimension uyt(3,maxres),uzt(3,maxres)
1563       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1564       double precision delta /1.0d-7/
1565       call vec_and_deriv
1566 cd      do i=1,nres
1567 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1570 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1571 cd     &     (dc_norm(if90,i),if90=1,3)
1572 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1574 cd          write(iout,'(a)')
1575 cd      enddo
1576       do i=1,nres
1577         do j=1,2
1578           do k=1,3
1579             do l=1,3
1580               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1581               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1582             enddo
1583           enddo
1584         enddo
1585       enddo
1586       call vec_and_deriv
1587       do i=1,nres
1588         do j=1,3
1589           uyt(j,i)=uy(j,i)
1590           uzt(j,i)=uz(j,i)
1591         enddo
1592       enddo
1593       do i=1,nres
1594 cd        write (iout,*) 'i=',i
1595         do k=1,3
1596           erij(k)=dc_norm(k,i)
1597         enddo
1598         do j=1,3
1599           do k=1,3
1600             dc_norm(k,i)=erij(k)
1601           enddo
1602           dc_norm(j,i)=dc_norm(j,i)+delta
1603 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1604 c          do k=1,3
1605 c            dc_norm(k,i)=dc_norm(k,i)/fac
1606 c          enddo
1607 c          write (iout,*) (dc_norm(k,i),k=1,3)
1608 c          write (iout,*) (erij(k),k=1,3)
1609           call vec_and_deriv
1610           do k=1,3
1611             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1612             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1613             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1614             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1615           enddo
1616 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1617 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1618 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1619         enddo
1620         do k=1,3
1621           dc_norm(k,i)=erij(k)
1622         enddo
1623 cd        do k=1,3
1624 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1625 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1626 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1627 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1628 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1629 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1630 cd          write (iout,'(a)')
1631 cd        enddo
1632       enddo
1633       return
1634       end
1635 C--------------------------------------------------------------------------
1636       subroutine set_matrices
1637       implicit real*8 (a-h,o-z)
1638       include 'DIMENSIONS'
1639       include 'DIMENSIONS.ZSCOPT'
1640       include 'COMMON.IOUNITS'
1641       include 'COMMON.GEO'
1642       include 'COMMON.VAR'
1643       include 'COMMON.LOCAL'
1644       include 'COMMON.CHAIN'
1645       include 'COMMON.DERIV'
1646       include 'COMMON.INTERACT'
1647       include 'COMMON.CONTACTS'
1648       include 'COMMON.TORSION'
1649       include 'COMMON.VECTORS'
1650       include 'COMMON.FFIELD'
1651       double precision auxvec(2),auxmat(2,2)
1652 C
1653 C Compute the virtual-bond-torsional-angle dependent quantities needed
1654 C to calculate the el-loc multibody terms of various order.
1655 C
1656       do i=3,nres+1
1657         if (i .lt. nres+1) then
1658           sin1=dsin(phi(i))
1659           cos1=dcos(phi(i))
1660           sintab(i-2)=sin1
1661           costab(i-2)=cos1
1662           obrot(1,i-2)=cos1
1663           obrot(2,i-2)=sin1
1664           sin2=dsin(2*phi(i))
1665           cos2=dcos(2*phi(i))
1666           sintab2(i-2)=sin2
1667           costab2(i-2)=cos2
1668           obrot2(1,i-2)=cos2
1669           obrot2(2,i-2)=sin2
1670           Ug(1,1,i-2)=-cos1
1671           Ug(1,2,i-2)=-sin1
1672           Ug(2,1,i-2)=-sin1
1673           Ug(2,2,i-2)= cos1
1674           Ug2(1,1,i-2)=-cos2
1675           Ug2(1,2,i-2)=-sin2
1676           Ug2(2,1,i-2)=-sin2
1677           Ug2(2,2,i-2)= cos2
1678         else
1679           costab(i-2)=1.0d0
1680           sintab(i-2)=0.0d0
1681           obrot(1,i-2)=1.0d0
1682           obrot(2,i-2)=0.0d0
1683           obrot2(1,i-2)=0.0d0
1684           obrot2(2,i-2)=0.0d0
1685           Ug(1,1,i-2)=1.0d0
1686           Ug(1,2,i-2)=0.0d0
1687           Ug(2,1,i-2)=0.0d0
1688           Ug(2,2,i-2)=1.0d0
1689           Ug2(1,1,i-2)=0.0d0
1690           Ug2(1,2,i-2)=0.0d0
1691           Ug2(2,1,i-2)=0.0d0
1692           Ug2(2,2,i-2)=0.0d0
1693         endif
1694         if (i .gt. 3 .and. i .lt. nres+1) then
1695           obrot_der(1,i-2)=-sin1
1696           obrot_der(2,i-2)= cos1
1697           Ugder(1,1,i-2)= sin1
1698           Ugder(1,2,i-2)=-cos1
1699           Ugder(2,1,i-2)=-cos1
1700           Ugder(2,2,i-2)=-sin1
1701           dwacos2=cos2+cos2
1702           dwasin2=sin2+sin2
1703           obrot2_der(1,i-2)=-dwasin2
1704           obrot2_der(2,i-2)= dwacos2
1705           Ug2der(1,1,i-2)= dwasin2
1706           Ug2der(1,2,i-2)=-dwacos2
1707           Ug2der(2,1,i-2)=-dwacos2
1708           Ug2der(2,2,i-2)=-dwasin2
1709         else
1710           obrot_der(1,i-2)=0.0d0
1711           obrot_der(2,i-2)=0.0d0
1712           Ugder(1,1,i-2)=0.0d0
1713           Ugder(1,2,i-2)=0.0d0
1714           Ugder(2,1,i-2)=0.0d0
1715           Ugder(2,2,i-2)=0.0d0
1716           obrot2_der(1,i-2)=0.0d0
1717           obrot2_der(2,i-2)=0.0d0
1718           Ug2der(1,1,i-2)=0.0d0
1719           Ug2der(1,2,i-2)=0.0d0
1720           Ug2der(2,1,i-2)=0.0d0
1721           Ug2der(2,2,i-2)=0.0d0
1722         endif
1723         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1724           iti = itortyp(itype(i-2))
1725         else
1726           iti=ntortyp+1
1727         endif
1728         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1729           iti1 = itortyp(itype(i-1))
1730         else
1731           iti1=ntortyp+1
1732         endif
1733 cd        write (iout,*) '*******i',i,' iti1',iti
1734 cd        write (iout,*) 'b1',b1(:,iti)
1735 cd        write (iout,*) 'b2',b2(:,iti)
1736 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1737         if (i .gt. iatel_s+2) then
1738           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1739           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1740           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1741           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1742           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1743           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1744           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1745         else
1746           do k=1,2
1747             Ub2(k,i-2)=0.0d0
1748             Ctobr(k,i-2)=0.0d0
1749             Dtobr2(k,i-2)=0.0d0
1750             do l=1,2
1751               EUg(l,k,i-2)=0.0d0
1752               CUg(l,k,i-2)=0.0d0
1753               DUg(l,k,i-2)=0.0d0
1754               DtUg2(l,k,i-2)=0.0d0
1755             enddo
1756           enddo
1757         endif
1758         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1759         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1760         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1761         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1762         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1763         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1764         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1765         do k=1,2
1766           muder(k,i-2)=Ub2der(k,i-2)
1767         enddo
1768         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1769           iti1 = itortyp(itype(i-1))
1770         else
1771           iti1=ntortyp+1
1772         endif
1773         do k=1,2
1774           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1775         enddo
1776 C Vectors and matrices dependent on a single virtual-bond dihedral.
1777         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1778         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1779         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1780         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1782         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1783         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1784         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1785         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1786 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1787 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1788       enddo
1789 C Matrices dependent on two consecutive virtual-bond dihedrals.
1790 C The order of matrices is from left to right.
1791       do i=2,nres-1
1792         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1793         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1794         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1795         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1796         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1797         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1798         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1799         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1800       enddo
1801 cd      do i=1,nres
1802 cd        iti = itortyp(itype(i))
1803 cd        write (iout,*) i
1804 cd        do j=1,2
1805 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1806 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1807 cd        enddo
1808 cd      enddo
1809       return
1810       end
1811 C--------------------------------------------------------------------------
1812       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1813 C
1814 C This subroutine calculates the average interaction energy and its gradient
1815 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1816 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1817 C The potential depends both on the distance of peptide-group centers and on
1818 C the orientation of the CA-CA virtual bonds.
1819 C
1820       implicit real*8 (a-h,o-z)
1821       include 'DIMENSIONS'
1822       include 'DIMENSIONS.ZSCOPT'
1823       include 'COMMON.CONTROL'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.GEO'
1826       include 'COMMON.VAR'
1827       include 'COMMON.LOCAL'
1828       include 'COMMON.CHAIN'
1829       include 'COMMON.DERIV'
1830       include 'COMMON.INTERACT'
1831       include 'COMMON.CONTACTS'
1832       include 'COMMON.TORSION'
1833       include 'COMMON.VECTORS'
1834       include 'COMMON.FFIELD'
1835       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1836      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1837       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1838      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1839       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1840 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1841       double precision scal_el /0.5d0/
1842 C 12/13/98
1843 C 13-go grudnia roku pamietnego...
1844       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1845      &                   0.0d0,1.0d0,0.0d0,
1846      &                   0.0d0,0.0d0,1.0d0/
1847 cd      write(iout,*) 'In EELEC'
1848 cd      do i=1,nloctyp
1849 cd        write(iout,*) 'Type',i
1850 cd        write(iout,*) 'B1',B1(:,i)
1851 cd        write(iout,*) 'B2',B2(:,i)
1852 cd        write(iout,*) 'CC',CC(:,:,i)
1853 cd        write(iout,*) 'DD',DD(:,:,i)
1854 cd        write(iout,*) 'EE',EE(:,:,i)
1855 cd      enddo
1856 cd      call check_vecgrad
1857 cd      stop
1858       if (icheckgrad.eq.1) then
1859         do i=1,nres-1
1860           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1861           do k=1,3
1862             dc_norm(k,i)=dc(k,i)*fac
1863           enddo
1864 c          write (iout,*) 'i',i,' fac',fac
1865         enddo
1866       endif
1867       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1868      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1869      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1870 cd      if (wel_loc.gt.0.0d0) then
1871         if (icheckgrad.eq.1) then
1872         call vec_and_deriv_test
1873         else
1874         call vec_and_deriv
1875         endif
1876         call set_matrices
1877       endif
1878 cd      do i=1,nres-1
1879 cd        write (iout,*) 'i=',i
1880 cd        do k=1,3
1881 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1882 cd        enddo
1883 cd        do k=1,3
1884 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1885 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1886 cd        enddo
1887 cd      enddo
1888       num_conti_hb=0
1889       ees=0.0D0
1890       evdw1=0.0D0
1891       eel_loc=0.0d0
1892       eello_turn3=0.0d0
1893       eello_turn4=0.0d0
1894       ind=0
1895       do i=1,nres
1896         num_cont_hb(i)=0
1897       enddo
1898 cd      print '(a)','Enter EELEC'
1899 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1900       do i=1,nres
1901         gel_loc_loc(i)=0.0d0
1902         gcorr_loc(i)=0.0d0
1903       enddo
1904       do i=iatel_s,iatel_e
1905         if (itel(i).eq.0) goto 1215
1906         dxi=dc(1,i)
1907         dyi=dc(2,i)
1908         dzi=dc(3,i)
1909         dx_normi=dc_norm(1,i)
1910         dy_normi=dc_norm(2,i)
1911         dz_normi=dc_norm(3,i)
1912         xmedi=c(1,i)+0.5d0*dxi
1913         ymedi=c(2,i)+0.5d0*dyi
1914         zmedi=c(3,i)+0.5d0*dzi
1915         num_conti=0
1916 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1917         do j=ielstart(i),ielend(i)
1918           if (itel(j).eq.0) goto 1216
1919           ind=ind+1
1920           iteli=itel(i)
1921           itelj=itel(j)
1922           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1923           aaa=app(iteli,itelj)
1924           bbb=bpp(iteli,itelj)
1925 C Diagnostics only!!!
1926 c         aaa=0.0D0
1927 c         bbb=0.0D0
1928 c         ael6i=0.0D0
1929 c         ael3i=0.0D0
1930 C End diagnostics
1931           ael6i=ael6(iteli,itelj)
1932           ael3i=ael3(iteli,itelj)
1933           dxj=dc(1,j)
1934           dyj=dc(2,j)
1935           dzj=dc(3,j)
1936           dx_normj=dc_norm(1,j)
1937           dy_normj=dc_norm(2,j)
1938           dz_normj=dc_norm(3,j)
1939           xj=c(1,j)+0.5D0*dxj-xmedi
1940           yj=c(2,j)+0.5D0*dyj-ymedi
1941           zj=c(3,j)+0.5D0*dzj-zmedi
1942           rij=xj*xj+yj*yj+zj*zj
1943           rrmij=1.0D0/rij
1944           rij=dsqrt(rij)
1945           rmij=1.0D0/rij
1946           r3ij=rrmij*rmij
1947           r6ij=r3ij*r3ij
1948           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1949           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1950           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1951           fac=cosa-3.0D0*cosb*cosg
1952           ev1=aaa*r6ij*r6ij
1953 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1954           if (j.eq.i+2) ev1=scal_el*ev1
1955           ev2=bbb*r6ij
1956           fac3=ael6i*r6ij
1957           fac4=ael3i*r3ij
1958           evdwij=ev1+ev2
1959           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1960           el2=fac4*fac
1961           eesij=el1+el2
1962 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1963 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1964           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1965           ees=ees+eesij
1966           evdw1=evdw1+evdwij
1967 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1968 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1969 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1970 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1971 C
1972 C Calculate contributions to the Cartesian gradient.
1973 C
1974 #ifdef SPLITELE
1975           facvdw=-6*rrmij*(ev1+evdwij)
1976           facel=-3*rrmij*(el1+eesij)
1977           fac1=fac
1978           erij(1)=xj*rmij
1979           erij(2)=yj*rmij
1980           erij(3)=zj*rmij
1981           if (calc_grad) then
1982 *
1983 * Radial derivatives. First process both termini of the fragment (i,j)
1984 *
1985           ggg(1)=facel*xj
1986           ggg(2)=facel*yj
1987           ggg(3)=facel*zj
1988           do k=1,3
1989             ghalf=0.5D0*ggg(k)
1990             gelc(k,i)=gelc(k,i)+ghalf
1991             gelc(k,j)=gelc(k,j)+ghalf
1992           enddo
1993 *
1994 * Loop over residues i+1 thru j-1.
1995 *
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           ggg(1)=facvdw*xj
2002           ggg(2)=facvdw*yj
2003           ggg(3)=facvdw*zj
2004           do k=1,3
2005             ghalf=0.5D0*ggg(k)
2006             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2007             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2008           enddo
2009 *
2010 * Loop over residues i+1 thru j-1.
2011 *
2012           do k=i+1,j-1
2013             do l=1,3
2014               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2015             enddo
2016           enddo
2017 #else
2018           facvdw=ev1+evdwij
2019           facel=el1+eesij
2020           fac1=fac
2021           fac=-3*rrmij*(facvdw+facvdw+facel)
2022           erij(1)=xj*rmij
2023           erij(2)=yj*rmij
2024           erij(3)=zj*rmij
2025           if (calc_grad) then
2026 *
2027 * Radial derivatives. First process both termini of the fragment (i,j)
2028 *
2029           ggg(1)=fac*xj
2030           ggg(2)=fac*yj
2031           ggg(3)=fac*zj
2032           do k=1,3
2033             ghalf=0.5D0*ggg(k)
2034             gelc(k,i)=gelc(k,i)+ghalf
2035             gelc(k,j)=gelc(k,j)+ghalf
2036           enddo
2037 *
2038 * Loop over residues i+1 thru j-1.
2039 *
2040           do k=i+1,j-1
2041             do l=1,3
2042               gelc(l,k)=gelc(l,k)+ggg(l)
2043             enddo
2044           enddo
2045 #endif
2046 *
2047 * Angular part
2048 *
2049           ecosa=2.0D0*fac3*fac1+fac4
2050           fac4=-3.0D0*fac4
2051           fac3=-6.0D0*fac3
2052           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2053           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2054           do k=1,3
2055             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2056             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2057           enddo
2058 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2059 cd   &          (dcosg(k),k=1,3)
2060           do k=1,3
2061             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2062           enddo
2063           do k=1,3
2064             ghalf=0.5D0*ggg(k)
2065             gelc(k,i)=gelc(k,i)+ghalf
2066      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2067      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2068             gelc(k,j)=gelc(k,j)+ghalf
2069      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2070      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2071           enddo
2072           do k=i+1,j-1
2073             do l=1,3
2074               gelc(l,k)=gelc(l,k)+ggg(l)
2075             enddo
2076           enddo
2077           endif
2078
2079           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2080      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2081      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2082 C
2083 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2084 C   energy of a peptide unit is assumed in the form of a second-order
2085 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2086 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2087 C   are computed for EVERY pair of non-contiguous peptide groups.
2088 C
2089           if (j.lt.nres-1) then
2090             j1=j+1
2091             j2=j-1
2092           else
2093             j1=j-1
2094             j2=j-2
2095           endif
2096           kkk=0
2097           do k=1,2
2098             do l=1,2
2099               kkk=kkk+1
2100               muij(kkk)=mu(k,i)*mu(l,j)
2101             enddo
2102           enddo
2103 cd         write (iout,*) 'EELEC: i',i,' j',j
2104 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2105 cd          write(iout,*) 'muij',muij
2106           ury=scalar(uy(1,i),erij)
2107           urz=scalar(uz(1,i),erij)
2108           vry=scalar(uy(1,j),erij)
2109           vrz=scalar(uz(1,j),erij)
2110           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2111           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2112           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2113           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2114 C For diagnostics only
2115 cd          a22=1.0d0
2116 cd          a23=1.0d0
2117 cd          a32=1.0d0
2118 cd          a33=1.0d0
2119           fac=dsqrt(-ael6i)*r3ij
2120 cd          write (2,*) 'fac=',fac
2121 C For diagnostics only
2122 cd          fac=1.0d0
2123           a22=a22*fac
2124           a23=a23*fac
2125           a32=a32*fac
2126           a33=a33*fac
2127 cd          write (iout,'(4i5,4f10.5)')
2128 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2129 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2130 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2131 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2132 cd          write (iout,'(4f10.5)')
2133 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2134 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2135 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2136 cd           write (iout,'(2i3,9f10.5/)') i,j,
2137 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2138           if (calc_grad) then
2139 C Derivatives of the elements of A in virtual-bond vectors
2140           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2141 cd          do k=1,3
2142 cd            do l=1,3
2143 cd              erder(k,l)=0.0d0
2144 cd            enddo
2145 cd          enddo
2146           do k=1,3
2147             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2148             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2149             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2150             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2151             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2152             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2153             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2154             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2155             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2156             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2157             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2158             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2159           enddo
2160 cd          do k=1,3
2161 cd            do l=1,3
2162 cd              uryg(k,l)=0.0d0
2163 cd              urzg(k,l)=0.0d0
2164 cd              vryg(k,l)=0.0d0
2165 cd              vrzg(k,l)=0.0d0
2166 cd            enddo
2167 cd          enddo
2168 C Compute radial contributions to the gradient
2169           facr=-3.0d0*rrmij
2170           a22der=a22*facr
2171           a23der=a23*facr
2172           a32der=a32*facr
2173           a33der=a33*facr
2174 cd          a22der=0.0d0
2175 cd          a23der=0.0d0
2176 cd          a32der=0.0d0
2177 cd          a33der=0.0d0
2178           agg(1,1)=a22der*xj
2179           agg(2,1)=a22der*yj
2180           agg(3,1)=a22der*zj
2181           agg(1,2)=a23der*xj
2182           agg(2,2)=a23der*yj
2183           agg(3,2)=a23der*zj
2184           agg(1,3)=a32der*xj
2185           agg(2,3)=a32der*yj
2186           agg(3,3)=a32der*zj
2187           agg(1,4)=a33der*xj
2188           agg(2,4)=a33der*yj
2189           agg(3,4)=a33der*zj
2190 C Add the contributions coming from er
2191           fac3=-3.0d0*fac
2192           do k=1,3
2193             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2194             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2195             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2196             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2197           enddo
2198           do k=1,3
2199 C Derivatives in DC(i)
2200             ghalf1=0.5d0*agg(k,1)
2201             ghalf2=0.5d0*agg(k,2)
2202             ghalf3=0.5d0*agg(k,3)
2203             ghalf4=0.5d0*agg(k,4)
2204             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2205      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2206             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2207      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2208             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2209      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2210             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2211      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2212 C Derivatives in DC(i+1)
2213             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2214      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2215             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2216      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2217             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2218      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2219             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2220      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2221 C Derivatives in DC(j)
2222             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2223      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2224             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2226             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2227      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2228             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2230 C Derivatives in DC(j+1) or DC(nres-1)
2231             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2232      &      -3.0d0*vryg(k,3)*ury)
2233             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vrzg(k,3)*ury)
2235             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2236      &      -3.0d0*vryg(k,3)*urz)
2237             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vrzg(k,3)*urz)
2239 cd            aggi(k,1)=ghalf1
2240 cd            aggi(k,2)=ghalf2
2241 cd            aggi(k,3)=ghalf3
2242 cd            aggi(k,4)=ghalf4
2243 C Derivatives in DC(i+1)
2244 cd            aggi1(k,1)=agg(k,1)
2245 cd            aggi1(k,2)=agg(k,2)
2246 cd            aggi1(k,3)=agg(k,3)
2247 cd            aggi1(k,4)=agg(k,4)
2248 C Derivatives in DC(j)
2249 cd            aggj(k,1)=ghalf1
2250 cd            aggj(k,2)=ghalf2
2251 cd            aggj(k,3)=ghalf3
2252 cd            aggj(k,4)=ghalf4
2253 C Derivatives in DC(j+1)
2254 cd            aggj1(k,1)=0.0d0
2255 cd            aggj1(k,2)=0.0d0
2256 cd            aggj1(k,3)=0.0d0
2257 cd            aggj1(k,4)=0.0d0
2258             if (j.eq.nres-1 .and. i.lt.j-2) then
2259               do l=1,4
2260                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2261 cd                aggj1(k,l)=agg(k,l)
2262               enddo
2263             endif
2264           enddo
2265           endif
2266 c          goto 11111
2267 C Check the loc-el terms by numerical integration
2268           acipa(1,1)=a22
2269           acipa(1,2)=a23
2270           acipa(2,1)=a32
2271           acipa(2,2)=a33
2272           a22=-a22
2273           a23=-a23
2274           do l=1,2
2275             do k=1,3
2276               agg(k,l)=-agg(k,l)
2277               aggi(k,l)=-aggi(k,l)
2278               aggi1(k,l)=-aggi1(k,l)
2279               aggj(k,l)=-aggj(k,l)
2280               aggj1(k,l)=-aggj1(k,l)
2281             enddo
2282           enddo
2283           if (j.lt.nres-1) then
2284             a22=-a22
2285             a32=-a32
2286             do l=1,3,2
2287               do k=1,3
2288                 agg(k,l)=-agg(k,l)
2289                 aggi(k,l)=-aggi(k,l)
2290                 aggi1(k,l)=-aggi1(k,l)
2291                 aggj(k,l)=-aggj(k,l)
2292                 aggj1(k,l)=-aggj1(k,l)
2293               enddo
2294             enddo
2295           else
2296             a22=-a22
2297             a23=-a23
2298             a32=-a32
2299             a33=-a33
2300             do l=1,4
2301               do k=1,3
2302                 agg(k,l)=-agg(k,l)
2303                 aggi(k,l)=-aggi(k,l)
2304                 aggi1(k,l)=-aggi1(k,l)
2305                 aggj(k,l)=-aggj(k,l)
2306                 aggj1(k,l)=-aggj1(k,l)
2307               enddo
2308             enddo
2309           endif
2310           ENDIF ! WCORR
2311 11111     continue
2312           IF (wel_loc.gt.0.0d0) THEN
2313 C Contribution to the local-electrostatic energy coming from the i-j pair
2314           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2315      &     +a33*muij(4)
2316 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2317 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2318           eel_loc=eel_loc+eel_loc_ij
2319 C Partial derivatives in virtual-bond dihedral angles gamma
2320           if (calc_grad) then
2321           if (i.gt.1)
2322      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2323      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2324      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2325           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2326      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2327      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2328 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2329 cd          write(iout,*) 'agg  ',agg
2330 cd          write(iout,*) 'aggi ',aggi
2331 cd          write(iout,*) 'aggi1',aggi1
2332 cd          write(iout,*) 'aggj ',aggj
2333 cd          write(iout,*) 'aggj1',aggj1
2334
2335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2336           do l=1,3
2337             ggg(l)=agg(l,1)*muij(1)+
2338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2339           enddo
2340           do k=i+2,j2
2341             do l=1,3
2342               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2343             enddo
2344           enddo
2345 C Remaining derivatives of eello
2346           do l=1,3
2347             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2348      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2349             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2350      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2351             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2352      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2353             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2354      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2355           enddo
2356           endif
2357           ENDIF
2358           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2359 C Contributions from turns
2360             a_temp(1,1)=a22
2361             a_temp(1,2)=a23
2362             a_temp(2,1)=a32
2363             a_temp(2,2)=a33
2364             call eturn34(i,j,eello_turn3,eello_turn4)
2365           endif
2366 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2367           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2368 C
2369 C Calculate the contact function. The ith column of the array JCONT will
2370 C contain the numbers of atoms that make contacts with the atom I (of numbers
2371 C greater than I). The arrays FACONT and GACONT will contain the values of
2372 C the contact function and its derivative.
2373 c           r0ij=1.02D0*rpp(iteli,itelj)
2374 c           r0ij=1.11D0*rpp(iteli,itelj)
2375             r0ij=2.20D0*rpp(iteli,itelj)
2376 c           r0ij=1.55D0*rpp(iteli,itelj)
2377             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2378             if (fcont.gt.0.0D0) then
2379               num_conti=num_conti+1
2380               if (num_conti.gt.maxconts) then
2381                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2382      &                         ' will skip next contacts for this conf.'
2383               else
2384                 jcont_hb(num_conti,i)=j
2385                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2386      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2387 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2388 C  terms.
2389                 d_cont(num_conti,i)=rij
2390 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2391 C     --- Electrostatic-interaction matrix ---
2392                 a_chuj(1,1,num_conti,i)=a22
2393                 a_chuj(1,2,num_conti,i)=a23
2394                 a_chuj(2,1,num_conti,i)=a32
2395                 a_chuj(2,2,num_conti,i)=a33
2396 C     --- Gradient of rij
2397                 do kkk=1,3
2398                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2399                 enddo
2400 c             if (i.eq.1) then
2401 c                a_chuj(1,1,num_conti,i)=-0.61d0
2402 c                a_chuj(1,2,num_conti,i)= 0.4d0
2403 c                a_chuj(2,1,num_conti,i)= 0.65d0
2404 c                a_chuj(2,2,num_conti,i)= 0.50d0
2405 c             else if (i.eq.2) then
2406 c                a_chuj(1,1,num_conti,i)= 0.0d0
2407 c                a_chuj(1,2,num_conti,i)= 0.0d0
2408 c                a_chuj(2,1,num_conti,i)= 0.0d0
2409 c                a_chuj(2,2,num_conti,i)= 0.0d0
2410 c             endif
2411 C     --- and its gradients
2412 cd                write (iout,*) 'i',i,' j',j
2413 cd                do kkk=1,3
2414 cd                write (iout,*) 'iii 1 kkk',kkk
2415 cd                write (iout,*) agg(kkk,:)
2416 cd                enddo
2417 cd                do kkk=1,3
2418 cd                write (iout,*) 'iii 2 kkk',kkk
2419 cd                write (iout,*) aggi(kkk,:)
2420 cd                enddo
2421 cd                do kkk=1,3
2422 cd                write (iout,*) 'iii 3 kkk',kkk
2423 cd                write (iout,*) aggi1(kkk,:)
2424 cd                enddo
2425 cd                do kkk=1,3
2426 cd                write (iout,*) 'iii 4 kkk',kkk
2427 cd                write (iout,*) aggj(kkk,:)
2428 cd                enddo
2429 cd                do kkk=1,3
2430 cd                write (iout,*) 'iii 5 kkk',kkk
2431 cd                write (iout,*) aggj1(kkk,:)
2432 cd                enddo
2433                 kkll=0
2434                 do k=1,2
2435                   do l=1,2
2436                     kkll=kkll+1
2437                     do m=1,3
2438                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2439                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2440                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2441                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2442                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2443 c                      do mm=1,5
2444 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2445 c                      enddo
2446                     enddo
2447                   enddo
2448                 enddo
2449                 ENDIF
2450                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2451 C Calculate contact energies
2452                 cosa4=4.0D0*cosa
2453                 wij=cosa-3.0D0*cosb*cosg
2454                 cosbg1=cosb+cosg
2455                 cosbg2=cosb-cosg
2456 c               fac3=dsqrt(-ael6i)/r0ij**3
2457                 fac3=dsqrt(-ael6i)*r3ij
2458                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2459                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2460 c               ees0mij=0.0D0
2461                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2462                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2463 C Diagnostics. Comment out or remove after debugging!
2464 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2465 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2466 c               ees0m(num_conti,i)=0.0D0
2467 C End diagnostics.
2468 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2469 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2470                 facont_hb(num_conti,i)=fcont
2471                 if (calc_grad) then
2472 C Angular derivatives of the contact function
2473                 ees0pij1=fac3/ees0pij
2474                 ees0mij1=fac3/ees0mij
2475                 fac3p=-3.0D0*fac3*rrmij
2476                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2477                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2478 c               ees0mij1=0.0D0
2479                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2480                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2481                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2482                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2483                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2484                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2485                 ecosap=ecosa1+ecosa2
2486                 ecosbp=ecosb1+ecosb2
2487                 ecosgp=ecosg1+ecosg2
2488                 ecosam=ecosa1-ecosa2
2489                 ecosbm=ecosb1-ecosb2
2490                 ecosgm=ecosg1-ecosg2
2491 C Diagnostics
2492 c               ecosap=ecosa1
2493 c               ecosbp=ecosb1
2494 c               ecosgp=ecosg1
2495 c               ecosam=0.0D0
2496 c               ecosbm=0.0D0
2497 c               ecosgm=0.0D0
2498 C End diagnostics
2499                 fprimcont=fprimcont/rij
2500 cd              facont_hb(num_conti,i)=1.0D0
2501 C Following line is for diagnostics.
2502 cd              fprimcont=0.0D0
2503                 do k=1,3
2504                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2505                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2506                 enddo
2507                 do k=1,3
2508                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2509                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2510                 enddo
2511                 gggp(1)=gggp(1)+ees0pijp*xj
2512                 gggp(2)=gggp(2)+ees0pijp*yj
2513                 gggp(3)=gggp(3)+ees0pijp*zj
2514                 gggm(1)=gggm(1)+ees0mijp*xj
2515                 gggm(2)=gggm(2)+ees0mijp*yj
2516                 gggm(3)=gggm(3)+ees0mijp*zj
2517 C Derivatives due to the contact function
2518                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2519                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2520                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2521                 do k=1,3
2522                   ghalfp=0.5D0*gggp(k)
2523                   ghalfm=0.5D0*gggm(k)
2524                   gacontp_hb1(k,num_conti,i)=ghalfp
2525      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2526      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2527                   gacontp_hb2(k,num_conti,i)=ghalfp
2528      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2529      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2530                   gacontp_hb3(k,num_conti,i)=gggp(k)
2531                   gacontm_hb1(k,num_conti,i)=ghalfm
2532      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2533      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2534                   gacontm_hb2(k,num_conti,i)=ghalfm
2535      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2536      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2537                   gacontm_hb3(k,num_conti,i)=gggm(k)
2538                 enddo
2539                 endif
2540 C Diagnostics. Comment out or remove after debugging!
2541 cdiag           do k=1,3
2542 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2543 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2544 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2545 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2546 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2548 cdiag           enddo
2549               ENDIF ! wcorr
2550               endif  ! num_conti.le.maxconts
2551             endif  ! fcont.gt.0
2552           endif    ! j.gt.i+1
2553  1216     continue
2554         enddo ! j
2555         num_cont_hb(i)=num_conti
2556  1215   continue
2557       enddo   ! i
2558 cd      do i=1,nres
2559 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2560 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2561 cd      enddo
2562 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2563 ccc      eel_loc=eel_loc+eello_turn3
2564       return
2565       end
2566 C-----------------------------------------------------------------------------
2567       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2568 C Third- and fourth-order contributions from turns
2569       implicit real*8 (a-h,o-z)
2570       include 'DIMENSIONS'
2571       include 'DIMENSIONS.ZSCOPT'
2572       include 'COMMON.IOUNITS'
2573       include 'COMMON.GEO'
2574       include 'COMMON.VAR'
2575       include 'COMMON.LOCAL'
2576       include 'COMMON.CHAIN'
2577       include 'COMMON.DERIV'
2578       include 'COMMON.INTERACT'
2579       include 'COMMON.CONTACTS'
2580       include 'COMMON.TORSION'
2581       include 'COMMON.VECTORS'
2582       include 'COMMON.FFIELD'
2583       dimension ggg(3)
2584       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2585      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2586      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2587       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2588      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2589       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2590       if (j.eq.i+2) then
2591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2592 C
2593 C               Third-order contributions
2594 C
2595 C                 (i+2)o----(i+3)
2596 C                      | |
2597 C                      | |
2598 C                 (i+1)o----i
2599 C
2600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2601 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2602         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2603         call transpose2(auxmat(1,1),auxmat1(1,1))
2604         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2605         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2607 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2608 cd     &    ' eello_turn3_num',4*eello_turn3_num
2609         if (calc_grad) then
2610 C Derivatives in gamma(i)
2611         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2612         call transpose2(auxmat2(1,1),pizda(1,1))
2613         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2614         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2615 C Derivatives in gamma(i+1)
2616         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2617         call transpose2(auxmat2(1,1),pizda(1,1))
2618         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2619         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2620      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2621 C Cartesian derivatives
2622         do l=1,3
2623           a_temp(1,1)=aggi(l,1)
2624           a_temp(1,2)=aggi(l,2)
2625           a_temp(2,1)=aggi(l,3)
2626           a_temp(2,2)=aggi(l,4)
2627           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2628           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2629      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2630           a_temp(1,1)=aggi1(l,1)
2631           a_temp(1,2)=aggi1(l,2)
2632           a_temp(2,1)=aggi1(l,3)
2633           a_temp(2,2)=aggi1(l,4)
2634           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2635           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2636      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2637           a_temp(1,1)=aggj(l,1)
2638           a_temp(1,2)=aggj(l,2)
2639           a_temp(2,1)=aggj(l,3)
2640           a_temp(2,2)=aggj(l,4)
2641           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2642           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2643      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2644           a_temp(1,1)=aggj1(l,1)
2645           a_temp(1,2)=aggj1(l,2)
2646           a_temp(2,1)=aggj1(l,3)
2647           a_temp(2,2)=aggj1(l,4)
2648           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2649           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2650      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2651         enddo
2652         endif
2653       else if (j.eq.i+3) then
2654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2655 C
2656 C               Fourth-order contributions
2657 C
2658 C                 (i+3)o----(i+4)
2659 C                     /  |
2660 C               (i+2)o   |
2661 C                     \  |
2662 C                 (i+1)o----i
2663 C
2664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2665 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2666         iti1=itortyp(itype(i+1))
2667         iti2=itortyp(itype(i+2))
2668         iti3=itortyp(itype(i+3))
2669         call transpose2(EUg(1,1,i+1),e1t(1,1))
2670         call transpose2(Eug(1,1,i+2),e2t(1,1))
2671         call transpose2(Eug(1,1,i+3),e3t(1,1))
2672         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2673         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2674         s1=scalar2(b1(1,iti2),auxvec(1))
2675         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2676         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2677         s2=scalar2(b1(1,iti1),auxvec(1))
2678         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2679         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2681         eello_turn4=eello_turn4-(s1+s2+s3)
2682 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2683 cd     &    ' eello_turn4_num',8*eello_turn4_num
2684 C Derivatives in gamma(i)
2685         if (calc_grad) then
2686         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2687         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2688         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2689         s1=scalar2(b1(1,iti2),auxvec(1))
2690         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2691         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2692         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2693 C Derivatives in gamma(i+1)
2694         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2695         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2696         s2=scalar2(b1(1,iti1),auxvec(1))
2697         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2698         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2699         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2701 C Derivatives in gamma(i+2)
2702         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2703         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2704         s1=scalar2(b1(1,iti2),auxvec(1))
2705         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2706         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2707         s2=scalar2(b1(1,iti1),auxvec(1))
2708         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2709         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2710         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2711         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2712 C Cartesian derivatives
2713 C Derivatives of this turn contributions in DC(i+2)
2714         if (j.lt.nres-1) then
2715           do l=1,3
2716             a_temp(1,1)=agg(l,1)
2717             a_temp(1,2)=agg(l,2)
2718             a_temp(2,1)=agg(l,3)
2719             a_temp(2,2)=agg(l,4)
2720             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2721             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2722             s1=scalar2(b1(1,iti2),auxvec(1))
2723             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2724             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2725             s2=scalar2(b1(1,iti1),auxvec(1))
2726             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2727             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2728             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2729             ggg(l)=-(s1+s2+s3)
2730             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2731           enddo
2732         endif
2733 C Remaining derivatives of this turn contribution
2734         do l=1,3
2735           a_temp(1,1)=aggi(l,1)
2736           a_temp(1,2)=aggi(l,2)
2737           a_temp(2,1)=aggi(l,3)
2738           a_temp(2,2)=aggi(l,4)
2739           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2740           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2741           s1=scalar2(b1(1,iti2),auxvec(1))
2742           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2743           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2744           s2=scalar2(b1(1,iti1),auxvec(1))
2745           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2746           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2747           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2748           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2749           a_temp(1,1)=aggi1(l,1)
2750           a_temp(1,2)=aggi1(l,2)
2751           a_temp(2,1)=aggi1(l,3)
2752           a_temp(2,2)=aggi1(l,4)
2753           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2754           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2755           s1=scalar2(b1(1,iti2),auxvec(1))
2756           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2757           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2758           s2=scalar2(b1(1,iti1),auxvec(1))
2759           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2760           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2761           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2762           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2763           a_temp(1,1)=aggj(l,1)
2764           a_temp(1,2)=aggj(l,2)
2765           a_temp(2,1)=aggj(l,3)
2766           a_temp(2,2)=aggj(l,4)
2767           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2768           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2769           s1=scalar2(b1(1,iti2),auxvec(1))
2770           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2771           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2772           s2=scalar2(b1(1,iti1),auxvec(1))
2773           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2774           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2775           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2776           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2777           a_temp(1,1)=aggj1(l,1)
2778           a_temp(1,2)=aggj1(l,2)
2779           a_temp(2,1)=aggj1(l,3)
2780           a_temp(2,2)=aggj1(l,4)
2781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2783           s1=scalar2(b1(1,iti2),auxvec(1))
2784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2786           s2=scalar2(b1(1,iti1),auxvec(1))
2787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2790           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2791         enddo
2792         endif
2793       endif
2794       return
2795       end
2796 C-----------------------------------------------------------------------------
2797       subroutine vecpr(u,v,w)
2798       implicit real*8(a-h,o-z)
2799       dimension u(3),v(3),w(3)
2800       w(1)=u(2)*v(3)-u(3)*v(2)
2801       w(2)=-u(1)*v(3)+u(3)*v(1)
2802       w(3)=u(1)*v(2)-u(2)*v(1)
2803       return
2804       end
2805 C-----------------------------------------------------------------------------
2806       subroutine unormderiv(u,ugrad,unorm,ungrad)
2807 C This subroutine computes the derivatives of a normalized vector u, given
2808 C the derivatives computed without normalization conditions, ugrad. Returns
2809 C ungrad.
2810       implicit none
2811       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2812       double precision vec(3)
2813       double precision scalar
2814       integer i,j
2815 c      write (2,*) 'ugrad',ugrad
2816 c      write (2,*) 'u',u
2817       do i=1,3
2818         vec(i)=scalar(ugrad(1,i),u(1))
2819       enddo
2820 c      write (2,*) 'vec',vec
2821       do i=1,3
2822         do j=1,3
2823           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2824         enddo
2825       enddo
2826 c      write (2,*) 'ungrad',ungrad
2827       return
2828       end
2829 C-----------------------------------------------------------------------------
2830       subroutine escp(evdw2,evdw2_14)
2831 C
2832 C This subroutine calculates the excluded-volume interaction energy between
2833 C peptide-group centers and side chains and its gradient in virtual-bond and
2834 C side-chain vectors.
2835 C
2836       implicit real*8 (a-h,o-z)
2837       include 'DIMENSIONS'
2838       include 'DIMENSIONS.ZSCOPT'
2839       include 'COMMON.GEO'
2840       include 'COMMON.VAR'
2841       include 'COMMON.LOCAL'
2842       include 'COMMON.CHAIN'
2843       include 'COMMON.DERIV'
2844       include 'COMMON.INTERACT'
2845       include 'COMMON.FFIELD'
2846       include 'COMMON.IOUNITS'
2847       dimension ggg(3)
2848       evdw2=0.0D0
2849       evdw2_14=0.0d0
2850 cd    print '(a)','Enter ESCP'
2851 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2852 c     &  ' scal14',scal14
2853       do i=iatscp_s,iatscp_e
2854         iteli=itel(i)
2855 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2856 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2857         if (iteli.eq.0) goto 1225
2858         xi=0.5D0*(c(1,i)+c(1,i+1))
2859         yi=0.5D0*(c(2,i)+c(2,i+1))
2860         zi=0.5D0*(c(3,i)+c(3,i+1))
2861
2862         do iint=1,nscp_gr(i)
2863
2864         do j=iscpstart(i,iint),iscpend(i,iint)
2865           itypj=itype(j)
2866 C Uncomment following three lines for SC-p interactions
2867 c         xj=c(1,nres+j)-xi
2868 c         yj=c(2,nres+j)-yi
2869 c         zj=c(3,nres+j)-zi
2870 C Uncomment following three lines for Ca-p interactions
2871           xj=c(1,j)-xi
2872           yj=c(2,j)-yi
2873           zj=c(3,j)-zi
2874           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2875           fac=rrij**expon2
2876           e1=fac*fac*aad(itypj,iteli)
2877           e2=fac*bad(itypj,iteli)
2878           if (iabs(j-i) .le. 2) then
2879             e1=scal14*e1
2880             e2=scal14*e2
2881             evdw2_14=evdw2_14+e1+e2
2882           endif
2883           evdwij=e1+e2
2884 c          write (iout,*) i,j,evdwij
2885           evdw2=evdw2+evdwij
2886           if (calc_grad) then
2887 C
2888 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2889 C
2890           fac=-(evdwij+e1)*rrij
2891           ggg(1)=xj*fac
2892           ggg(2)=yj*fac
2893           ggg(3)=zj*fac
2894           if (j.lt.i) then
2895 cd          write (iout,*) 'j<i'
2896 C Uncomment following three lines for SC-p interactions
2897 c           do k=1,3
2898 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2899 c           enddo
2900           else
2901 cd          write (iout,*) 'j>i'
2902             do k=1,3
2903               ggg(k)=-ggg(k)
2904 C Uncomment following line for SC-p interactions
2905 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2906             enddo
2907           endif
2908           do k=1,3
2909             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2910           enddo
2911           kstart=min0(i+1,j)
2912           kend=max0(i-1,j-1)
2913 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2914 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2915           do k=kstart,kend
2916             do l=1,3
2917               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2918             enddo
2919           enddo
2920           endif
2921         enddo
2922         enddo ! iint
2923  1225   continue
2924       enddo ! i
2925       do i=1,nct
2926         do j=1,3
2927           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2928           gradx_scp(j,i)=expon*gradx_scp(j,i)
2929         enddo
2930       enddo
2931 C******************************************************************************
2932 C
2933 C                              N O T E !!!
2934 C
2935 C To save time the factor EXPON has been extracted from ALL components
2936 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2937 C use!
2938 C
2939 C******************************************************************************
2940       return
2941       end
2942 C--------------------------------------------------------------------------
2943       subroutine edis(ehpb)
2944 C
2945 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2946 C
2947       implicit real*8 (a-h,o-z)
2948       include 'DIMENSIONS'
2949       include 'COMMON.SBRIDGE'
2950       include 'COMMON.CHAIN'
2951       include 'COMMON.DERIV'
2952       include 'COMMON.VAR'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.IOUNITS'
2955       dimension ggg(3)
2956       ehpb=0.0D0
2957 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2958 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2959       if (link_end.eq.0) return
2960       do i=link_start,link_end
2961 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2962 C CA-CA distance used in regularization of structure.
2963         ii=ihpb(i)
2964         jj=jhpb(i)
2965 C iii and jjj point to the residues for which the distance is assigned.
2966         if (ii.gt.nres) then
2967           iii=ii-nres
2968           jjj=jj-nres
2969         else
2970           iii=ii
2971           jjj=jj
2972         endif
2973 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2974 c     &    dhpb(i),dhpb1(i),forcon(i)
2975 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2976 C    distance and angle dependent SS bond potential.
2977         if (.not.dyn_ss .and. i.le.nss) then
2978 C 15/02/13 CC dynamic SSbond - additional check
2979         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2980           call ssbond_ene(iii,jjj,eij)
2981           ehpb=ehpb+2*eij
2982          endif
2983 cd          write (iout,*) "eij",eij
2984         else if (ii.gt.nres .and. jj.gt.nres) then
2985 c Restraints from contact prediction
2986           dd=dist(ii,jj)
2987           if (dhpb1(i).gt.0.0d0) then
2988             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2989             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2990 c            write (iout,*) "beta nmr",
2991 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2992           else
2993             dd=dist(ii,jj)
2994             rdis=dd-dhpb(i)
2995 C Get the force constant corresponding to this distance.
2996             waga=forcon(i)
2997 C Calculate the contribution to energy.
2998             ehpb=ehpb+waga*rdis*rdis
2999 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3000 C
3001 C Evaluate gradient.
3002 C
3003             fac=waga*rdis/dd
3004           endif
3005           do j=1,3
3006             ggg(j)=fac*(c(j,jj)-c(j,ii))
3007           enddo
3008           do j=1,3
3009             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3010             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3011           enddo
3012           do k=1,3
3013             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3014             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3015           enddo
3016         else
3017 C Calculate the distance between the two points and its difference from the
3018 C target distance.
3019           dd=dist(ii,jj)
3020           if (dhpb1(i).gt.0.0d0) then
3021             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3022             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3023 c            write (iout,*) "alph nmr",
3024 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3025           else
3026             rdis=dd-dhpb(i)
3027 C Get the force constant corresponding to this distance.
3028             waga=forcon(i)
3029 C Calculate the contribution to energy.
3030             ehpb=ehpb+waga*rdis*rdis
3031 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3032 C
3033 C Evaluate gradient.
3034 C
3035             fac=waga*rdis/dd
3036           endif
3037 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3038 cd   &   ' waga=',waga,' fac=',fac
3039             do j=1,3
3040               ggg(j)=fac*(c(j,jj)-c(j,ii))
3041             enddo
3042 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3043 C If this is a SC-SC distance, we need to calculate the contributions to the
3044 C Cartesian gradient in the SC vectors (ghpbx).
3045           if (iii.lt.ii) then
3046           do j=1,3
3047             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3048             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3049           enddo
3050           endif
3051           do k=1,3
3052             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3053             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3054           enddo
3055         endif
3056       enddo
3057       ehpb=0.5D0*ehpb
3058       return
3059       end
3060 C--------------------------------------------------------------------------
3061       subroutine ssbond_ene(i,j,eij)
3062 C
3063 C Calculate the distance and angle dependent SS-bond potential energy
3064 C using a free-energy function derived based on RHF/6-31G** ab initio
3065 C calculations of diethyl disulfide.
3066 C
3067 C A. Liwo and U. Kozlowska, 11/24/03
3068 C
3069       implicit real*8 (a-h,o-z)
3070       include 'DIMENSIONS'
3071       include 'DIMENSIONS.ZSCOPT'
3072       include 'COMMON.SBRIDGE'
3073       include 'COMMON.CHAIN'
3074       include 'COMMON.DERIV'
3075       include 'COMMON.LOCAL'
3076       include 'COMMON.INTERACT'
3077       include 'COMMON.VAR'
3078       include 'COMMON.IOUNITS'
3079       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3080       itypi=itype(i)
3081       xi=c(1,nres+i)
3082       yi=c(2,nres+i)
3083       zi=c(3,nres+i)
3084       dxi=dc_norm(1,nres+i)
3085       dyi=dc_norm(2,nres+i)
3086       dzi=dc_norm(3,nres+i)
3087       dsci_inv=dsc_inv(itypi)
3088       itypj=itype(j)
3089       dscj_inv=dsc_inv(itypj)
3090       xj=c(1,nres+j)-xi
3091       yj=c(2,nres+j)-yi
3092       zj=c(3,nres+j)-zi
3093       dxj=dc_norm(1,nres+j)
3094       dyj=dc_norm(2,nres+j)
3095       dzj=dc_norm(3,nres+j)
3096       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3097       rij=dsqrt(rrij)
3098       erij(1)=xj*rij
3099       erij(2)=yj*rij
3100       erij(3)=zj*rij
3101       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3102       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3103       om12=dxi*dxj+dyi*dyj+dzi*dzj
3104       do k=1,3
3105         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3106         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3107       enddo
3108       rij=1.0d0/rij
3109       deltad=rij-d0cm
3110       deltat1=1.0d0-om1
3111       deltat2=1.0d0+om2
3112       deltat12=om2-om1+2.0d0
3113       cosphi=om12-om1*om2
3114       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3115      &  +akct*deltad*deltat12+ebr
3116 c     &  +akct*deltad*deltat12
3117      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3118       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3119      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3120      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3121       ed=2*akcm*deltad+akct*deltat12
3122       pom1=akct*deltad
3123       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3124       eom1=-2*akth*deltat1-pom1-om2*pom2
3125       eom2= 2*akth*deltat2+pom1-om1*pom2
3126       eom12=pom2
3127       do k=1,3
3128         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3129       enddo
3130       do k=1,3
3131         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3132      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3133         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3134      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3135       enddo
3136 C
3137 C Calculate the components of the gradient in DC and X
3138 C
3139       do k=i,j-1
3140         do l=1,3
3141           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3142         enddo
3143       enddo
3144       return
3145       end
3146 C--------------------------------------------------------------------------
3147 c MODELLER restraint function
3148       subroutine e_modeller(ehomology_constr)
3149       implicit real*8 (a-h,o-z)
3150       include 'DIMENSIONS'
3151       include 'DIMENSIONS.ZSCOPT'
3152
3153       integer nnn, i, j, k, ki, irec, l
3154       integer katy, odleglosci, test7
3155       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3156       real*8 distance(max_template),distancek(max_template),
3157      &    min_odl,godl(max_template),dih_diff(max_template)
3158
3159 c
3160 c     FP - 30/10/2014 Temporary specifications for homology restraints
3161 c
3162       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3163      &                 sgtheta
3164       double precision, dimension (maxres) :: guscdiff,usc_diff
3165       double precision, dimension (max_template) ::
3166      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3167      &           theta_diff
3168
3169       include 'COMMON.SBRIDGE'
3170       include 'COMMON.CHAIN'
3171       include 'COMMON.GEO'
3172       include 'COMMON.DERIV'
3173       include 'COMMON.LOCAL'
3174       include 'COMMON.INTERACT'
3175       include 'COMMON.VAR'
3176       include 'COMMON.IOUNITS'
3177       include 'COMMON.CONTROL'
3178       include 'COMMON.HOMRESTR'
3179 c
3180       include 'COMMON.SETUP'
3181       include 'COMMON.NAMES'
3182
3183       do i=1,19
3184         distancek(i)=9999999.9
3185       enddo
3186
3187       odleg=0.0d0
3188
3189 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3190 c function)
3191 C AL 5/2/14 - Introduce list of restraints
3192 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3193 #ifdef DEBUG
3194       write(iout,*) "------- dist restrs start -------"
3195 #endif
3196       do ii = link_start_homo,link_end_homo
3197          i = ires_homo(ii)
3198          j = jres_homo(ii)
3199          dij=dist(i,j)
3200 c        write (iout,*) "dij(",i,j,") =",dij
3201          do k=1,constr_homology
3202            distance(k)=odl(k,ii)-dij
3203 c          write (iout,*) "distance(",k,") =",distance(k)
3204 c
3205 c          For Gaussian-type Urestr
3206 c
3207            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3208 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3209 c          write (iout,*) "distancek(",k,") =",distancek(k)
3210 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3211 c
3212 c          For Lorentzian-type Urestr
3213 c
3214            if (waga_dist.lt.0.0d0) then
3215               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3216               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3217      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3218            endif
3219          enddo
3220
3221          min_odl=minval(distancek)
3222 c        write (iout,* )"min_odl",min_odl
3223 #ifdef DEBUG
3224          write (iout,*) "ij dij",i,j,dij
3225          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3226          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3227          write (iout,* )"min_odl",min_odl
3228 #endif
3229          odleg2=0.0d0
3230          do k=1,constr_homology
3231 c Nie wiem po co to liczycie jeszcze raz!
3232 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3233 c     &              (2*(sigma_odl(i,j,k))**2))
3234            if (waga_dist.ge.0.0d0) then
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238             godl(k)=dexp(-distancek(k)+min_odl)
3239             odleg2=odleg2+godl(k)
3240 c
3241 c          For Lorentzian-type Urestr
3242 c
3243            else
3244             odleg2=odleg2+distancek(k)
3245            endif
3246
3247 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3248 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3249 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3250 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3251
3252          enddo
3253 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3254 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3255 #ifdef DEBUG
3256          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3257          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3258 #endif
3259            if (waga_dist.ge.0.0d0) then
3260 c
3261 c          For Gaussian-type Urestr
3262 c
3263               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3264 c
3265 c          For Lorentzian-type Urestr
3266 c
3267            else
3268               odleg=odleg+odleg2/constr_homology
3269            endif
3270 c
3271 #ifdef GRAD
3272 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3273 c Gradient
3274 c
3275 c          For Gaussian-type Urestr
3276 c
3277          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3278          sum_sgodl=0.0d0
3279          do k=1,constr_homology
3280 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3281 c     &           *waga_dist)+min_odl
3282 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3283 c
3284          if (waga_dist.ge.0.0d0) then
3285 c          For Gaussian-type Urestr
3286 c
3287            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3288 c
3289 c          For Lorentzian-type Urestr
3290 c
3291          else
3292            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3293      &           sigma_odlir(k,ii)**2)**2)
3294          endif
3295            sum_sgodl=sum_sgodl+sgodl
3296
3297 c            sgodl2=sgodl2+sgodl
3298 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3299 c      write(iout,*) "constr_homology=",constr_homology
3300 c      write(iout,*) i, j, k, "TEST K"
3301          enddo
3302          if (waga_dist.ge.0.0d0) then
3303 c
3304 c          For Gaussian-type Urestr
3305 c
3306             grad_odl3=waga_homology(iset)*waga_dist
3307      &                *sum_sgodl/(sum_godl*dij)
3308 c
3309 c          For Lorentzian-type Urestr
3310 c
3311          else
3312 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3313 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3314             grad_odl3=-waga_homology(iset)*waga_dist*
3315      &                sum_sgodl/(constr_homology*dij)
3316          endif
3317 c
3318 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3319
3320
3321 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3322 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3323 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3324
3325 ccc      write(iout,*) godl, sgodl, grad_odl3
3326
3327 c          grad_odl=grad_odl+grad_odl3
3328
3329          do jik=1,3
3330             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3331 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3332 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3333 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3334             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3335             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3336 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3337 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3338 c         if (i.eq.25.and.j.eq.27) then
3339 c         write(iout,*) "jik",jik,"i",i,"j",j
3340 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3341 c         write(iout,*) "grad_odl3",grad_odl3
3342 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3343 c         write(iout,*) "ggodl",ggodl
3344 c         write(iout,*) "ghpbc(",jik,i,")",
3345 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3346 c     &                 ghpbc(jik,j)
3347 c         endif
3348          enddo
3349 #endif
3350 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3351 ccc     & dLOG(odleg2),"-odleg=", -odleg
3352
3353       enddo ! ii-loop for dist
3354 #ifdef DEBUG
3355       write(iout,*) "------- dist restrs end -------"
3356 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3357 c    &     waga_d.eq.1.0d0) call sum_gradient
3358 #endif
3359 c Pseudo-energy and gradient from dihedral-angle restraints from
3360 c homology templates
3361 c      write (iout,*) "End of distance loop"
3362 c      call flush(iout)
3363       kat=0.0d0
3364 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3365 #ifdef DEBUG
3366       write(iout,*) "------- dih restrs start -------"
3367       do i=idihconstr_start_homo,idihconstr_end_homo
3368         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3369       enddo
3370 #endif
3371       do i=idihconstr_start_homo,idihconstr_end_homo
3372         kat2=0.0d0
3373 c        betai=beta(i,i+1,i+2,i+3)
3374         betai = phi(i+3)
3375 c       write (iout,*) "betai =",betai
3376         do k=1,constr_homology
3377           dih_diff(k)=pinorm(dih(k,i)-betai)
3378 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3379 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3380 c     &                                   -(6.28318-dih_diff(i,k))
3381 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3382 c     &                                   6.28318+dih_diff(i,k)
3383
3384           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3385 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3386           gdih(k)=dexp(kat3)
3387           kat2=kat2+gdih(k)
3388 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3389 c          write(*,*)""
3390         enddo
3391 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3392 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3393 #ifdef DEBUG
3394         write (iout,*) "i",i," betai",betai," kat2",kat2
3395         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3396 #endif
3397         if (kat2.le.1.0d-14) cycle
3398         kat=kat-dLOG(kat2/constr_homology)
3399 c       write (iout,*) "kat",kat ! sum of -ln-s
3400
3401 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3402 ccc     & dLOG(kat2), "-kat=", -kat
3403
3404 #ifdef GRAD
3405 c ----------------------------------------------------------------------
3406 c Gradient
3407 c ----------------------------------------------------------------------
3408
3409         sum_gdih=kat2
3410         sum_sgdih=0.0d0
3411         do k=1,constr_homology
3412           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3413 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3414           sum_sgdih=sum_sgdih+sgdih
3415         enddo
3416 c       grad_dih3=sum_sgdih/sum_gdih
3417         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3418
3419 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3420 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3421 ccc     & gloc(nphi+i-3,icg)
3422         gloc(i,icg)=gloc(i,icg)+grad_dih3
3423 c        if (i.eq.25) then
3424 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3425 c        endif
3426 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3427 ccc     & gloc(nphi+i-3,icg)
3428 #endif
3429       enddo ! i-loop for dih
3430 #ifdef DEBUG
3431       write(iout,*) "------- dih restrs end -------"
3432 #endif
3433
3434 c Pseudo-energy and gradient for theta angle restraints from
3435 c homology templates
3436 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3437 c adapted
3438
3439 c
3440 c     For constr_homology reference structures (FP)
3441 c
3442 c     Uconst_back_tot=0.0d0
3443       Eval=0.0d0
3444       Erot=0.0d0
3445 c     Econstr_back legacy
3446 #ifdef GRAD
3447       do i=1,nres
3448 c     do i=ithet_start,ithet_end
3449        dutheta(i)=0.0d0
3450 c     enddo
3451 c     do i=loc_start,loc_end
3452         do j=1,3
3453           duscdiff(j,i)=0.0d0
3454           duscdiffx(j,i)=0.0d0
3455         enddo
3456       enddo
3457 #endif
3458 c
3459 c     do iref=1,nref
3460 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3461 c     write (iout,*) "waga_theta",waga_theta
3462       if (waga_theta.gt.0.0d0) then
3463 #ifdef DEBUG
3464       write (iout,*) "usampl",usampl
3465       write(iout,*) "------- theta restrs start -------"
3466 c     do i=ithet_start,ithet_end
3467 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3468 c     enddo
3469 #endif
3470 c     write (iout,*) "maxres",maxres,"nres",nres
3471
3472       do i=ithet_start,ithet_end
3473 c
3474 c     do i=1,nfrag_back
3475 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3476 c
3477 c Deviation of theta angles wrt constr_homology ref structures
3478 c
3479         utheta_i=0.0d0 ! argument of Gaussian for single k
3480         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3481 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3482 c       over residues in a fragment
3483 c       write (iout,*) "theta(",i,")=",theta(i)
3484         do k=1,constr_homology
3485 c
3486 c         dtheta_i=theta(j)-thetaref(j,iref)
3487 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3488           theta_diff(k)=thetatpl(k,i)-theta(i)
3489 c
3490           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3491 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3492           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3493           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3494 c         Gradient for single Gaussian restraint in subr Econstr_back
3495 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3496 c
3497         enddo
3498 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3499 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3500
3501 c
3502 #ifdef GRAD
3503 c         Gradient for multiple Gaussian restraint
3504         sum_gtheta=gutheta_i
3505         sum_sgtheta=0.0d0
3506         do k=1,constr_homology
3507 c        New generalized expr for multiple Gaussian from Econstr_back
3508          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3509 c
3510 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3511           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3512         enddo
3513 c
3514 c       Final value of gradient using same var as in Econstr_back
3515         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3516      &               *waga_homology(iset)
3517 c       dutheta(i)=sum_sgtheta/sum_gtheta
3518 c
3519 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3520 #endif
3521         Eval=Eval-dLOG(gutheta_i/constr_homology)
3522 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3523 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3524 c       Uconst_back=Uconst_back+utheta(i)
3525       enddo ! (i-loop for theta)
3526 #ifdef DEBUG
3527       write(iout,*) "------- theta restrs end -------"
3528 #endif
3529       endif
3530 c
3531 c Deviation of local SC geometry
3532 c
3533 c Separation of two i-loops (instructed by AL - 11/3/2014)
3534 c
3535 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3536 c     write (iout,*) "waga_d",waga_d
3537
3538 #ifdef DEBUG
3539       write(iout,*) "------- SC restrs start -------"
3540       write (iout,*) "Initial duscdiff,duscdiffx"
3541       do i=loc_start,loc_end
3542         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3543      &                 (duscdiffx(jik,i),jik=1,3)
3544       enddo
3545 #endif
3546       do i=loc_start,loc_end
3547         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3548         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3549 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3550 c       write(iout,*) "xxtab, yytab, zztab"
3551 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3552         do k=1,constr_homology
3553 c
3554           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3555 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3556           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3557           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3558 c         write(iout,*) "dxx, dyy, dzz"
3559 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3560 c
3561           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3562 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3563 c         uscdiffk(k)=usc_diff(i)
3564           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3565           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3566 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3567 c     &      xxref(j),yyref(j),zzref(j)
3568         enddo
3569 c
3570 c       Gradient
3571 c
3572 c       Generalized expression for multiple Gaussian acc to that for a single
3573 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3574 c
3575 c       Original implementation
3576 c       sum_guscdiff=guscdiff(i)
3577 c
3578 c       sum_sguscdiff=0.0d0
3579 c       do k=1,constr_homology
3580 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3581 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3582 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3583 c       enddo
3584 c
3585 c       Implementation of new expressions for gradient (Jan. 2015)
3586 c
3587 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3588 #ifdef GRAD
3589         do k=1,constr_homology
3590 c
3591 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3592 c       before. Now the drivatives should be correct
3593 c
3594           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3595 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3596           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3597           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3598 c
3599 c         New implementation
3600 c
3601           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3602      &                 sigma_d(k,i) ! for the grad wrt r'
3603 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3604 c
3605 c
3606 c        New implementation
3607          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3608          do jik=1,3
3609             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3610      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3611      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3612             duscdiff(jik,i)=duscdiff(jik,i)+
3613      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3614      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3615             duscdiffx(jik,i)=duscdiffx(jik,i)+
3616      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3617      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3618 c
3619 #ifdef DEBUG
3620              write(iout,*) "jik",jik,"i",i
3621              write(iout,*) "dxx, dyy, dzz"
3622              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3623              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3624 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3625 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3626 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3627 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3628 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3629 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3630 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3631 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3632 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3633 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3634 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3635 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3636 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3637 c            endif
3638 #endif
3639          enddo
3640         enddo
3641 #endif
3642 c
3643 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3644 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3645 c
3646 c        write (iout,*) i," uscdiff",uscdiff(i)
3647 c
3648 c Put together deviations from local geometry
3649
3650 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3651 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3652         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3653 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3654 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3655 c       Uconst_back=Uconst_back+usc_diff(i)
3656 c
3657 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3658 c
3659 c     New implment: multiplied by sum_sguscdiff
3660 c
3661
3662       enddo ! (i-loop for dscdiff)
3663
3664 c      endif
3665
3666 #ifdef DEBUG
3667       write(iout,*) "------- SC restrs end -------"
3668         write (iout,*) "------ After SC loop in e_modeller ------"
3669         do i=loc_start,loc_end
3670          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3671          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3672         enddo
3673       if (waga_theta.eq.1.0d0) then
3674       write (iout,*) "in e_modeller after SC restr end: dutheta"
3675       do i=ithet_start,ithet_end
3676         write (iout,*) i,dutheta(i)
3677       enddo
3678       endif
3679       if (waga_d.eq.1.0d0) then
3680       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3681       do i=1,nres
3682         write (iout,*) i,(duscdiff(j,i),j=1,3)
3683         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3684       enddo
3685       endif
3686 #endif
3687
3688 c Total energy from homology restraints
3689 #ifdef DEBUG
3690       write (iout,*) "odleg",odleg," kat",kat
3691       write (iout,*) "odleg",odleg," kat",kat
3692       write (iout,*) "Eval",Eval," Erot",Erot
3693       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3694       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3695       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3696 #endif
3697 c
3698 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3699 c
3700 c     ehomology_constr=odleg+kat
3701 c
3702 c     For Lorentzian-type Urestr
3703 c
3704
3705       if (waga_dist.ge.0.0d0) then
3706 c
3707 c          For Gaussian-type Urestr
3708 c
3709 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3710 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3711         ehomology_constr=waga_dist*odleg+waga_angle*kat+
3712      &              waga_theta*Eval+waga_d*Erot
3713 c     write (iout,*) "ehomology_constr=",ehomology_constr
3714       else
3715 c
3716 c          For Lorentzian-type Urestr
3717 c
3718 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3719 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3720         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
3721      &              waga_theta*Eval+waga_d*Erot
3722 c     write (iout,*) "ehomology_constr=",ehomology_constr
3723       endif
3724 #ifdef DEBUG
3725       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3726      & "Eval",waga_theta,eval,
3727      &   "Erot",waga_d,Erot
3728       write (iout,*) "ehomology_constr",ehomology_constr
3729 #endif
3730       return
3731
3732   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3733   747 format(a12,i4,i4,i4,f8.3,f8.3)
3734   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3735   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3736   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3737      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3738       end
3739 c-----------------------------------------------------------------------
3740       subroutine ebond(estr)
3741 c
3742 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3743 c
3744       implicit real*8 (a-h,o-z)
3745       include 'DIMENSIONS'
3746       include 'DIMENSIONS.ZSCOPT'
3747       include 'COMMON.LOCAL'
3748       include 'COMMON.GEO'
3749       include 'COMMON.INTERACT'
3750       include 'COMMON.DERIV'
3751       include 'COMMON.VAR'
3752       include 'COMMON.CHAIN'
3753       include 'COMMON.IOUNITS'
3754       include 'COMMON.NAMES'
3755       include 'COMMON.FFIELD'
3756       include 'COMMON.CONTROL'
3757       double precision u(3),ud(3)
3758       logical :: lprn=.false.
3759       estr=0.0d0
3760       do i=nnt+1,nct
3761         diff = vbld(i)-vbldp0
3762 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3763         estr=estr+diff*diff
3764         do j=1,3
3765           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3766         enddo
3767       enddo
3768       estr=0.5d0*AKP*estr
3769 c
3770 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3771 c
3772       do i=nnt,nct
3773         iti=itype(i)
3774         if (iti.ne.10) then
3775           nbi=nbondterm(iti)
3776           if (nbi.eq.1) then
3777             diff=vbld(i+nres)-vbldsc0(1,iti)
3778             if (lprn)
3779      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3780      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3781             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3782             do j=1,3
3783               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3784             enddo
3785           else
3786             do j=1,nbi
3787               diff=vbld(i+nres)-vbldsc0(j,iti)
3788               ud(j)=aksc(j,iti)*diff
3789               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3790             enddo
3791             uprod=u(1)
3792             do j=2,nbi
3793               uprod=uprod*u(j)
3794             enddo
3795             usum=0.0d0
3796             usumsqder=0.0d0
3797             do j=1,nbi
3798               uprod1=1.0d0
3799               uprod2=1.0d0
3800               do k=1,nbi
3801                 if (k.ne.j) then
3802                   uprod1=uprod1*u(k)
3803                   uprod2=uprod2*u(k)*u(k)
3804                 endif
3805               enddo
3806               usum=usum+uprod1
3807               usumsqder=usumsqder+ud(j)*uprod2
3808             enddo
3809             if (lprn)
3810      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3811      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3812             estr=estr+uprod/usum
3813             do j=1,3
3814              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3815             enddo
3816           endif
3817         endif
3818       enddo
3819       return
3820       end
3821 #ifdef CRYST_THETA
3822 C--------------------------------------------------------------------------
3823       subroutine ebend(etheta)
3824 C
3825 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3826 C angles gamma and its derivatives in consecutive thetas and gammas.
3827 C
3828       implicit real*8 (a-h,o-z)
3829       include 'DIMENSIONS'
3830       include 'DIMENSIONS.ZSCOPT'
3831       include 'COMMON.LOCAL'
3832       include 'COMMON.GEO'
3833       include 'COMMON.INTERACT'
3834       include 'COMMON.DERIV'
3835       include 'COMMON.VAR'
3836       include 'COMMON.CHAIN'
3837       include 'COMMON.IOUNITS'
3838       include 'COMMON.NAMES'
3839       include 'COMMON.FFIELD'
3840       common /calcthet/ term1,term2,termm,diffak,ratak,
3841      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3842      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3843       double precision y(2),z(2)
3844       delta=0.02d0*pi
3845       time11=dexp(-2*time)
3846       time12=1.0d0
3847       etheta=0.0D0
3848 c      write (iout,*) "nres",nres
3849 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3850 c      write (iout,*) ithet_start,ithet_end
3851       do i=ithet_start,ithet_end
3852 C Zero the energy function and its derivative at 0 or pi.
3853         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3854         it=itype(i-1)
3855 c        if (i.gt.ithet_start .and.
3856 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3857 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3858 c          phii=phi(i)
3859 c          y(1)=dcos(phii)
3860 c          y(2)=dsin(phii)
3861 c        else
3862 c          y(1)=0.0D0
3863 c          y(2)=0.0D0
3864 c        endif
3865 c        if (i.lt.nres .and. itel(i).ne.0) then
3866 c          phii1=phi(i+1)
3867 c          z(1)=dcos(phii1)
3868 c          z(2)=dsin(phii1)
3869 c        else
3870 c          z(1)=0.0D0
3871 c          z(2)=0.0D0
3872 c        endif
3873         if (i.gt.3) then
3874 #ifdef OSF
3875           phii=phi(i)
3876           icrc=0
3877           call proc_proc(phii,icrc)
3878           if (icrc.eq.1) phii=150.0
3879 #else
3880           phii=phi(i)
3881 #endif
3882           y(1)=dcos(phii)
3883           y(2)=dsin(phii)
3884         else
3885           y(1)=0.0D0
3886           y(2)=0.0D0
3887         endif
3888         if (i.lt.nres) then
3889 #ifdef OSF
3890           phii1=phi(i+1)
3891           icrc=0
3892           call proc_proc(phii1,icrc)
3893           if (icrc.eq.1) phii1=150.0
3894           phii1=pinorm(phii1)
3895           z(1)=cos(phii1)
3896 #else
3897           phii1=phi(i+1)
3898           z(1)=dcos(phii1)
3899 #endif
3900           z(2)=dsin(phii1)
3901         else
3902           z(1)=0.0D0
3903           z(2)=0.0D0
3904         endif
3905 C Calculate the "mean" value of theta from the part of the distribution
3906 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3907 C In following comments this theta will be referred to as t_c.
3908         thet_pred_mean=0.0d0
3909         do k=1,2
3910           athetk=athet(k,it)
3911           bthetk=bthet(k,it)
3912           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3913         enddo
3914 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3915         dthett=thet_pred_mean*ssd
3916         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3917 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3918 C Derivatives of the "mean" values in gamma1 and gamma2.
3919         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3920         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3921         if (theta(i).gt.pi-delta) then
3922           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3923      &         E_tc0)
3924           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3925           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3926           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3927      &        E_theta)
3928           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3929      &        E_tc)
3930         else if (theta(i).lt.delta) then
3931           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3932           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3933           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3934      &        E_theta)
3935           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3936           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3937      &        E_tc)
3938         else
3939           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3940      &        E_theta,E_tc)
3941         endif
3942         etheta=etheta+ethetai
3943 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3944 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3945         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3946         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3947         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3948  1215   continue
3949       enddo
3950 C Ufff.... We've done all this!!!
3951       return
3952       end
3953 C---------------------------------------------------------------------------
3954       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3955      &     E_tc)
3956       implicit real*8 (a-h,o-z)
3957       include 'DIMENSIONS'
3958       include 'COMMON.LOCAL'
3959       include 'COMMON.IOUNITS'
3960       common /calcthet/ term1,term2,termm,diffak,ratak,
3961      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3962      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3963 C Calculate the contributions to both Gaussian lobes.
3964 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3965 C The "polynomial part" of the "standard deviation" of this part of
3966 C the distribution.
3967         sig=polthet(3,it)
3968         do j=2,0,-1
3969           sig=sig*thet_pred_mean+polthet(j,it)
3970         enddo
3971 C Derivative of the "interior part" of the "standard deviation of the"
3972 C gamma-dependent Gaussian lobe in t_c.
3973         sigtc=3*polthet(3,it)
3974         do j=2,1,-1
3975           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3976         enddo
3977         sigtc=sig*sigtc
3978 C Set the parameters of both Gaussian lobes of the distribution.
3979 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3980         fac=sig*sig+sigc0(it)
3981         sigcsq=fac+fac
3982         sigc=1.0D0/sigcsq
3983 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3984         sigsqtc=-4.0D0*sigcsq*sigtc
3985 c       print *,i,sig,sigtc,sigsqtc
3986 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3987         sigtc=-sigtc/(fac*fac)
3988 C Following variable is sigma(t_c)**(-2)
3989         sigcsq=sigcsq*sigcsq
3990         sig0i=sig0(it)
3991         sig0inv=1.0D0/sig0i**2
3992         delthec=thetai-thet_pred_mean
3993         delthe0=thetai-theta0i
3994         term1=-0.5D0*sigcsq*delthec*delthec
3995         term2=-0.5D0*sig0inv*delthe0*delthe0
3996 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3997 C NaNs in taking the logarithm. We extract the largest exponent which is added
3998 C to the energy (this being the log of the distribution) at the end of energy
3999 C term evaluation for this virtual-bond angle.
4000         if (term1.gt.term2) then
4001           termm=term1
4002           term2=dexp(term2-termm)
4003           term1=1.0d0
4004         else
4005           termm=term2
4006           term1=dexp(term1-termm)
4007           term2=1.0d0
4008         endif
4009 C The ratio between the gamma-independent and gamma-dependent lobes of
4010 C the distribution is a Gaussian function of thet_pred_mean too.
4011         diffak=gthet(2,it)-thet_pred_mean
4012         ratak=diffak/gthet(3,it)**2
4013         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4014 C Let's differentiate it in thet_pred_mean NOW.
4015         aktc=ak*ratak
4016 C Now put together the distribution terms to make complete distribution.
4017         termexp=term1+ak*term2
4018         termpre=sigc+ak*sig0i
4019 C Contribution of the bending energy from this theta is just the -log of
4020 C the sum of the contributions from the two lobes and the pre-exponential
4021 C factor. Simple enough, isn't it?
4022         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4023 C NOW the derivatives!!!
4024 C 6/6/97 Take into account the deformation.
4025         E_theta=(delthec*sigcsq*term1
4026      &       +ak*delthe0*sig0inv*term2)/termexp
4027         E_tc=((sigtc+aktc*sig0i)/termpre
4028      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4029      &       aktc*term2)/termexp)
4030       return
4031       end
4032 c-----------------------------------------------------------------------------
4033       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4034       implicit real*8 (a-h,o-z)
4035       include 'DIMENSIONS'
4036       include 'COMMON.LOCAL'
4037       include 'COMMON.IOUNITS'
4038       common /calcthet/ term1,term2,termm,diffak,ratak,
4039      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4040      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4041       delthec=thetai-thet_pred_mean
4042       delthe0=thetai-theta0i
4043 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4044       t3 = thetai-thet_pred_mean
4045       t6 = t3**2
4046       t9 = term1
4047       t12 = t3*sigcsq
4048       t14 = t12+t6*sigsqtc
4049       t16 = 1.0d0
4050       t21 = thetai-theta0i
4051       t23 = t21**2
4052       t26 = term2
4053       t27 = t21*t26
4054       t32 = termexp
4055       t40 = t32**2
4056       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4057      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4058      & *(-t12*t9-ak*sig0inv*t27)
4059       return
4060       end
4061 #else
4062 C--------------------------------------------------------------------------
4063       subroutine ebend(etheta)
4064 C
4065 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4066 C angles gamma and its derivatives in consecutive thetas and gammas.
4067 C ab initio-derived potentials from
4068 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4069 C
4070       implicit real*8 (a-h,o-z)
4071       include 'DIMENSIONS'
4072       include 'DIMENSIONS.ZSCOPT'
4073       include 'COMMON.LOCAL'
4074       include 'COMMON.GEO'
4075       include 'COMMON.INTERACT'
4076       include 'COMMON.DERIV'
4077       include 'COMMON.VAR'
4078       include 'COMMON.CHAIN'
4079       include 'COMMON.IOUNITS'
4080       include 'COMMON.NAMES'
4081       include 'COMMON.FFIELD'
4082       include 'COMMON.CONTROL'
4083       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4084      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4085      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4086      & sinph1ph2(maxdouble,maxdouble)
4087       logical lprn /.false./, lprn1 /.false./
4088       etheta=0.0D0
4089 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4090       do i=ithet_start,ithet_end
4091         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4092      &    (itype(i).eq.ntyp1)) cycle
4093         dethetai=0.0d0
4094         dephii=0.0d0
4095         dephii1=0.0d0
4096         theti2=0.5d0*theta(i)
4097         ityp2=ithetyp(itype(i-1))
4098         do k=1,nntheterm
4099           coskt(k)=dcos(k*theti2)
4100           sinkt(k)=dsin(k*theti2)
4101         enddo
4102         if (i.gt.3  .and. itype(i-3).ne.ntyp1) then
4103 #ifdef OSF
4104           phii=phi(i)
4105           if (phii.ne.phii) phii=150.0
4106 #else
4107           phii=phi(i)
4108 #endif
4109           ityp1=ithetyp(itype(i-2))
4110           do k=1,nsingle
4111             cosph1(k)=dcos(k*phii)
4112             sinph1(k)=dsin(k*phii)
4113           enddo
4114         else
4115           phii=0.0d0
4116           ityp1=ithetyp(itype(i-2))
4117           do k=1,nsingle
4118             cosph1(k)=0.0d0
4119             sinph1(k)=0.0d0
4120           enddo
4121         endif
4122         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4123 #ifdef OSF
4124           phii1=phi(i+1)
4125           if (phii1.ne.phii1) phii1=150.0
4126           phii1=pinorm(phii1)
4127 #else
4128           phii1=phi(i+1)
4129 #endif
4130           ityp3=ithetyp(itype(i))
4131           do k=1,nsingle
4132             cosph2(k)=dcos(k*phii1)
4133             sinph2(k)=dsin(k*phii1)
4134           enddo
4135         else
4136           phii1=0.0d0
4137 c          ityp3=nthetyp+1
4138           ityp3=ithetyp(itype(i))
4139           do k=1,nsingle
4140             cosph2(k)=0.0d0
4141             sinph2(k)=0.0d0
4142           enddo
4143         endif
4144 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4145 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4146 c        call flush(iout)
4147         ethetai=aa0thet(ityp1,ityp2,ityp3)
4148         do k=1,ndouble
4149           do l=1,k-1
4150             ccl=cosph1(l)*cosph2(k-l)
4151             ssl=sinph1(l)*sinph2(k-l)
4152             scl=sinph1(l)*cosph2(k-l)
4153             csl=cosph1(l)*sinph2(k-l)
4154             cosph1ph2(l,k)=ccl-ssl
4155             cosph1ph2(k,l)=ccl+ssl
4156             sinph1ph2(l,k)=scl+csl
4157             sinph1ph2(k,l)=scl-csl
4158           enddo
4159         enddo
4160         if (lprn) then
4161         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4162      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4163         write (iout,*) "coskt and sinkt"
4164         do k=1,nntheterm
4165           write (iout,*) k,coskt(k),sinkt(k)
4166         enddo
4167         endif
4168         do k=1,ntheterm
4169           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4170           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4171      &      *coskt(k)
4172           if (lprn)
4173      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4174      &     " ethetai",ethetai
4175         enddo
4176         if (lprn) then
4177         write (iout,*) "cosph and sinph"
4178         do k=1,nsingle
4179           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4180         enddo
4181         write (iout,*) "cosph1ph2 and sinph2ph2"
4182         do k=2,ndouble
4183           do l=1,k-1
4184             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4185      &         sinph1ph2(l,k),sinph1ph2(k,l)
4186           enddo
4187         enddo
4188         write(iout,*) "ethetai",ethetai
4189         endif
4190         do m=1,ntheterm2
4191           do k=1,nsingle
4192             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4193      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4194      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4195      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4196             ethetai=ethetai+sinkt(m)*aux
4197             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4198             dephii=dephii+k*sinkt(m)*(
4199      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4200      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4201             dephii1=dephii1+k*sinkt(m)*(
4202      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4203      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4204             if (lprn)
4205      &      write (iout,*) "m",m," k",k," bbthet",
4206      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4207      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4208      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4209      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4210           enddo
4211         enddo
4212         if (lprn)
4213      &  write(iout,*) "ethetai",ethetai
4214         do m=1,ntheterm3
4215           do k=2,ndouble
4216             do l=1,k-1
4217               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4218      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4219      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4220      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4221               ethetai=ethetai+sinkt(m)*aux
4222               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4223               dephii=dephii+l*sinkt(m)*(
4224      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4225      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4226      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4227      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4228               dephii1=dephii1+(k-l)*sinkt(m)*(
4229      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4230      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4231      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4232      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4233               if (lprn) then
4234               write (iout,*) "m",m," k",k," l",l," ffthet",
4235      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4236      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4237      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4238      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4239               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4240      &            cosph1ph2(k,l)*sinkt(m),
4241      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4242               endif
4243             enddo
4244           enddo
4245         enddo
4246 10      continue
4247 c        lprn1=.true.
4248         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4249      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4250      &   phii1*rad2deg,ethetai
4251 c        lprn1=.false.
4252         etheta=etheta+ethetai
4253
4254         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4255         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4256         gloc(nphi+i-2,icg)=wang*dethetai
4257       enddo
4258       return
4259       end
4260 #endif
4261 #ifdef CRYST_SC
4262 c-----------------------------------------------------------------------------
4263       subroutine esc(escloc)
4264 C Calculate the local energy of a side chain and its derivatives in the
4265 C corresponding virtual-bond valence angles THETA and the spherical angles
4266 C ALPHA and OMEGA.
4267       implicit real*8 (a-h,o-z)
4268       include 'DIMENSIONS'
4269       include 'DIMENSIONS.ZSCOPT'
4270       include 'COMMON.GEO'
4271       include 'COMMON.LOCAL'
4272       include 'COMMON.VAR'
4273       include 'COMMON.INTERACT'
4274       include 'COMMON.DERIV'
4275       include 'COMMON.CHAIN'
4276       include 'COMMON.IOUNITS'
4277       include 'COMMON.NAMES'
4278       include 'COMMON.FFIELD'
4279       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4280      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4281       common /sccalc/ time11,time12,time112,theti,it,nlobit
4282       delta=0.02d0*pi
4283       escloc=0.0D0
4284 c     write (iout,'(a)') 'ESC'
4285       do i=loc_start,loc_end
4286         it=itype(i)
4287         if (it.eq.10) goto 1
4288         nlobit=nlob(it)
4289 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4290 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4291         theti=theta(i+1)-pipol
4292         x(1)=dtan(theti)
4293         x(2)=alph(i)
4294         x(3)=omeg(i)
4295 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4296
4297         if (x(2).gt.pi-delta) then
4298           xtemp(1)=x(1)
4299           xtemp(2)=pi-delta
4300           xtemp(3)=x(3)
4301           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4302           xtemp(2)=pi
4303           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4304           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4305      &        escloci,dersc(2))
4306           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4307      &        ddersc0(1),dersc(1))
4308           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4309      &        ddersc0(3),dersc(3))
4310           xtemp(2)=pi-delta
4311           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4312           xtemp(2)=pi
4313           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4314           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4315      &            dersc0(2),esclocbi,dersc02)
4316           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4317      &            dersc12,dersc01)
4318           call splinthet(x(2),0.5d0*delta,ss,ssd)
4319           dersc0(1)=dersc01
4320           dersc0(2)=dersc02
4321           dersc0(3)=0.0d0
4322           do k=1,3
4323             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4324           enddo
4325           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4326 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4327 c    &             esclocbi,ss,ssd
4328           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4329 c         escloci=esclocbi
4330 c         write (iout,*) escloci
4331         else if (x(2).lt.delta) then
4332           xtemp(1)=x(1)
4333           xtemp(2)=delta
4334           xtemp(3)=x(3)
4335           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4336           xtemp(2)=0.0d0
4337           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4338           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4339      &        escloci,dersc(2))
4340           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4341      &        ddersc0(1),dersc(1))
4342           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4343      &        ddersc0(3),dersc(3))
4344           xtemp(2)=delta
4345           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4346           xtemp(2)=0.0d0
4347           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4348           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4349      &            dersc0(2),esclocbi,dersc02)
4350           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4351      &            dersc12,dersc01)
4352           dersc0(1)=dersc01
4353           dersc0(2)=dersc02
4354           dersc0(3)=0.0d0
4355           call splinthet(x(2),0.5d0*delta,ss,ssd)
4356           do k=1,3
4357             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4358           enddo
4359           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4360 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4361 c    &             esclocbi,ss,ssd
4362           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4363 c         write (iout,*) escloci
4364         else
4365           call enesc(x,escloci,dersc,ddummy,.false.)
4366         endif
4367
4368         escloc=escloc+escloci
4369 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4370
4371         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4372      &   wscloc*dersc(1)
4373         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4374         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4375     1   continue
4376       enddo
4377       return
4378       end
4379 C---------------------------------------------------------------------------
4380       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4381       implicit real*8 (a-h,o-z)
4382       include 'DIMENSIONS'
4383       include 'COMMON.GEO'
4384       include 'COMMON.LOCAL'
4385       include 'COMMON.IOUNITS'
4386       common /sccalc/ time11,time12,time112,theti,it,nlobit
4387       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4388       double precision contr(maxlob,-1:1)
4389       logical mixed
4390 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4391         escloc_i=0.0D0
4392         do j=1,3
4393           dersc(j)=0.0D0
4394           if (mixed) ddersc(j)=0.0d0
4395         enddo
4396         x3=x(3)
4397
4398 C Because of periodicity of the dependence of the SC energy in omega we have
4399 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4400 C To avoid underflows, first compute & store the exponents.
4401
4402         do iii=-1,1
4403
4404           x(3)=x3+iii*dwapi
4405
4406           do j=1,nlobit
4407             do k=1,3
4408               z(k)=x(k)-censc(k,j,it)
4409             enddo
4410             do k=1,3
4411               Axk=0.0D0
4412               do l=1,3
4413                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4414               enddo
4415               Ax(k,j,iii)=Axk
4416             enddo
4417             expfac=0.0D0
4418             do k=1,3
4419               expfac=expfac+Ax(k,j,iii)*z(k)
4420             enddo
4421             contr(j,iii)=expfac
4422           enddo ! j
4423
4424         enddo ! iii
4425
4426         x(3)=x3
4427 C As in the case of ebend, we want to avoid underflows in exponentiation and
4428 C subsequent NaNs and INFs in energy calculation.
4429 C Find the largest exponent
4430         emin=contr(1,-1)
4431         do iii=-1,1
4432           do j=1,nlobit
4433             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4434           enddo
4435         enddo
4436         emin=0.5D0*emin
4437 cd      print *,'it=',it,' emin=',emin
4438
4439 C Compute the contribution to SC energy and derivatives
4440         do iii=-1,1
4441
4442           do j=1,nlobit
4443             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4444 cd          print *,'j=',j,' expfac=',expfac
4445             escloc_i=escloc_i+expfac
4446             do k=1,3
4447               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4448             enddo
4449             if (mixed) then
4450               do k=1,3,2
4451                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4452      &            +gaussc(k,2,j,it))*expfac
4453               enddo
4454             endif
4455           enddo
4456
4457         enddo ! iii
4458
4459         dersc(1)=dersc(1)/cos(theti)**2
4460         ddersc(1)=ddersc(1)/cos(theti)**2
4461         ddersc(3)=ddersc(3)
4462
4463         escloci=-(dlog(escloc_i)-emin)
4464         do j=1,3
4465           dersc(j)=dersc(j)/escloc_i
4466         enddo
4467         if (mixed) then
4468           do j=1,3,2
4469             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4470           enddo
4471         endif
4472       return
4473       end
4474 C------------------------------------------------------------------------------
4475       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4476       implicit real*8 (a-h,o-z)
4477       include 'DIMENSIONS'
4478       include 'COMMON.GEO'
4479       include 'COMMON.LOCAL'
4480       include 'COMMON.IOUNITS'
4481       common /sccalc/ time11,time12,time112,theti,it,nlobit
4482       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4483       double precision contr(maxlob)
4484       logical mixed
4485
4486       escloc_i=0.0D0
4487
4488       do j=1,3
4489         dersc(j)=0.0D0
4490       enddo
4491
4492       do j=1,nlobit
4493         do k=1,2
4494           z(k)=x(k)-censc(k,j,it)
4495         enddo
4496         z(3)=dwapi
4497         do k=1,3
4498           Axk=0.0D0
4499           do l=1,3
4500             Axk=Axk+gaussc(l,k,j,it)*z(l)
4501           enddo
4502           Ax(k,j)=Axk
4503         enddo
4504         expfac=0.0D0
4505         do k=1,3
4506           expfac=expfac+Ax(k,j)*z(k)
4507         enddo
4508         contr(j)=expfac
4509       enddo ! j
4510
4511 C As in the case of ebend, we want to avoid underflows in exponentiation and
4512 C subsequent NaNs and INFs in energy calculation.
4513 C Find the largest exponent
4514       emin=contr(1)
4515       do j=1,nlobit
4516         if (emin.gt.contr(j)) emin=contr(j)
4517       enddo
4518       emin=0.5D0*emin
4519
4520 C Compute the contribution to SC energy and derivatives
4521
4522       dersc12=0.0d0
4523       do j=1,nlobit
4524         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4525         escloc_i=escloc_i+expfac
4526         do k=1,2
4527           dersc(k)=dersc(k)+Ax(k,j)*expfac
4528         enddo
4529         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4530      &            +gaussc(1,2,j,it))*expfac
4531         dersc(3)=0.0d0
4532       enddo
4533
4534       dersc(1)=dersc(1)/cos(theti)**2
4535       dersc12=dersc12/cos(theti)**2
4536       escloci=-(dlog(escloc_i)-emin)
4537       do j=1,2
4538         dersc(j)=dersc(j)/escloc_i
4539       enddo
4540       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4541       return
4542       end
4543 #else
4544 c----------------------------------------------------------------------------------
4545       subroutine esc(escloc)
4546 C Calculate the local energy of a side chain and its derivatives in the
4547 C corresponding virtual-bond valence angles THETA and the spherical angles
4548 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4549 C added by Urszula Kozlowska. 07/11/2007
4550 C
4551       implicit real*8 (a-h,o-z)
4552       include 'DIMENSIONS'
4553       include 'DIMENSIONS.ZSCOPT'
4554       include 'COMMON.GEO'
4555       include 'COMMON.LOCAL'
4556       include 'COMMON.VAR'
4557       include 'COMMON.SCROT'
4558       include 'COMMON.INTERACT'
4559       include 'COMMON.DERIV'
4560       include 'COMMON.CHAIN'
4561       include 'COMMON.IOUNITS'
4562       include 'COMMON.NAMES'
4563       include 'COMMON.FFIELD'
4564       include 'COMMON.CONTROL'
4565       include 'COMMON.VECTORS'
4566       double precision x_prime(3),y_prime(3),z_prime(3)
4567      &    , sumene,dsc_i,dp2_i,x(65),
4568      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4569      &    de_dxx,de_dyy,de_dzz,de_dt
4570       double precision s1_t,s1_6_t,s2_t,s2_6_t
4571       double precision
4572      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4573      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4574      & dt_dCi(3),dt_dCi1(3)
4575       common /sccalc/ time11,time12,time112,theti,it,nlobit
4576       delta=0.02d0*pi
4577       escloc=0.0D0
4578       do i=loc_start,loc_end
4579         costtab(i+1) =dcos(theta(i+1))
4580         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4581         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4582         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4583         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4584         cosfac=dsqrt(cosfac2)
4585         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4586         sinfac=dsqrt(sinfac2)
4587         it=itype(i)
4588         if (it.eq.10) goto 1
4589 c
4590 C  Compute the axes of tghe local cartesian coordinates system; store in
4591 c   x_prime, y_prime and z_prime
4592 c
4593         do j=1,3
4594           x_prime(j) = 0.00
4595           y_prime(j) = 0.00
4596           z_prime(j) = 0.00
4597         enddo
4598 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4599 C     &   dc_norm(3,i+nres)
4600         do j = 1,3
4601           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4602           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4603         enddo
4604         do j = 1,3
4605           z_prime(j) = -uz(j,i-1)
4606         enddo
4607 c       write (2,*) "i",i
4608 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4609 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4610 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4611 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4612 c      & " xy",scalar(x_prime(1),y_prime(1)),
4613 c      & " xz",scalar(x_prime(1),z_prime(1)),
4614 c      & " yy",scalar(y_prime(1),y_prime(1)),
4615 c      & " yz",scalar(y_prime(1),z_prime(1)),
4616 c      & " zz",scalar(z_prime(1),z_prime(1))
4617 c
4618 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4619 C to local coordinate system. Store in xx, yy, zz.
4620 c
4621         xx=0.0d0
4622         yy=0.0d0
4623         zz=0.0d0
4624         do j = 1,3
4625           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4626           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4627           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4628         enddo
4629
4630         xxtab(i)=xx
4631         yytab(i)=yy
4632         zztab(i)=zz
4633 C
4634 C Compute the energy of the ith side cbain
4635 C
4636 c        write (2,*) "xx",xx," yy",yy," zz",zz
4637         it=itype(i)
4638         do j = 1,65
4639           x(j) = sc_parmin(j,it)
4640         enddo
4641 #ifdef CHECK_COORD
4642 Cc diagnostics - remove later
4643         xx1 = dcos(alph(2))
4644         yy1 = dsin(alph(2))*dcos(omeg(2))
4645         zz1 = -dsin(alph(2))*dsin(omeg(2))
4646         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4647      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4648      &    xx1,yy1,zz1
4649 C,"  --- ", xx_w,yy_w,zz_w
4650 c end diagnostics
4651 #endif
4652         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4653      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4654      &   + x(10)*yy*zz
4655         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4656      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4657      & + x(20)*yy*zz
4658         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4659      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4660      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4661      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4662      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4663      &  +x(40)*xx*yy*zz
4664         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4665      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4666      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4667      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4668      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4669      &  +x(60)*xx*yy*zz
4670         dsc_i   = 0.743d0+x(61)
4671         dp2_i   = 1.9d0+x(62)
4672         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4673      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4674         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4675      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4676         s1=(1+x(63))/(0.1d0 + dscp1)
4677         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4678         s2=(1+x(65))/(0.1d0 + dscp2)
4679         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4680         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4681      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4682 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4683 c     &   sumene4,
4684 c     &   dscp1,dscp2,sumene
4685 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4686         escloc = escloc + sumene
4687 c        write (2,*) "escloc",escloc
4688         if (.not. calc_grad) goto 1
4689
4690 #ifdef DEBUG2
4691 C
4692 C This section to check the numerical derivatives of the energy of ith side
4693 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4694 C #define DEBUG in the code to turn it on.
4695 C
4696         write (2,*) "sumene               =",sumene
4697         aincr=1.0d-7
4698         xxsave=xx
4699         xx=xx+aincr
4700         write (2,*) xx,yy,zz
4701         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4702         de_dxx_num=(sumenep-sumene)/aincr
4703         xx=xxsave
4704         write (2,*) "xx+ sumene from enesc=",sumenep
4705         yysave=yy
4706         yy=yy+aincr
4707         write (2,*) xx,yy,zz
4708         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4709         de_dyy_num=(sumenep-sumene)/aincr
4710         yy=yysave
4711         write (2,*) "yy+ sumene from enesc=",sumenep
4712         zzsave=zz
4713         zz=zz+aincr
4714         write (2,*) xx,yy,zz
4715         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4716         de_dzz_num=(sumenep-sumene)/aincr
4717         zz=zzsave
4718         write (2,*) "zz+ sumene from enesc=",sumenep
4719         costsave=cost2tab(i+1)
4720         sintsave=sint2tab(i+1)
4721         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4722         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4723         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4724         de_dt_num=(sumenep-sumene)/aincr
4725         write (2,*) " t+ sumene from enesc=",sumenep
4726         cost2tab(i+1)=costsave
4727         sint2tab(i+1)=sintsave
4728 C End of diagnostics section.
4729 #endif
4730 C
4731 C Compute the gradient of esc
4732 C
4733         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4734         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4735         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4736         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4737         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4738         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4739         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4740         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4741         pom1=(sumene3*sint2tab(i+1)+sumene1)
4742      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4743         pom2=(sumene4*cost2tab(i+1)+sumene2)
4744      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4745         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4746         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4747      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4748      &  +x(40)*yy*zz
4749         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4750         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4751      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4752      &  +x(60)*yy*zz
4753         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4754      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4755      &        +(pom1+pom2)*pom_dx
4756 #ifdef DEBUG
4757         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4758 #endif
4759 C
4760         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4761         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4762      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4763      &  +x(40)*xx*zz
4764         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4765         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4766      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4767      &  +x(59)*zz**2 +x(60)*xx*zz
4768         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4769      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4770      &        +(pom1-pom2)*pom_dy
4771 #ifdef DEBUG
4772         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4773 #endif
4774 C
4775         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4776      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4777      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4778      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4779      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4780      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4781      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4782      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4783 #ifdef DEBUG
4784         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4785 #endif
4786 C
4787         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4788      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4789      &  +pom1*pom_dt1+pom2*pom_dt2
4790 #ifdef DEBUG
4791         write(2,*), "de_dt = ", de_dt,de_dt_num
4792 #endif
4793 c
4794 C
4795        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4796        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4797        cosfac2xx=cosfac2*xx
4798        sinfac2yy=sinfac2*yy
4799        do k = 1,3
4800          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4801      &      vbld_inv(i+1)
4802          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4803      &      vbld_inv(i)
4804          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4805          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4806 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4807 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4808 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4809 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4810          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4811          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4812          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4813          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4814          dZZ_Ci1(k)=0.0d0
4815          dZZ_Ci(k)=0.0d0
4816          do j=1,3
4817            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4818            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4819          enddo
4820
4821          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4822          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4823          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4824 c
4825          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4826          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4827        enddo
4828
4829        do k=1,3
4830          dXX_Ctab(k,i)=dXX_Ci(k)
4831          dXX_C1tab(k,i)=dXX_Ci1(k)
4832          dYY_Ctab(k,i)=dYY_Ci(k)
4833          dYY_C1tab(k,i)=dYY_Ci1(k)
4834          dZZ_Ctab(k,i)=dZZ_Ci(k)
4835          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4836          dXX_XYZtab(k,i)=dXX_XYZ(k)
4837          dYY_XYZtab(k,i)=dYY_XYZ(k)
4838          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4839        enddo
4840
4841        do k = 1,3
4842 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4843 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4844 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4845 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4846 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4847 c     &    dt_dci(k)
4848 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4849 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4850          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4851      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4852          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4853      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4854          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4855      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4856        enddo
4857 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4858 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4859
4860 C to check gradient call subroutine check_grad
4861
4862     1 continue
4863       enddo
4864       return
4865       end
4866 #endif
4867 c------------------------------------------------------------------------------
4868       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4869 C
4870 C This procedure calculates two-body contact function g(rij) and its derivative:
4871 C
4872 C           eps0ij                                     !       x < -1
4873 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4874 C            0                                         !       x > 1
4875 C
4876 C where x=(rij-r0ij)/delta
4877 C
4878 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4879 C
4880       implicit none
4881       double precision rij,r0ij,eps0ij,fcont,fprimcont
4882       double precision x,x2,x4,delta
4883 c     delta=0.02D0*r0ij
4884 c      delta=0.2D0*r0ij
4885       x=(rij-r0ij)/delta
4886       if (x.lt.-1.0D0) then
4887         fcont=eps0ij
4888         fprimcont=0.0D0
4889       else if (x.le.1.0D0) then
4890         x2=x*x
4891         x4=x2*x2
4892         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4893         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4894       else
4895         fcont=0.0D0
4896         fprimcont=0.0D0
4897       endif
4898       return
4899       end
4900 c------------------------------------------------------------------------------
4901       subroutine splinthet(theti,delta,ss,ssder)
4902       implicit real*8 (a-h,o-z)
4903       include 'DIMENSIONS'
4904       include 'DIMENSIONS.ZSCOPT'
4905       include 'COMMON.VAR'
4906       include 'COMMON.GEO'
4907       thetup=pi-delta
4908       thetlow=delta
4909       if (theti.gt.pipol) then
4910         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4911       else
4912         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4913         ssder=-ssder
4914       endif
4915       return
4916       end
4917 c------------------------------------------------------------------------------
4918       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4919       implicit none
4920       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4921       double precision ksi,ksi2,ksi3,a1,a2,a3
4922       a1=fprim0*delta/(f1-f0)
4923       a2=3.0d0-2.0d0*a1
4924       a3=a1-2.0d0
4925       ksi=(x-x0)/delta
4926       ksi2=ksi*ksi
4927       ksi3=ksi2*ksi
4928       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4929       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4930       return
4931       end
4932 c------------------------------------------------------------------------------
4933       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4934       implicit none
4935       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4936       double precision ksi,ksi2,ksi3,a1,a2,a3
4937       ksi=(x-x0)/delta
4938       ksi2=ksi*ksi
4939       ksi3=ksi2*ksi
4940       a1=fprim0x*delta
4941       a2=3*(f1x-f0x)-2*fprim0x*delta
4942       a3=fprim0x*delta-2*(f1x-f0x)
4943       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4944       return
4945       end
4946 C-----------------------------------------------------------------------------
4947 #ifdef CRYST_TOR
4948 C-----------------------------------------------------------------------------
4949       subroutine etor(etors,edihcnstr,fact)
4950       implicit real*8 (a-h,o-z)
4951       include 'DIMENSIONS'
4952       include 'DIMENSIONS.ZSCOPT'
4953       include 'COMMON.VAR'
4954       include 'COMMON.GEO'
4955       include 'COMMON.LOCAL'
4956       include 'COMMON.TORSION'
4957       include 'COMMON.INTERACT'
4958       include 'COMMON.DERIV'
4959       include 'COMMON.CHAIN'
4960       include 'COMMON.NAMES'
4961       include 'COMMON.IOUNITS'
4962       include 'COMMON.FFIELD'
4963       include 'COMMON.TORCNSTR'
4964       logical lprn
4965 C Set lprn=.true. for debugging
4966       lprn=.false.
4967 c      lprn=.true.
4968       etors=0.0D0
4969       do i=iphi_start,iphi_end
4970         itori=itortyp(itype(i-2))
4971         itori1=itortyp(itype(i-1))
4972         phii=phi(i)
4973         gloci=0.0D0
4974 C Proline-Proline pair is a special case...
4975         if (itori.eq.3 .and. itori1.eq.3) then
4976           if (phii.gt.-dwapi3) then
4977             cosphi=dcos(3*phii)
4978             fac=1.0D0/(1.0D0-cosphi)
4979             etorsi=v1(1,3,3)*fac
4980             etorsi=etorsi+etorsi
4981             etors=etors+etorsi-v1(1,3,3)
4982             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4983           endif
4984           do j=1,3
4985             v1ij=v1(j+1,itori,itori1)
4986             v2ij=v2(j+1,itori,itori1)
4987             cosphi=dcos(j*phii)
4988             sinphi=dsin(j*phii)
4989             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4990             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4991           enddo
4992         else
4993           do j=1,nterm_old
4994             v1ij=v1(j,itori,itori1)
4995             v2ij=v2(j,itori,itori1)
4996             cosphi=dcos(j*phii)
4997             sinphi=dsin(j*phii)
4998             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4999             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5000           enddo
5001         endif
5002         if (lprn)
5003      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5004      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5005      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5006         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5007 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5008       enddo
5009 ! 6/20/98 - dihedral angle constraints
5010       edihcnstr=0.0d0
5011       do i=1,ndih_constr
5012         itori=idih_constr(i)
5013         phii=phi(itori)
5014         difi=phii-phi0(i)
5015         if (difi.gt.drange(i)) then
5016           difi=difi-drange(i)
5017           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5018           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5019         else if (difi.lt.-drange(i)) then
5020           difi=difi+drange(i)
5021           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5022           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5023         endif
5024 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5025 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5026       enddo
5027 !      write (iout,*) 'edihcnstr',edihcnstr
5028       return
5029       end
5030 c------------------------------------------------------------------------------
5031 #else
5032       subroutine etor(etors,edihcnstr,fact)
5033       implicit real*8 (a-h,o-z)
5034       include 'DIMENSIONS'
5035       include 'DIMENSIONS.ZSCOPT'
5036       include 'COMMON.VAR'
5037       include 'COMMON.GEO'
5038       include 'COMMON.LOCAL'
5039       include 'COMMON.TORSION'
5040       include 'COMMON.INTERACT'
5041       include 'COMMON.DERIV'
5042       include 'COMMON.CHAIN'
5043       include 'COMMON.NAMES'
5044       include 'COMMON.IOUNITS'
5045       include 'COMMON.FFIELD'
5046       include 'COMMON.TORCNSTR'
5047       logical lprn
5048 C Set lprn=.true. for debugging
5049       lprn=.false.
5050 c      lprn=.true.
5051       etors=0.0D0
5052       do i=iphi_start,iphi_end
5053         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5054         itori=itortyp(itype(i-2))
5055         itori1=itortyp(itype(i-1))
5056         phii=phi(i)
5057         gloci=0.0D0
5058 C Regular cosine and sine terms
5059         do j=1,nterm(itori,itori1)
5060           v1ij=v1(j,itori,itori1)
5061           v2ij=v2(j,itori,itori1)
5062           cosphi=dcos(j*phii)
5063           sinphi=dsin(j*phii)
5064           etors=etors+v1ij*cosphi+v2ij*sinphi
5065           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5066         enddo
5067 C Lorentz terms
5068 C                         v1
5069 C  E = SUM ----------------------------------- - v1
5070 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5071 C
5072         cosphi=dcos(0.5d0*phii)
5073         sinphi=dsin(0.5d0*phii)
5074         do j=1,nlor(itori,itori1)
5075           vl1ij=vlor1(j,itori,itori1)
5076           vl2ij=vlor2(j,itori,itori1)
5077           vl3ij=vlor3(j,itori,itori1)
5078           pom=vl2ij*cosphi+vl3ij*sinphi
5079           pom1=1.0d0/(pom*pom+1.0d0)
5080           etors=etors+vl1ij*pom1
5081           pom=-pom*pom1*pom1
5082           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5083         enddo
5084 C Subtract the constant term
5085         etors=etors-v0(itori,itori1)
5086         if (lprn)
5087      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5088      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5089      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5090         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5091 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5092  1215   continue
5093       enddo
5094 ! 6/20/98 - dihedral angle constraints
5095       edihcnstr=0.0d0
5096       do i=1,ndih_constr
5097         itori=idih_constr(i)
5098         phii=phi(itori)
5099         difi=pinorm(phii-phi0(i))
5100         edihi=0.0d0
5101         if (difi.gt.drange(i)) then
5102           difi=difi-drange(i)
5103           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5104           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5105           edihi=0.25d0*ftors*difi**4
5106         else if (difi.lt.-drange(i)) then
5107           difi=difi+drange(i)
5108           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5109           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5110           edihi=0.25d0*ftors*difi**4
5111         else
5112           difi=0.0d0
5113         endif
5114 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5115 c     &    drange(i),edihi
5116 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5117 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5118       enddo
5119 !      write (iout,*) 'edihcnstr',edihcnstr
5120       return
5121       end
5122 c----------------------------------------------------------------------------
5123       subroutine etor_d(etors_d,fact2)
5124 C 6/23/01 Compute double torsional energy
5125       implicit real*8 (a-h,o-z)
5126       include 'DIMENSIONS'
5127       include 'DIMENSIONS.ZSCOPT'
5128       include 'COMMON.VAR'
5129       include 'COMMON.GEO'
5130       include 'COMMON.LOCAL'
5131       include 'COMMON.TORSION'
5132       include 'COMMON.INTERACT'
5133       include 'COMMON.DERIV'
5134       include 'COMMON.CHAIN'
5135       include 'COMMON.NAMES'
5136       include 'COMMON.IOUNITS'
5137       include 'COMMON.FFIELD'
5138       include 'COMMON.TORCNSTR'
5139       logical lprn
5140 C Set lprn=.true. for debugging
5141       lprn=.false.
5142 c     lprn=.true.
5143       etors_d=0.0D0
5144       do i=iphi_start,iphi_end-1
5145         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5146      &     goto 1215
5147         itori=itortyp(itype(i-2))
5148         itori1=itortyp(itype(i-1))
5149         itori2=itortyp(itype(i))
5150         phii=phi(i)
5151         phii1=phi(i+1)
5152         gloci1=0.0D0
5153         gloci2=0.0D0
5154 C Regular cosine and sine terms
5155         do j=1,ntermd_1(itori,itori1,itori2)
5156           v1cij=v1c(1,j,itori,itori1,itori2)
5157           v1sij=v1s(1,j,itori,itori1,itori2)
5158           v2cij=v1c(2,j,itori,itori1,itori2)
5159           v2sij=v1s(2,j,itori,itori1,itori2)
5160           cosphi1=dcos(j*phii)
5161           sinphi1=dsin(j*phii)
5162           cosphi2=dcos(j*phii1)
5163           sinphi2=dsin(j*phii1)
5164           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5165      &     v2cij*cosphi2+v2sij*sinphi2
5166           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5167           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5168         enddo
5169         do k=2,ntermd_2(itori,itori1,itori2)
5170           do l=1,k-1
5171             v1cdij = v2c(k,l,itori,itori1,itori2)
5172             v2cdij = v2c(l,k,itori,itori1,itori2)
5173             v1sdij = v2s(k,l,itori,itori1,itori2)
5174             v2sdij = v2s(l,k,itori,itori1,itori2)
5175             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5176             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5177             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5178             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5179             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5180      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5181             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5182      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5183             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5184      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5185           enddo
5186         enddo
5187         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5188         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5189  1215   continue
5190       enddo
5191       return
5192       end
5193 #endif
5194 c------------------------------------------------------------------------------
5195       subroutine eback_sc_corr(esccor)
5196 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5197 c        conformational states; temporarily implemented as differences
5198 c        between UNRES torsional potentials (dependent on three types of
5199 c        residues) and the torsional potentials dependent on all 20 types
5200 c        of residues computed from AM1 energy surfaces of terminally-blocked
5201 c        amino-acid residues.
5202       implicit real*8 (a-h,o-z)
5203       include 'DIMENSIONS'
5204       include 'DIMENSIONS.ZSCOPT'
5205       include 'COMMON.VAR'
5206       include 'COMMON.GEO'
5207       include 'COMMON.LOCAL'
5208       include 'COMMON.TORSION'
5209       include 'COMMON.SCCOR'
5210       include 'COMMON.INTERACT'
5211       include 'COMMON.DERIV'
5212       include 'COMMON.CHAIN'
5213       include 'COMMON.NAMES'
5214       include 'COMMON.IOUNITS'
5215       include 'COMMON.FFIELD'
5216       include 'COMMON.CONTROL'
5217       logical lprn
5218 C Set lprn=.true. for debugging
5219       lprn=.false.
5220 c      lprn=.true.
5221 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5222       esccor=0.0D0
5223       do i=itau_start,itau_end
5224         esccor_ii=0.0D0
5225         isccori=isccortyp(itype(i-2))
5226         isccori1=isccortyp(itype(i-1))
5227         phii=phi(i)
5228 cccc  Added 9 May 2012
5229 cc Tauangle is torsional engle depending on the value of first digit
5230 c(see comment below)
5231 cc Omicron is flat angle depending on the value of first digit
5232 c(see comment below)
5233
5234
5235         do intertyp=1,3 !intertyp
5236 cc Added 09 May 2012 (Adasko)
5237 cc  Intertyp means interaction type of backbone mainchain correlation:
5238 c   1 = SC...Ca...Ca...Ca
5239 c   2 = Ca...Ca...Ca...SC
5240 c   3 = SC...Ca...Ca...SCi
5241         gloci=0.0D0
5242         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5243      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5244      &      (itype(i-1).eq.21)))
5245      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5246      &     .or.(itype(i-2).eq.21)))
5247      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5248      &      (itype(i-1).eq.21)))) cycle
5249         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5250         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5251      & cycle
5252         do j=1,nterm_sccor(isccori,isccori1)
5253           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5254           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5255           cosphi=dcos(j*tauangle(intertyp,i))
5256           sinphi=dsin(j*tauangle(intertyp,i))
5257           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5258 #define DEBUG
5259 #ifdef DEBUG
5260           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5261 #endif
5262 #undef DEBUG
5263           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5264         enddo
5265         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5266 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5267 c     &gloc_sc(intertyp,i-3,icg)
5268         if (lprn)
5269      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5270      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5271      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5272      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5273         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5274        enddo !intertyp
5275 #ifdef DEBUG
5276        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5277 #endif
5278       enddo
5279 c        do i=1,nres
5280 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5281 c        enddo
5282       return
5283       end
5284 c------------------------------------------------------------------------------
5285       subroutine multibody(ecorr)
5286 C This subroutine calculates multi-body contributions to energy following
5287 C the idea of Skolnick et al. If side chains I and J make a contact and
5288 C at the same time side chains I+1 and J+1 make a contact, an extra
5289 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5290       implicit real*8 (a-h,o-z)
5291       include 'DIMENSIONS'
5292       include 'COMMON.IOUNITS'
5293       include 'COMMON.DERIV'
5294       include 'COMMON.INTERACT'
5295       include 'COMMON.CONTACTS'
5296       double precision gx(3),gx1(3)
5297       logical lprn
5298
5299 C Set lprn=.true. for debugging
5300       lprn=.false.
5301
5302       if (lprn) then
5303         write (iout,'(a)') 'Contact function values:'
5304         do i=nnt,nct-2
5305           write (iout,'(i2,20(1x,i2,f10.5))')
5306      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5307         enddo
5308       endif
5309       ecorr=0.0D0
5310       do i=nnt,nct
5311         do j=1,3
5312           gradcorr(j,i)=0.0D0
5313           gradxorr(j,i)=0.0D0
5314         enddo
5315       enddo
5316       do i=nnt,nct-2
5317
5318         DO ISHIFT = 3,4
5319
5320         i1=i+ishift
5321         num_conti=num_cont(i)
5322         num_conti1=num_cont(i1)
5323         do jj=1,num_conti
5324           j=jcont(jj,i)
5325           do kk=1,num_conti1
5326             j1=jcont(kk,i1)
5327             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5328 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5329 cd   &                   ' ishift=',ishift
5330 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5331 C The system gains extra energy.
5332               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5333             endif   ! j1==j+-ishift
5334           enddo     ! kk
5335         enddo       ! jj
5336
5337         ENDDO ! ISHIFT
5338
5339       enddo         ! i
5340       return
5341       end
5342 c------------------------------------------------------------------------------
5343       double precision function esccorr(i,j,k,l,jj,kk)
5344       implicit real*8 (a-h,o-z)
5345       include 'DIMENSIONS'
5346       include 'COMMON.IOUNITS'
5347       include 'COMMON.DERIV'
5348       include 'COMMON.INTERACT'
5349       include 'COMMON.CONTACTS'
5350       double precision gx(3),gx1(3)
5351       logical lprn
5352       lprn=.false.
5353       eij=facont(jj,i)
5354       ekl=facont(kk,k)
5355 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5356 C Calculate the multi-body contribution to energy.
5357 C Calculate multi-body contributions to the gradient.
5358 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5359 cd   & k,l,(gacont(m,kk,k),m=1,3)
5360       do m=1,3
5361         gx(m) =ekl*gacont(m,jj,i)
5362         gx1(m)=eij*gacont(m,kk,k)
5363         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5364         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5365         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5366         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5367       enddo
5368       do m=i,j-1
5369         do ll=1,3
5370           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5371         enddo
5372       enddo
5373       do m=k,l-1
5374         do ll=1,3
5375           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5376         enddo
5377       enddo
5378       esccorr=-eij*ekl
5379       return
5380       end
5381 c------------------------------------------------------------------------------
5382 #ifdef MPL
5383       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5384       implicit real*8 (a-h,o-z)
5385       include 'DIMENSIONS'
5386       integer dimen1,dimen2,atom,indx
5387       double precision buffer(dimen1,dimen2)
5388       double precision zapas
5389       common /contacts_hb/ zapas(3,20,maxres,7),
5390      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5391      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5392       num_kont=num_cont_hb(atom)
5393       do i=1,num_kont
5394         do k=1,7
5395           do j=1,3
5396             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5397           enddo ! j
5398         enddo ! k
5399         buffer(i,indx+22)=facont_hb(i,atom)
5400         buffer(i,indx+23)=ees0p(i,atom)
5401         buffer(i,indx+24)=ees0m(i,atom)
5402         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5403       enddo ! i
5404       buffer(1,indx+26)=dfloat(num_kont)
5405       return
5406       end
5407 c------------------------------------------------------------------------------
5408       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5409       implicit real*8 (a-h,o-z)
5410       include 'DIMENSIONS'
5411       integer dimen1,dimen2,atom,indx
5412       double precision buffer(dimen1,dimen2)
5413       double precision zapas
5414       common /contacts_hb/ zapas(3,20,maxres,7),
5415      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5416      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5417       num_kont=buffer(1,indx+26)
5418       num_kont_old=num_cont_hb(atom)
5419       num_cont_hb(atom)=num_kont+num_kont_old
5420       do i=1,num_kont
5421         ii=i+num_kont_old
5422         do k=1,7
5423           do j=1,3
5424             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5425           enddo ! j
5426         enddo ! k
5427         facont_hb(ii,atom)=buffer(i,indx+22)
5428         ees0p(ii,atom)=buffer(i,indx+23)
5429         ees0m(ii,atom)=buffer(i,indx+24)
5430         jcont_hb(ii,atom)=buffer(i,indx+25)
5431       enddo ! i
5432       return
5433       end
5434 c------------------------------------------------------------------------------
5435 #endif
5436       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5437 C This subroutine calculates multi-body contributions to hydrogen-bonding
5438       implicit real*8 (a-h,o-z)
5439       include 'DIMENSIONS'
5440       include 'DIMENSIONS.ZSCOPT'
5441       include 'COMMON.IOUNITS'
5442 #ifdef MPL
5443       include 'COMMON.INFO'
5444 #endif
5445       include 'COMMON.FFIELD'
5446       include 'COMMON.DERIV'
5447       include 'COMMON.INTERACT'
5448       include 'COMMON.CONTACTS'
5449 #ifdef MPL
5450       parameter (max_cont=maxconts)
5451       parameter (max_dim=2*(8*3+2))
5452       parameter (msglen1=max_cont*max_dim*4)
5453       parameter (msglen2=2*msglen1)
5454       integer source,CorrelType,CorrelID,Error
5455       double precision buffer(max_cont,max_dim)
5456 #endif
5457       double precision gx(3),gx1(3)
5458       logical lprn,ldone
5459
5460 C Set lprn=.true. for debugging
5461       lprn=.false.
5462 #ifdef MPL
5463       n_corr=0
5464       n_corr1=0
5465       if (fgProcs.le.1) goto 30
5466       if (lprn) then
5467         write (iout,'(a)') 'Contact function values:'
5468         do i=nnt,nct-2
5469           write (iout,'(2i3,50(1x,i2,f5.2))')
5470      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5471      &    j=1,num_cont_hb(i))
5472         enddo
5473       endif
5474 C Caution! Following code assumes that electrostatic interactions concerning
5475 C a given atom are split among at most two processors!
5476       CorrelType=477
5477       CorrelID=MyID+1
5478       ldone=.false.
5479       do i=1,max_cont
5480         do j=1,max_dim
5481           buffer(i,j)=0.0D0
5482         enddo
5483       enddo
5484       mm=mod(MyRank,2)
5485 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5486       if (mm) 20,20,10
5487    10 continue
5488 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5489       if (MyRank.gt.0) then
5490 C Send correlation contributions to the preceding processor
5491         msglen=msglen1
5492         nn=num_cont_hb(iatel_s)
5493         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5494 cd      write (iout,*) 'The BUFFER array:'
5495 cd      do i=1,nn
5496 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5497 cd      enddo
5498         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5499           msglen=msglen2
5500             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5501 C Clear the contacts of the atom passed to the neighboring processor
5502         nn=num_cont_hb(iatel_s+1)
5503 cd      do i=1,nn
5504 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5505 cd      enddo
5506             num_cont_hb(iatel_s)=0
5507         endif
5508 cd      write (iout,*) 'Processor ',MyID,MyRank,
5509 cd   & ' is sending correlation contribution to processor',MyID-1,
5510 cd   & ' msglen=',msglen
5511 cd      write (*,*) 'Processor ',MyID,MyRank,
5512 cd   & ' is sending correlation contribution to processor',MyID-1,
5513 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5514         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5515 cd      write (iout,*) 'Processor ',MyID,
5516 cd   & ' has sent correlation contribution to processor',MyID-1,
5517 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5518 cd      write (*,*) 'Processor ',MyID,
5519 cd   & ' has sent correlation contribution to processor',MyID-1,
5520 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5521         msglen=msglen1
5522       endif ! (MyRank.gt.0)
5523       if (ldone) goto 30
5524       ldone=.true.
5525    20 continue
5526 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5527       if (MyRank.lt.fgProcs-1) then
5528 C Receive correlation contributions from the next processor
5529         msglen=msglen1
5530         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5531 cd      write (iout,*) 'Processor',MyID,
5532 cd   & ' is receiving correlation contribution from processor',MyID+1,
5533 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5534 cd      write (*,*) 'Processor',MyID,
5535 cd   & ' is receiving correlation contribution from processor',MyID+1,
5536 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5537         nbytes=-1
5538         do while (nbytes.le.0)
5539           call mp_probe(MyID+1,CorrelType,nbytes)
5540         enddo
5541 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5542         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5543 cd      write (iout,*) 'Processor',MyID,
5544 cd   & ' has received correlation contribution from processor',MyID+1,
5545 cd   & ' msglen=',msglen,' nbytes=',nbytes
5546 cd      write (iout,*) 'The received BUFFER array:'
5547 cd      do i=1,max_cont
5548 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5549 cd      enddo
5550         if (msglen.eq.msglen1) then
5551           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5552         else if (msglen.eq.msglen2)  then
5553           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5554           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5555         else
5556           write (iout,*)
5557      & 'ERROR!!!! message length changed while processing correlations.'
5558           write (*,*)
5559      & 'ERROR!!!! message length changed while processing correlations.'
5560           call mp_stopall(Error)
5561         endif ! msglen.eq.msglen1
5562       endif ! MyRank.lt.fgProcs-1
5563       if (ldone) goto 30
5564       ldone=.true.
5565       goto 10
5566    30 continue
5567 #endif
5568       if (lprn) then
5569         write (iout,'(a)') 'Contact function values:'
5570         do i=nnt,nct-2
5571           write (iout,'(2i3,50(1x,i2,f5.2))')
5572      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5573      &    j=1,num_cont_hb(i))
5574         enddo
5575       endif
5576       ecorr=0.0D0
5577 C Remove the loop below after debugging !!!
5578       do i=nnt,nct
5579         do j=1,3
5580           gradcorr(j,i)=0.0D0
5581           gradxorr(j,i)=0.0D0
5582         enddo
5583       enddo
5584 C Calculate the local-electrostatic correlation terms
5585       do i=iatel_s,iatel_e+1
5586         i1=i+1
5587         num_conti=num_cont_hb(i)
5588         num_conti1=num_cont_hb(i+1)
5589         do jj=1,num_conti
5590           j=jcont_hb(jj,i)
5591           do kk=1,num_conti1
5592             j1=jcont_hb(kk,i1)
5593 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5594 c     &         ' jj=',jj,' kk=',kk
5595             if (j1.eq.j+1 .or. j1.eq.j-1) then
5596 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5597 C The system gains extra energy.
5598               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5599               n_corr=n_corr+1
5600             else if (j1.eq.j) then
5601 C Contacts I-J and I-(J+1) occur simultaneously.
5602 C The system loses extra energy.
5603 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5604             endif
5605           enddo ! kk
5606           do kk=1,num_conti
5607             j1=jcont_hb(kk,i)
5608 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5609 c    &         ' jj=',jj,' kk=',kk
5610             if (j1.eq.j+1) then
5611 C Contacts I-J and (I+1)-J occur simultaneously.
5612 C The system loses extra energy.
5613 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5614             endif ! j1==j+1
5615           enddo ! kk
5616         enddo ! jj
5617       enddo ! i
5618       return
5619       end
5620 c------------------------------------------------------------------------------
5621       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5622      &  n_corr1)
5623 C This subroutine calculates multi-body contributions to hydrogen-bonding
5624       implicit real*8 (a-h,o-z)
5625       include 'DIMENSIONS'
5626       include 'DIMENSIONS.ZSCOPT'
5627       include 'COMMON.IOUNITS'
5628 #ifdef MPL
5629       include 'COMMON.INFO'
5630 #endif
5631       include 'COMMON.FFIELD'
5632       include 'COMMON.DERIV'
5633       include 'COMMON.INTERACT'
5634       include 'COMMON.CONTACTS'
5635 #ifdef MPL
5636       parameter (max_cont=maxconts)
5637       parameter (max_dim=2*(8*3+2))
5638       parameter (msglen1=max_cont*max_dim*4)
5639       parameter (msglen2=2*msglen1)
5640       integer source,CorrelType,CorrelID,Error
5641       double precision buffer(max_cont,max_dim)
5642 #endif
5643       double precision gx(3),gx1(3)
5644       logical lprn,ldone
5645
5646 C Set lprn=.true. for debugging
5647       lprn=.false.
5648       eturn6=0.0d0
5649 #ifdef MPL
5650       n_corr=0
5651       n_corr1=0
5652       if (fgProcs.le.1) goto 30
5653       if (lprn) then
5654         write (iout,'(a)') 'Contact function values:'
5655         do i=nnt,nct-2
5656           write (iout,'(2i3,50(1x,i2,f5.2))')
5657      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5658      &    j=1,num_cont_hb(i))
5659         enddo
5660       endif
5661 C Caution! Following code assumes that electrostatic interactions concerning
5662 C a given atom are split among at most two processors!
5663       CorrelType=477
5664       CorrelID=MyID+1
5665       ldone=.false.
5666       do i=1,max_cont
5667         do j=1,max_dim
5668           buffer(i,j)=0.0D0
5669         enddo
5670       enddo
5671       mm=mod(MyRank,2)
5672 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5673       if (mm) 20,20,10
5674    10 continue
5675 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5676       if (MyRank.gt.0) then
5677 C Send correlation contributions to the preceding processor
5678         msglen=msglen1
5679         nn=num_cont_hb(iatel_s)
5680         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5681 cd      write (iout,*) 'The BUFFER array:'
5682 cd      do i=1,nn
5683 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5684 cd      enddo
5685         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5686           msglen=msglen2
5687             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5688 C Clear the contacts of the atom passed to the neighboring processor
5689         nn=num_cont_hb(iatel_s+1)
5690 cd      do i=1,nn
5691 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5692 cd      enddo
5693             num_cont_hb(iatel_s)=0
5694         endif
5695 cd      write (iout,*) 'Processor ',MyID,MyRank,
5696 cd   & ' is sending correlation contribution to processor',MyID-1,
5697 cd   & ' msglen=',msglen
5698 cd      write (*,*) 'Processor ',MyID,MyRank,
5699 cd   & ' is sending correlation contribution to processor',MyID-1,
5700 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5701         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5702 cd      write (iout,*) 'Processor ',MyID,
5703 cd   & ' has sent correlation contribution to processor',MyID-1,
5704 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5705 cd      write (*,*) 'Processor ',MyID,
5706 cd   & ' has sent correlation contribution to processor',MyID-1,
5707 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5708         msglen=msglen1
5709       endif ! (MyRank.gt.0)
5710       if (ldone) goto 30
5711       ldone=.true.
5712    20 continue
5713 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5714       if (MyRank.lt.fgProcs-1) then
5715 C Receive correlation contributions from the next processor
5716         msglen=msglen1
5717         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5718 cd      write (iout,*) 'Processor',MyID,
5719 cd   & ' is receiving correlation contribution from processor',MyID+1,
5720 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5721 cd      write (*,*) 'Processor',MyID,
5722 cd   & ' is receiving correlation contribution from processor',MyID+1,
5723 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5724         nbytes=-1
5725         do while (nbytes.le.0)
5726           call mp_probe(MyID+1,CorrelType,nbytes)
5727         enddo
5728 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5729         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5730 cd      write (iout,*) 'Processor',MyID,
5731 cd   & ' has received correlation contribution from processor',MyID+1,
5732 cd   & ' msglen=',msglen,' nbytes=',nbytes
5733 cd      write (iout,*) 'The received BUFFER array:'
5734 cd      do i=1,max_cont
5735 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5736 cd      enddo
5737         if (msglen.eq.msglen1) then
5738           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5739         else if (msglen.eq.msglen2)  then
5740           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5741           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5742         else
5743           write (iout,*)
5744      & 'ERROR!!!! message length changed while processing correlations.'
5745           write (*,*)
5746      & 'ERROR!!!! message length changed while processing correlations.'
5747           call mp_stopall(Error)
5748         endif ! msglen.eq.msglen1
5749       endif ! MyRank.lt.fgProcs-1
5750       if (ldone) goto 30
5751       ldone=.true.
5752       goto 10
5753    30 continue
5754 #endif
5755       if (lprn) then
5756         write (iout,'(a)') 'Contact function values:'
5757         do i=nnt,nct-2
5758           write (iout,'(2i3,50(1x,i2,f5.2))')
5759      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5760      &    j=1,num_cont_hb(i))
5761         enddo
5762       endif
5763       ecorr=0.0D0
5764       ecorr5=0.0d0
5765       ecorr6=0.0d0
5766 C Remove the loop below after debugging !!!
5767       do i=nnt,nct
5768         do j=1,3
5769           gradcorr(j,i)=0.0D0
5770           gradxorr(j,i)=0.0D0
5771         enddo
5772       enddo
5773 C Calculate the dipole-dipole interaction energies
5774       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5775       do i=iatel_s,iatel_e+1
5776         num_conti=num_cont_hb(i)
5777         do jj=1,num_conti
5778           j=jcont_hb(jj,i)
5779           call dipole(i,j,jj)
5780         enddo
5781       enddo
5782       endif
5783 C Calculate the local-electrostatic correlation terms
5784       do i=iatel_s,iatel_e+1
5785         i1=i+1
5786         num_conti=num_cont_hb(i)
5787         num_conti1=num_cont_hb(i+1)
5788         do jj=1,num_conti
5789           j=jcont_hb(jj,i)
5790           do kk=1,num_conti1
5791             j1=jcont_hb(kk,i1)
5792 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5793 c     &         ' jj=',jj,' kk=',kk
5794             if (j1.eq.j+1 .or. j1.eq.j-1) then
5795 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5796 C The system gains extra energy.
5797               n_corr=n_corr+1
5798               sqd1=dsqrt(d_cont(jj,i))
5799               sqd2=dsqrt(d_cont(kk,i1))
5800               sred_geom = sqd1*sqd2
5801               IF (sred_geom.lt.cutoff_corr) THEN
5802                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5803      &            ekont,fprimcont)
5804 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5805 c     &         ' jj=',jj,' kk=',kk
5806                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5807                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5808                 do l=1,3
5809                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5810                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5811                 enddo
5812                 n_corr1=n_corr1+1
5813 cd               write (iout,*) 'sred_geom=',sred_geom,
5814 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5815                 call calc_eello(i,j,i+1,j1,jj,kk)
5816                 if (wcorr4.gt.0.0d0)
5817      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5818                 if (wcorr5.gt.0.0d0)
5819      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5820 c                print *,"wcorr5",ecorr5
5821 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5822 cd                write(2,*)'ijkl',i,j,i+1,j1
5823                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5824      &               .or. wturn6.eq.0.0d0))then
5825 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5826                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5827 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5828 cd     &            'ecorr6=',ecorr6
5829 cd                write (iout,'(4e15.5)') sred_geom,
5830 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5831 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5832 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5833                 else if (wturn6.gt.0.0d0
5834      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5835 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5836                   eturn6=eturn6+eello_turn6(i,jj,kk)
5837 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5838                 endif
5839               ENDIF
5840 1111          continue
5841             else if (j1.eq.j) then
5842 C Contacts I-J and I-(J+1) occur simultaneously.
5843 C The system loses extra energy.
5844 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5845             endif
5846           enddo ! kk
5847           do kk=1,num_conti
5848             j1=jcont_hb(kk,i)
5849 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5850 c    &         ' jj=',jj,' kk=',kk
5851             if (j1.eq.j+1) then
5852 C Contacts I-J and (I+1)-J occur simultaneously.
5853 C The system loses extra energy.
5854 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5855             endif ! j1==j+1
5856           enddo ! kk
5857         enddo ! jj
5858       enddo ! i
5859       return
5860       end
5861 c------------------------------------------------------------------------------
5862       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5863       implicit real*8 (a-h,o-z)
5864       include 'DIMENSIONS'
5865       include 'COMMON.IOUNITS'
5866       include 'COMMON.DERIV'
5867       include 'COMMON.INTERACT'
5868       include 'COMMON.CONTACTS'
5869       double precision gx(3),gx1(3)
5870       logical lprn
5871       lprn=.false.
5872       eij=facont_hb(jj,i)
5873       ekl=facont_hb(kk,k)
5874       ees0pij=ees0p(jj,i)
5875       ees0pkl=ees0p(kk,k)
5876       ees0mij=ees0m(jj,i)
5877       ees0mkl=ees0m(kk,k)
5878       ekont=eij*ekl
5879       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5880 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5881 C Following 4 lines for diagnostics.
5882 cd    ees0pkl=0.0D0
5883 cd    ees0pij=1.0D0
5884 cd    ees0mkl=0.0D0
5885 cd    ees0mij=1.0D0
5886 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5887 c    &   ' and',k,l
5888 c     write (iout,*)'Contacts have occurred for peptide groups',
5889 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5890 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5891 C Calculate the multi-body contribution to energy.
5892       ecorr=ecorr+ekont*ees
5893       if (calc_grad) then
5894 C Calculate multi-body contributions to the gradient.
5895       do ll=1,3
5896         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5897         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5898      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5899      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5900         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5901      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5902      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5903         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5904         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5905      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5906      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5907         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5908      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5909      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5910       enddo
5911       do m=i+1,j-1
5912         do ll=1,3
5913           gradcorr(ll,m)=gradcorr(ll,m)+
5914      &     ees*ekl*gacont_hbr(ll,jj,i)-
5915      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5916      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5917         enddo
5918       enddo
5919       do m=k+1,l-1
5920         do ll=1,3
5921           gradcorr(ll,m)=gradcorr(ll,m)+
5922      &     ees*eij*gacont_hbr(ll,kk,k)-
5923      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5924      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5925         enddo
5926       enddo
5927       endif
5928       ehbcorr=ekont*ees
5929       return
5930       end
5931 C---------------------------------------------------------------------------
5932       subroutine dipole(i,j,jj)
5933       implicit real*8 (a-h,o-z)
5934       include 'DIMENSIONS'
5935       include 'DIMENSIONS.ZSCOPT'
5936       include 'COMMON.IOUNITS'
5937       include 'COMMON.CHAIN'
5938       include 'COMMON.FFIELD'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.INTERACT'
5941       include 'COMMON.CONTACTS'
5942       include 'COMMON.TORSION'
5943       include 'COMMON.VAR'
5944       include 'COMMON.GEO'
5945       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5946      &  auxmat(2,2)
5947       iti1 = itortyp(itype(i+1))
5948       if (j.lt.nres-1) then
5949         itj1 = itortyp(itype(j+1))
5950       else
5951         itj1=ntortyp+1
5952       endif
5953       do iii=1,2
5954         dipi(iii,1)=Ub2(iii,i)
5955         dipderi(iii)=Ub2der(iii,i)
5956         dipi(iii,2)=b1(iii,iti1)
5957         dipj(iii,1)=Ub2(iii,j)
5958         dipderj(iii)=Ub2der(iii,j)
5959         dipj(iii,2)=b1(iii,itj1)
5960       enddo
5961       kkk=0
5962       do iii=1,2
5963         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5964         do jjj=1,2
5965           kkk=kkk+1
5966           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5967         enddo
5968       enddo
5969       if (.not.calc_grad) return
5970       do kkk=1,5
5971         do lll=1,3
5972           mmm=0
5973           do iii=1,2
5974             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5975      &        auxvec(1))
5976             do jjj=1,2
5977               mmm=mmm+1
5978               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5979             enddo
5980           enddo
5981         enddo
5982       enddo
5983       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5984       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5985       do iii=1,2
5986         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5987       enddo
5988       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5989       do iii=1,2
5990         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5991       enddo
5992       return
5993       end
5994 C---------------------------------------------------------------------------
5995       subroutine calc_eello(i,j,k,l,jj,kk)
5996 C
5997 C This subroutine computes matrices and vectors needed to calculate
5998 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5999 C
6000       implicit real*8 (a-h,o-z)
6001       include 'DIMENSIONS'
6002       include 'DIMENSIONS.ZSCOPT'
6003       include 'COMMON.IOUNITS'
6004       include 'COMMON.CHAIN'
6005       include 'COMMON.DERIV'
6006       include 'COMMON.INTERACT'
6007       include 'COMMON.CONTACTS'
6008       include 'COMMON.TORSION'
6009       include 'COMMON.VAR'
6010       include 'COMMON.GEO'
6011       include 'COMMON.FFIELD'
6012       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6013      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6014       logical lprn
6015       common /kutas/ lprn
6016 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6017 cd     & ' jj=',jj,' kk=',kk
6018 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6019       do iii=1,2
6020         do jjj=1,2
6021           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6022           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6023         enddo
6024       enddo
6025       call transpose2(aa1(1,1),aa1t(1,1))
6026       call transpose2(aa2(1,1),aa2t(1,1))
6027       do kkk=1,5
6028         do lll=1,3
6029           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6030      &      aa1tder(1,1,lll,kkk))
6031           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6032      &      aa2tder(1,1,lll,kkk))
6033         enddo
6034       enddo
6035       if (l.eq.j+1) then
6036 C parallel orientation of the two CA-CA-CA frames.
6037         if (i.gt.1) then
6038           iti=itortyp(itype(i))
6039         else
6040           iti=ntortyp+1
6041         endif
6042         itk1=itortyp(itype(k+1))
6043         itj=itortyp(itype(j))
6044         if (l.lt.nres-1) then
6045           itl1=itortyp(itype(l+1))
6046         else
6047           itl1=ntortyp+1
6048         endif
6049 C A1 kernel(j+1) A2T
6050 cd        do iii=1,2
6051 cd          write (iout,'(3f10.5,5x,3f10.5)')
6052 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6053 cd        enddo
6054         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6055      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6056      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6057 C Following matrices are needed only for 6-th order cumulants
6058         IF (wcorr6.gt.0.0d0) THEN
6059         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6060      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6061      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6063      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6064      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6065      &   ADtEAderx(1,1,1,1,1,1))
6066         lprn=.false.
6067         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6068      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6069      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6070      &   ADtEA1derx(1,1,1,1,1,1))
6071         ENDIF
6072 C End 6-th order cumulants
6073 cd        lprn=.false.
6074 cd        if (lprn) then
6075 cd        write (2,*) 'In calc_eello6'
6076 cd        do iii=1,2
6077 cd          write (2,*) 'iii=',iii
6078 cd          do kkk=1,5
6079 cd            write (2,*) 'kkk=',kkk
6080 cd            do jjj=1,2
6081 cd              write (2,'(3(2f10.5),5x)')
6082 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6083 cd            enddo
6084 cd          enddo
6085 cd        enddo
6086 cd        endif
6087         call transpose2(EUgder(1,1,k),auxmat(1,1))
6088         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6089         call transpose2(EUg(1,1,k),auxmat(1,1))
6090         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6091         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6092         do iii=1,2
6093           do kkk=1,5
6094             do lll=1,3
6095               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6096      &          EAEAderx(1,1,lll,kkk,iii,1))
6097             enddo
6098           enddo
6099         enddo
6100 C A1T kernel(i+1) A2
6101         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6102      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6103      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6104 C Following matrices are needed only for 6-th order cumulants
6105         IF (wcorr6.gt.0.0d0) THEN
6106         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6107      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6108      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6109         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6110      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6111      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6112      &   ADtEAderx(1,1,1,1,1,2))
6113         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6114      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6115      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6116      &   ADtEA1derx(1,1,1,1,1,2))
6117         ENDIF
6118 C End 6-th order cumulants
6119         call transpose2(EUgder(1,1,l),auxmat(1,1))
6120         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6121         call transpose2(EUg(1,1,l),auxmat(1,1))
6122         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6123         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6124         do iii=1,2
6125           do kkk=1,5
6126             do lll=1,3
6127               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6128      &          EAEAderx(1,1,lll,kkk,iii,2))
6129             enddo
6130           enddo
6131         enddo
6132 C AEAb1 and AEAb2
6133 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6134 C They are needed only when the fifth- or the sixth-order cumulants are
6135 C indluded.
6136         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6137         call transpose2(AEA(1,1,1),auxmat(1,1))
6138         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6139         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6140         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6141         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6142         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6144         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6145         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6146         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6147         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6148         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6149         call transpose2(AEA(1,1,2),auxmat(1,1))
6150         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6151         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6152         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6153         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6154         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6155         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6156         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6157         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6158         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6159         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6160         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6161 C Calculate the Cartesian derivatives of the vectors.
6162         do iii=1,2
6163           do kkk=1,5
6164             do lll=1,3
6165               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6166               call matvec2(auxmat(1,1),b1(1,iti),
6167      &          AEAb1derx(1,lll,kkk,iii,1,1))
6168               call matvec2(auxmat(1,1),Ub2(1,i),
6169      &          AEAb2derx(1,lll,kkk,iii,1,1))
6170               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6171      &          AEAb1derx(1,lll,kkk,iii,2,1))
6172               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6173      &          AEAb2derx(1,lll,kkk,iii,2,1))
6174               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6175               call matvec2(auxmat(1,1),b1(1,itj),
6176      &          AEAb1derx(1,lll,kkk,iii,1,2))
6177               call matvec2(auxmat(1,1),Ub2(1,j),
6178      &          AEAb2derx(1,lll,kkk,iii,1,2))
6179               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6180      &          AEAb1derx(1,lll,kkk,iii,2,2))
6181               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6182      &          AEAb2derx(1,lll,kkk,iii,2,2))
6183             enddo
6184           enddo
6185         enddo
6186         ENDIF
6187 C End vectors
6188       else
6189 C Antiparallel orientation of the two CA-CA-CA frames.
6190         if (i.gt.1) then
6191           iti=itortyp(itype(i))
6192         else
6193           iti=ntortyp+1
6194         endif
6195         itk1=itortyp(itype(k+1))
6196         itl=itortyp(itype(l))
6197         itj=itortyp(itype(j))
6198         if (j.lt.nres-1) then
6199           itj1=itortyp(itype(j+1))
6200         else
6201           itj1=ntortyp+1
6202         endif
6203 C A2 kernel(j-1)T A1T
6204         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6205      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6206      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6207 C Following matrices are needed only for 6-th order cumulants
6208         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6209      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6210         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6211      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6212      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6213         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6214      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6215      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6216      &   ADtEAderx(1,1,1,1,1,1))
6217         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6218      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6219      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6220      &   ADtEA1derx(1,1,1,1,1,1))
6221         ENDIF
6222 C End 6-th order cumulants
6223         call transpose2(EUgder(1,1,k),auxmat(1,1))
6224         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6225         call transpose2(EUg(1,1,k),auxmat(1,1))
6226         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6227         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6228         do iii=1,2
6229           do kkk=1,5
6230             do lll=1,3
6231               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6232      &          EAEAderx(1,1,lll,kkk,iii,1))
6233             enddo
6234           enddo
6235         enddo
6236 C A2T kernel(i+1)T A1
6237         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6238      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6239      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6240 C Following matrices are needed only for 6-th order cumulants
6241         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6242      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6243         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6244      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6245      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6246         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6247      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6248      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6249      &   ADtEAderx(1,1,1,1,1,2))
6250         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6251      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6252      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6253      &   ADtEA1derx(1,1,1,1,1,2))
6254         ENDIF
6255 C End 6-th order cumulants
6256         call transpose2(EUgder(1,1,j),auxmat(1,1))
6257         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6258         call transpose2(EUg(1,1,j),auxmat(1,1))
6259         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6260         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6261         do iii=1,2
6262           do kkk=1,5
6263             do lll=1,3
6264               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6265      &          EAEAderx(1,1,lll,kkk,iii,2))
6266             enddo
6267           enddo
6268         enddo
6269 C AEAb1 and AEAb2
6270 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6271 C They are needed only when the fifth- or the sixth-order cumulants are
6272 C indluded.
6273         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6274      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6275         call transpose2(AEA(1,1,1),auxmat(1,1))
6276         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6277         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6278         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6279         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6280         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6281         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6282         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6283         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6284         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6285         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6286         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6287         call transpose2(AEA(1,1,2),auxmat(1,1))
6288         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6289         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6290         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6291         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6292         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6293         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6294         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6295         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6296         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6297         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6298         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6299 C Calculate the Cartesian derivatives of the vectors.
6300         do iii=1,2
6301           do kkk=1,5
6302             do lll=1,3
6303               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6304               call matvec2(auxmat(1,1),b1(1,iti),
6305      &          AEAb1derx(1,lll,kkk,iii,1,1))
6306               call matvec2(auxmat(1,1),Ub2(1,i),
6307      &          AEAb2derx(1,lll,kkk,iii,1,1))
6308               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6309      &          AEAb1derx(1,lll,kkk,iii,2,1))
6310               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6311      &          AEAb2derx(1,lll,kkk,iii,2,1))
6312               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6313               call matvec2(auxmat(1,1),b1(1,itl),
6314      &          AEAb1derx(1,lll,kkk,iii,1,2))
6315               call matvec2(auxmat(1,1),Ub2(1,l),
6316      &          AEAb2derx(1,lll,kkk,iii,1,2))
6317               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6318      &          AEAb1derx(1,lll,kkk,iii,2,2))
6319               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6320      &          AEAb2derx(1,lll,kkk,iii,2,2))
6321             enddo
6322           enddo
6323         enddo
6324         ENDIF
6325 C End vectors
6326       endif
6327       return
6328       end
6329 C---------------------------------------------------------------------------
6330       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6331      &  KK,KKderg,AKA,AKAderg,AKAderx)
6332       implicit none
6333       integer nderg
6334       logical transp
6335       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6336      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6337      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6338       integer iii,kkk,lll
6339       integer jjj,mmm
6340       logical lprn
6341       common /kutas/ lprn
6342       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6343       do iii=1,nderg
6344         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6345      &    AKAderg(1,1,iii))
6346       enddo
6347 cd      if (lprn) write (2,*) 'In kernel'
6348       do kkk=1,5
6349 cd        if (lprn) write (2,*) 'kkk=',kkk
6350         do lll=1,3
6351           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6352      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6353 cd          if (lprn) then
6354 cd            write (2,*) 'lll=',lll
6355 cd            write (2,*) 'iii=1'
6356 cd            do jjj=1,2
6357 cd              write (2,'(3(2f10.5),5x)')
6358 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6359 cd            enddo
6360 cd          endif
6361           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6362      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6363 cd          if (lprn) then
6364 cd            write (2,*) 'lll=',lll
6365 cd            write (2,*) 'iii=2'
6366 cd            do jjj=1,2
6367 cd              write (2,'(3(2f10.5),5x)')
6368 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6369 cd            enddo
6370 cd          endif
6371         enddo
6372       enddo
6373       return
6374       end
6375 C---------------------------------------------------------------------------
6376       double precision function eello4(i,j,k,l,jj,kk)
6377       implicit real*8 (a-h,o-z)
6378       include 'DIMENSIONS'
6379       include 'DIMENSIONS.ZSCOPT'
6380       include 'COMMON.IOUNITS'
6381       include 'COMMON.CHAIN'
6382       include 'COMMON.DERIV'
6383       include 'COMMON.INTERACT'
6384       include 'COMMON.CONTACTS'
6385       include 'COMMON.TORSION'
6386       include 'COMMON.VAR'
6387       include 'COMMON.GEO'
6388       double precision pizda(2,2),ggg1(3),ggg2(3)
6389 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6390 cd        eello4=0.0d0
6391 cd        return
6392 cd      endif
6393 cd      print *,'eello4:',i,j,k,l,jj,kk
6394 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6395 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6396 cold      eij=facont_hb(jj,i)
6397 cold      ekl=facont_hb(kk,k)
6398 cold      ekont=eij*ekl
6399       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6400       if (calc_grad) then
6401 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6402       gcorr_loc(k-1)=gcorr_loc(k-1)
6403      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6404       if (l.eq.j+1) then
6405         gcorr_loc(l-1)=gcorr_loc(l-1)
6406      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6407       else
6408         gcorr_loc(j-1)=gcorr_loc(j-1)
6409      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6410       endif
6411       do iii=1,2
6412         do kkk=1,5
6413           do lll=1,3
6414             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6415      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6416 cd            derx(lll,kkk,iii)=0.0d0
6417           enddo
6418         enddo
6419       enddo
6420 cd      gcorr_loc(l-1)=0.0d0
6421 cd      gcorr_loc(j-1)=0.0d0
6422 cd      gcorr_loc(k-1)=0.0d0
6423 cd      eel4=1.0d0
6424 cd      write (iout,*)'Contacts have occurred for peptide groups',
6425 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6426 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6427       if (j.lt.nres-1) then
6428         j1=j+1
6429         j2=j-1
6430       else
6431         j1=j-1
6432         j2=j-2
6433       endif
6434       if (l.lt.nres-1) then
6435         l1=l+1
6436         l2=l-1
6437       else
6438         l1=l-1
6439         l2=l-2
6440       endif
6441       do ll=1,3
6442 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6443         ggg1(ll)=eel4*g_contij(ll,1)
6444         ggg2(ll)=eel4*g_contij(ll,2)
6445         ghalf=0.5d0*ggg1(ll)
6446 cd        ghalf=0.0d0
6447         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6448         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6449         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6450         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6451 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6452         ghalf=0.5d0*ggg2(ll)
6453 cd        ghalf=0.0d0
6454         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6455         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6456         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6457         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6458       enddo
6459 cd      goto 1112
6460       do m=i+1,j-1
6461         do ll=1,3
6462 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6463           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6464         enddo
6465       enddo
6466       do m=k+1,l-1
6467         do ll=1,3
6468 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6469           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6470         enddo
6471       enddo
6472 1112  continue
6473       do m=i+2,j2
6474         do ll=1,3
6475           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6476         enddo
6477       enddo
6478       do m=k+2,l2
6479         do ll=1,3
6480           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6481         enddo
6482       enddo
6483 cd      do iii=1,nres-3
6484 cd        write (2,*) iii,gcorr_loc(iii)
6485 cd      enddo
6486       endif
6487       eello4=ekont*eel4
6488 cd      write (2,*) 'ekont',ekont
6489 cd      write (iout,*) 'eello4',ekont*eel4
6490       return
6491       end
6492 C---------------------------------------------------------------------------
6493       double precision function eello5(i,j,k,l,jj,kk)
6494       implicit real*8 (a-h,o-z)
6495       include 'DIMENSIONS'
6496       include 'DIMENSIONS.ZSCOPT'
6497       include 'COMMON.IOUNITS'
6498       include 'COMMON.CHAIN'
6499       include 'COMMON.DERIV'
6500       include 'COMMON.INTERACT'
6501       include 'COMMON.CONTACTS'
6502       include 'COMMON.TORSION'
6503       include 'COMMON.VAR'
6504       include 'COMMON.GEO'
6505       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6506       double precision ggg1(3),ggg2(3)
6507 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6508 C                                                                              C
6509 C                            Parallel chains                                   C
6510 C                                                                              C
6511 C          o             o                   o             o                   C
6512 C         /l\           / \             \   / \           / \   /              C
6513 C        /   \         /   \             \ /   \         /   \ /               C
6514 C       j| o |l1       | o |              o| o |         | o |o                C
6515 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6516 C      \i/   \         /   \ /             /   \         /   \                 C
6517 C       o    k1             o                                                  C
6518 C         (I)          (II)                (III)          (IV)                 C
6519 C                                                                              C
6520 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6521 C                                                                              C
6522 C                            Antiparallel chains                               C
6523 C                                                                              C
6524 C          o             o                   o             o                   C
6525 C         /j\           / \             \   / \           / \   /              C
6526 C        /   \         /   \             \ /   \         /   \ /               C
6527 C      j1| o |l        | o |              o| o |         | o |o                C
6528 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6529 C      \i/   \         /   \ /             /   \         /   \                 C
6530 C       o     k1            o                                                  C
6531 C         (I)          (II)                (III)          (IV)                 C
6532 C                                                                              C
6533 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6534 C                                                                              C
6535 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6536 C                                                                              C
6537 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6538 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6539 cd        eello5=0.0d0
6540 cd        return
6541 cd      endif
6542 cd      write (iout,*)
6543 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6544 cd     &   ' and',k,l
6545       itk=itortyp(itype(k))
6546       itl=itortyp(itype(l))
6547       itj=itortyp(itype(j))
6548       eello5_1=0.0d0
6549       eello5_2=0.0d0
6550       eello5_3=0.0d0
6551       eello5_4=0.0d0
6552 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6553 cd     &   eel5_3_num,eel5_4_num)
6554       do iii=1,2
6555         do kkk=1,5
6556           do lll=1,3
6557             derx(lll,kkk,iii)=0.0d0
6558           enddo
6559         enddo
6560       enddo
6561 cd      eij=facont_hb(jj,i)
6562 cd      ekl=facont_hb(kk,k)
6563 cd      ekont=eij*ekl
6564 cd      write (iout,*)'Contacts have occurred for peptide groups',
6565 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6566 cd      goto 1111
6567 C Contribution from the graph I.
6568 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6569 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6570       call transpose2(EUg(1,1,k),auxmat(1,1))
6571       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6572       vv(1)=pizda(1,1)-pizda(2,2)
6573       vv(2)=pizda(1,2)+pizda(2,1)
6574       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6575      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6576       if (calc_grad) then
6577 C Explicit gradient in virtual-dihedral angles.
6578       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6579      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6580      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6581       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6582       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6583       vv(1)=pizda(1,1)-pizda(2,2)
6584       vv(2)=pizda(1,2)+pizda(2,1)
6585       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6586      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6587      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6588       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6589       vv(1)=pizda(1,1)-pizda(2,2)
6590       vv(2)=pizda(1,2)+pizda(2,1)
6591       if (l.eq.j+1) then
6592         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6593      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6595       else
6596         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6597      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6598      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6599       endif
6600 C Cartesian gradient
6601       do iii=1,2
6602         do kkk=1,5
6603           do lll=1,3
6604             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6605      &        pizda(1,1))
6606             vv(1)=pizda(1,1)-pizda(2,2)
6607             vv(2)=pizda(1,2)+pizda(2,1)
6608             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6609      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6610      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6611           enddo
6612         enddo
6613       enddo
6614 c      goto 1112
6615       endif
6616 c1111  continue
6617 C Contribution from graph II
6618       call transpose2(EE(1,1,itk),auxmat(1,1))
6619       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6620       vv(1)=pizda(1,1)+pizda(2,2)
6621       vv(2)=pizda(2,1)-pizda(1,2)
6622       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6623      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6624       if (calc_grad) then
6625 C Explicit gradient in virtual-dihedral angles.
6626       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6627      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6628       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6629       vv(1)=pizda(1,1)+pizda(2,2)
6630       vv(2)=pizda(2,1)-pizda(1,2)
6631       if (l.eq.j+1) then
6632         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6633      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6634      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6635       else
6636         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6637      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6638      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6639       endif
6640 C Cartesian gradient
6641       do iii=1,2
6642         do kkk=1,5
6643           do lll=1,3
6644             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6645      &        pizda(1,1))
6646             vv(1)=pizda(1,1)+pizda(2,2)
6647             vv(2)=pizda(2,1)-pizda(1,2)
6648             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6649      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6650      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6651           enddo
6652         enddo
6653       enddo
6654 cd      goto 1112
6655       endif
6656 cd1111  continue
6657       if (l.eq.j+1) then
6658 cd        goto 1110
6659 C Parallel orientation
6660 C Contribution from graph III
6661         call transpose2(EUg(1,1,l),auxmat(1,1))
6662         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6663         vv(1)=pizda(1,1)-pizda(2,2)
6664         vv(2)=pizda(1,2)+pizda(2,1)
6665         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6666      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6667         if (calc_grad) then
6668 C Explicit gradient in virtual-dihedral angles.
6669         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6670      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6671      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6672         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6673         vv(1)=pizda(1,1)-pizda(2,2)
6674         vv(2)=pizda(1,2)+pizda(2,1)
6675         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6676      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6677      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6678         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6679         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6680         vv(1)=pizda(1,1)-pizda(2,2)
6681         vv(2)=pizda(1,2)+pizda(2,1)
6682         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6683      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6684      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6685 C Cartesian gradient
6686         do iii=1,2
6687           do kkk=1,5
6688             do lll=1,3
6689               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6690      &          pizda(1,1))
6691               vv(1)=pizda(1,1)-pizda(2,2)
6692               vv(2)=pizda(1,2)+pizda(2,1)
6693               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6694      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6695      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6696             enddo
6697           enddo
6698         enddo
6699 cd        goto 1112
6700         endif
6701 C Contribution from graph IV
6702 cd1110    continue
6703         call transpose2(EE(1,1,itl),auxmat(1,1))
6704         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6705         vv(1)=pizda(1,1)+pizda(2,2)
6706         vv(2)=pizda(2,1)-pizda(1,2)
6707         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6708      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6709         if (calc_grad) then
6710 C Explicit gradient in virtual-dihedral angles.
6711         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6712      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6713         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6714         vv(1)=pizda(1,1)+pizda(2,2)
6715         vv(2)=pizda(2,1)-pizda(1,2)
6716         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6717      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6718      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6719 C Cartesian gradient
6720         do iii=1,2
6721           do kkk=1,5
6722             do lll=1,3
6723               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6724      &          pizda(1,1))
6725               vv(1)=pizda(1,1)+pizda(2,2)
6726               vv(2)=pizda(2,1)-pizda(1,2)
6727               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6728      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6729      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6730             enddo
6731           enddo
6732         enddo
6733         endif
6734       else
6735 C Antiparallel orientation
6736 C Contribution from graph III
6737 c        goto 1110
6738         call transpose2(EUg(1,1,j),auxmat(1,1))
6739         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6740         vv(1)=pizda(1,1)-pizda(2,2)
6741         vv(2)=pizda(1,2)+pizda(2,1)
6742         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6743      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6744         if (calc_grad) then
6745 C Explicit gradient in virtual-dihedral angles.
6746         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6747      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6748      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6749         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6750         vv(1)=pizda(1,1)-pizda(2,2)
6751         vv(2)=pizda(1,2)+pizda(2,1)
6752         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6753      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6754      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6755         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6756         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6757         vv(1)=pizda(1,1)-pizda(2,2)
6758         vv(2)=pizda(1,2)+pizda(2,1)
6759         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6760      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6762 C Cartesian gradient
6763         do iii=1,2
6764           do kkk=1,5
6765             do lll=1,3
6766               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6767      &          pizda(1,1))
6768               vv(1)=pizda(1,1)-pizda(2,2)
6769               vv(2)=pizda(1,2)+pizda(2,1)
6770               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6771      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6772      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6773             enddo
6774           enddo
6775         enddo
6776 cd        goto 1112
6777         endif
6778 C Contribution from graph IV
6779 1110    continue
6780         call transpose2(EE(1,1,itj),auxmat(1,1))
6781         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6782         vv(1)=pizda(1,1)+pizda(2,2)
6783         vv(2)=pizda(2,1)-pizda(1,2)
6784         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6785      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6786         if (calc_grad) then
6787 C Explicit gradient in virtual-dihedral angles.
6788         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6789      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6790         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6791         vv(1)=pizda(1,1)+pizda(2,2)
6792         vv(2)=pizda(2,1)-pizda(1,2)
6793         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6794      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6795      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6796 C Cartesian gradient
6797         do iii=1,2
6798           do kkk=1,5
6799             do lll=1,3
6800               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6801      &          pizda(1,1))
6802               vv(1)=pizda(1,1)+pizda(2,2)
6803               vv(2)=pizda(2,1)-pizda(1,2)
6804               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6805      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6806      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6807             enddo
6808           enddo
6809         enddo
6810       endif
6811       endif
6812 1112  continue
6813       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6814 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6815 cd        write (2,*) 'ijkl',i,j,k,l
6816 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6817 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6818 cd      endif
6819 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6820 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6821 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6822 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6823       if (calc_grad) then
6824       if (j.lt.nres-1) then
6825         j1=j+1
6826         j2=j-1
6827       else
6828         j1=j-1
6829         j2=j-2
6830       endif
6831       if (l.lt.nres-1) then
6832         l1=l+1
6833         l2=l-1
6834       else
6835         l1=l-1
6836         l2=l-2
6837       endif
6838 cd      eij=1.0d0
6839 cd      ekl=1.0d0
6840 cd      ekont=1.0d0
6841 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6842       do ll=1,3
6843         ggg1(ll)=eel5*g_contij(ll,1)
6844         ggg2(ll)=eel5*g_contij(ll,2)
6845 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6846         ghalf=0.5d0*ggg1(ll)
6847 cd        ghalf=0.0d0
6848         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6849         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6850         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6851         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6852 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6853         ghalf=0.5d0*ggg2(ll)
6854 cd        ghalf=0.0d0
6855         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6856         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6857         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6858         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6859       enddo
6860 cd      goto 1112
6861       do m=i+1,j-1
6862         do ll=1,3
6863 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6864           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6865         enddo
6866       enddo
6867       do m=k+1,l-1
6868         do ll=1,3
6869 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6870           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6871         enddo
6872       enddo
6873 c1112  continue
6874       do m=i+2,j2
6875         do ll=1,3
6876           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6877         enddo
6878       enddo
6879       do m=k+2,l2
6880         do ll=1,3
6881           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6882         enddo
6883       enddo
6884 cd      do iii=1,nres-3
6885 cd        write (2,*) iii,g_corr5_loc(iii)
6886 cd      enddo
6887       endif
6888       eello5=ekont*eel5
6889 cd      write (2,*) 'ekont',ekont
6890 cd      write (iout,*) 'eello5',ekont*eel5
6891       return
6892       end
6893 c--------------------------------------------------------------------------
6894       double precision function eello6(i,j,k,l,jj,kk)
6895       implicit real*8 (a-h,o-z)
6896       include 'DIMENSIONS'
6897       include 'DIMENSIONS.ZSCOPT'
6898       include 'COMMON.IOUNITS'
6899       include 'COMMON.CHAIN'
6900       include 'COMMON.DERIV'
6901       include 'COMMON.INTERACT'
6902       include 'COMMON.CONTACTS'
6903       include 'COMMON.TORSION'
6904       include 'COMMON.VAR'
6905       include 'COMMON.GEO'
6906       include 'COMMON.FFIELD'
6907       double precision ggg1(3),ggg2(3)
6908 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6909 cd        eello6=0.0d0
6910 cd        return
6911 cd      endif
6912 cd      write (iout,*)
6913 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6914 cd     &   ' and',k,l
6915       eello6_1=0.0d0
6916       eello6_2=0.0d0
6917       eello6_3=0.0d0
6918       eello6_4=0.0d0
6919       eello6_5=0.0d0
6920       eello6_6=0.0d0
6921 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6922 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6923       do iii=1,2
6924         do kkk=1,5
6925           do lll=1,3
6926             derx(lll,kkk,iii)=0.0d0
6927           enddo
6928         enddo
6929       enddo
6930 cd      eij=facont_hb(jj,i)
6931 cd      ekl=facont_hb(kk,k)
6932 cd      ekont=eij*ekl
6933 cd      eij=1.0d0
6934 cd      ekl=1.0d0
6935 cd      ekont=1.0d0
6936       if (l.eq.j+1) then
6937         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6938         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6939         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6940         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6941         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6942         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6943       else
6944         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6945         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6946         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6947         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6948         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6949           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6950         else
6951           eello6_5=0.0d0
6952         endif
6953         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6954       endif
6955 C If turn contributions are considered, they will be handled separately.
6956       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6957 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6958 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6959 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6960 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6961 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6962 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6963 cd      goto 1112
6964       if (calc_grad) then
6965       if (j.lt.nres-1) then
6966         j1=j+1
6967         j2=j-1
6968       else
6969         j1=j-1
6970         j2=j-2
6971       endif
6972       if (l.lt.nres-1) then
6973         l1=l+1
6974         l2=l-1
6975       else
6976         l1=l-1
6977         l2=l-2
6978       endif
6979       do ll=1,3
6980         ggg1(ll)=eel6*g_contij(ll,1)
6981         ggg2(ll)=eel6*g_contij(ll,2)
6982 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6983         ghalf=0.5d0*ggg1(ll)
6984 cd        ghalf=0.0d0
6985         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6986         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6987         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6988         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6989         ghalf=0.5d0*ggg2(ll)
6990 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6991 cd        ghalf=0.0d0
6992         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6993         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6994         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6995         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6996       enddo
6997 cd      goto 1112
6998       do m=i+1,j-1
6999         do ll=1,3
7000 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7001           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7002         enddo
7003       enddo
7004       do m=k+1,l-1
7005         do ll=1,3
7006 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7007           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7008         enddo
7009       enddo
7010 1112  continue
7011       do m=i+2,j2
7012         do ll=1,3
7013           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7014         enddo
7015       enddo
7016       do m=k+2,l2
7017         do ll=1,3
7018           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7019         enddo
7020       enddo
7021 cd      do iii=1,nres-3
7022 cd        write (2,*) iii,g_corr6_loc(iii)
7023 cd      enddo
7024       endif
7025       eello6=ekont*eel6
7026 cd      write (2,*) 'ekont',ekont
7027 cd      write (iout,*) 'eello6',ekont*eel6
7028       return
7029       end
7030 c--------------------------------------------------------------------------
7031       double precision function eello6_graph1(i,j,k,l,imat,swap)
7032       implicit real*8 (a-h,o-z)
7033       include 'DIMENSIONS'
7034       include 'DIMENSIONS.ZSCOPT'
7035       include 'COMMON.IOUNITS'
7036       include 'COMMON.CHAIN'
7037       include 'COMMON.DERIV'
7038       include 'COMMON.INTERACT'
7039       include 'COMMON.CONTACTS'
7040       include 'COMMON.TORSION'
7041       include 'COMMON.VAR'
7042       include 'COMMON.GEO'
7043       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7044       logical swap
7045       logical lprn
7046       common /kutas/ lprn
7047 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7048 C                                                                              C
7049 C      Parallel       Antiparallel                                             C
7050 C                                                                              C
7051 C          o             o                                                     C
7052 C         /l\           /j\                                                    C
7053 C        /   \         /   \                                                   C
7054 C       /| o |         | o |\                                                  C
7055 C     \ j|/k\|  /   \  |/k\|l /                                                C
7056 C      \ /   \ /     \ /   \ /                                                 C
7057 C       o     o       o     o                                                  C
7058 C       i             i                                                        C
7059 C                                                                              C
7060 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7061       itk=itortyp(itype(k))
7062       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7063       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7064       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7065       call transpose2(EUgC(1,1,k),auxmat(1,1))
7066       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7067       vv1(1)=pizda1(1,1)-pizda1(2,2)
7068       vv1(2)=pizda1(1,2)+pizda1(2,1)
7069       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7070       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7071       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7072       s5=scalar2(vv(1),Dtobr2(1,i))
7073 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7074       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7075       if (.not. calc_grad) return
7076       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7077      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7078      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7079      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7080      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7081      & +scalar2(vv(1),Dtobr2der(1,i)))
7082       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7083       vv1(1)=pizda1(1,1)-pizda1(2,2)
7084       vv1(2)=pizda1(1,2)+pizda1(2,1)
7085       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7086       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7087       if (l.eq.j+1) then
7088         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7089      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7090      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7091      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7092      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7093       else
7094         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7095      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7096      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7097      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7098      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7099       endif
7100       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7101       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7102       vv1(1)=pizda1(1,1)-pizda1(2,2)
7103       vv1(2)=pizda1(1,2)+pizda1(2,1)
7104       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7105      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7106      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7107      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7108       do iii=1,2
7109         if (swap) then
7110           ind=3-iii
7111         else
7112           ind=iii
7113         endif
7114         do kkk=1,5
7115           do lll=1,3
7116             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7117             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7118             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7119             call transpose2(EUgC(1,1,k),auxmat(1,1))
7120             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7121      &        pizda1(1,1))
7122             vv1(1)=pizda1(1,1)-pizda1(2,2)
7123             vv1(2)=pizda1(1,2)+pizda1(2,1)
7124             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7125             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7126      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7127             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7128      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7129             s5=scalar2(vv(1),Dtobr2(1,i))
7130             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7131           enddo
7132         enddo
7133       enddo
7134       return
7135       end
7136 c----------------------------------------------------------------------------
7137       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7138       implicit real*8 (a-h,o-z)
7139       include 'DIMENSIONS'
7140       include 'DIMENSIONS.ZSCOPT'
7141       include 'COMMON.IOUNITS'
7142       include 'COMMON.CHAIN'
7143       include 'COMMON.DERIV'
7144       include 'COMMON.INTERACT'
7145       include 'COMMON.CONTACTS'
7146       include 'COMMON.TORSION'
7147       include 'COMMON.VAR'
7148       include 'COMMON.GEO'
7149       logical swap
7150       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7151      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7152       logical lprn
7153       common /kutas/ lprn
7154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7155 C                                                                              C
7156 C      Parallel       Antiparallel                                             C
7157 C                                                                              C
7158 C          o             o                                                     C
7159 C     \   /l\           /j\   /                                                C
7160 C      \ /   \         /   \ /                                                 C
7161 C       o| o |         | o |o                                                  C
7162 C     \ j|/k\|      \  |/k\|l                                                  C
7163 C      \ /   \       \ /   \                                                   C
7164 C       o             o                                                        C
7165 C       i             i                                                        C
7166 C                                                                              C
7167 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7168 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7169 C AL 7/4/01 s1 would occur in the sixth-order moment,
7170 C           but not in a cluster cumulant
7171 #ifdef MOMENT
7172       s1=dip(1,jj,i)*dip(1,kk,k)
7173 #endif
7174       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7175       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7176       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7177       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7178       call transpose2(EUg(1,1,k),auxmat(1,1))
7179       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7180       vv(1)=pizda(1,1)-pizda(2,2)
7181       vv(2)=pizda(1,2)+pizda(2,1)
7182       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7183 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7184 #ifdef MOMENT
7185       eello6_graph2=-(s1+s2+s3+s4)
7186 #else
7187       eello6_graph2=-(s2+s3+s4)
7188 #endif
7189 c      eello6_graph2=-s3
7190       if (.not. calc_grad) return
7191 C Derivatives in gamma(i-1)
7192       if (i.gt.1) then
7193 #ifdef MOMENT
7194         s1=dipderg(1,jj,i)*dip(1,kk,k)
7195 #endif
7196         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7197         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7198         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7199         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7200 #ifdef MOMENT
7201         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7202 #else
7203         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7204 #endif
7205 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7206       endif
7207 C Derivatives in gamma(k-1)
7208 #ifdef MOMENT
7209       s1=dip(1,jj,i)*dipderg(1,kk,k)
7210 #endif
7211       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7212       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7213       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7214       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7215       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7216       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7217       vv(1)=pizda(1,1)-pizda(2,2)
7218       vv(2)=pizda(1,2)+pizda(2,1)
7219       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7220 #ifdef MOMENT
7221       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7222 #else
7223       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7224 #endif
7225 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7226 C Derivatives in gamma(j-1) or gamma(l-1)
7227       if (j.gt.1) then
7228 #ifdef MOMENT
7229         s1=dipderg(3,jj,i)*dip(1,kk,k)
7230 #endif
7231         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7232         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7233         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7234         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7235         vv(1)=pizda(1,1)-pizda(2,2)
7236         vv(2)=pizda(1,2)+pizda(2,1)
7237         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7238 #ifdef MOMENT
7239         if (swap) then
7240           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7241         else
7242           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7243         endif
7244 #endif
7245         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7246 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7247       endif
7248 C Derivatives in gamma(l-1) or gamma(j-1)
7249       if (l.gt.1) then
7250 #ifdef MOMENT
7251         s1=dip(1,jj,i)*dipderg(3,kk,k)
7252 #endif
7253         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7254         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7255         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7256         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7257         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7258         vv(1)=pizda(1,1)-pizda(2,2)
7259         vv(2)=pizda(1,2)+pizda(2,1)
7260         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7261 #ifdef MOMENT
7262         if (swap) then
7263           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7264         else
7265           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7266         endif
7267 #endif
7268         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7269 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7270       endif
7271 C Cartesian derivatives.
7272       if (lprn) then
7273         write (2,*) 'In eello6_graph2'
7274         do iii=1,2
7275           write (2,*) 'iii=',iii
7276           do kkk=1,5
7277             write (2,*) 'kkk=',kkk
7278             do jjj=1,2
7279               write (2,'(3(2f10.5),5x)')
7280      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7281             enddo
7282           enddo
7283         enddo
7284       endif
7285       do iii=1,2
7286         do kkk=1,5
7287           do lll=1,3
7288 #ifdef MOMENT
7289             if (iii.eq.1) then
7290               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7291             else
7292               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7293             endif
7294 #endif
7295             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7296      &        auxvec(1))
7297             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7298             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7299      &        auxvec(1))
7300             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7301             call transpose2(EUg(1,1,k),auxmat(1,1))
7302             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7303      &        pizda(1,1))
7304             vv(1)=pizda(1,1)-pizda(2,2)
7305             vv(2)=pizda(1,2)+pizda(2,1)
7306             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7307 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7308 #ifdef MOMENT
7309             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7310 #else
7311             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7312 #endif
7313             if (swap) then
7314               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7315             else
7316               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7317             endif
7318           enddo
7319         enddo
7320       enddo
7321       return
7322       end
7323 c----------------------------------------------------------------------------
7324       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7325       implicit real*8 (a-h,o-z)
7326       include 'DIMENSIONS'
7327       include 'DIMENSIONS.ZSCOPT'
7328       include 'COMMON.IOUNITS'
7329       include 'COMMON.CHAIN'
7330       include 'COMMON.DERIV'
7331       include 'COMMON.INTERACT'
7332       include 'COMMON.CONTACTS'
7333       include 'COMMON.TORSION'
7334       include 'COMMON.VAR'
7335       include 'COMMON.GEO'
7336       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7337       logical swap
7338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7339 C                                                                              C
7340 C      Parallel       Antiparallel                                             C
7341 C                                                                              C
7342 C          o             o                                                     C
7343 C         /l\   /   \   /j\                                                    C
7344 C        /   \ /     \ /   \                                                   C
7345 C       /| o |o       o| o |\                                                  C
7346 C       j|/k\|  /      |/k\|l /                                                C
7347 C        /   \ /       /   \ /                                                 C
7348 C       /     o       /     o                                                  C
7349 C       i             i                                                        C
7350 C                                                                              C
7351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7352 C
7353 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7354 C           energy moment and not to the cluster cumulant.
7355       iti=itortyp(itype(i))
7356       if (j.lt.nres-1) then
7357         itj1=itortyp(itype(j+1))
7358       else
7359         itj1=ntortyp+1
7360       endif
7361       itk=itortyp(itype(k))
7362       itk1=itortyp(itype(k+1))
7363       if (l.lt.nres-1) then
7364         itl1=itortyp(itype(l+1))
7365       else
7366         itl1=ntortyp+1
7367       endif
7368 #ifdef MOMENT
7369       s1=dip(4,jj,i)*dip(4,kk,k)
7370 #endif
7371       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7372       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7373       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7374       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7375       call transpose2(EE(1,1,itk),auxmat(1,1))
7376       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7377       vv(1)=pizda(1,1)+pizda(2,2)
7378       vv(2)=pizda(2,1)-pizda(1,2)
7379       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7380 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7381 #ifdef MOMENT
7382       eello6_graph3=-(s1+s2+s3+s4)
7383 #else
7384       eello6_graph3=-(s2+s3+s4)
7385 #endif
7386 c      eello6_graph3=-s4
7387       if (.not. calc_grad) return
7388 C Derivatives in gamma(k-1)
7389       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7390       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7391       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7392       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7393 C Derivatives in gamma(l-1)
7394       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7395       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7396       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7397       vv(1)=pizda(1,1)+pizda(2,2)
7398       vv(2)=pizda(2,1)-pizda(1,2)
7399       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7400       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7401 C Cartesian derivatives.
7402       do iii=1,2
7403         do kkk=1,5
7404           do lll=1,3
7405 #ifdef MOMENT
7406             if (iii.eq.1) then
7407               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7408             else
7409               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7410             endif
7411 #endif
7412             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7413      &        auxvec(1))
7414             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7415             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7416      &        auxvec(1))
7417             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7418             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7419      &        pizda(1,1))
7420             vv(1)=pizda(1,1)+pizda(2,2)
7421             vv(2)=pizda(2,1)-pizda(1,2)
7422             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7423 #ifdef MOMENT
7424             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7425 #else
7426             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7427 #endif
7428             if (swap) then
7429               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7430             else
7431               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7432             endif
7433 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7434           enddo
7435         enddo
7436       enddo
7437       return
7438       end
7439 c----------------------------------------------------------------------------
7440       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7441       implicit real*8 (a-h,o-z)
7442       include 'DIMENSIONS'
7443       include 'DIMENSIONS.ZSCOPT'
7444       include 'COMMON.IOUNITS'
7445       include 'COMMON.CHAIN'
7446       include 'COMMON.DERIV'
7447       include 'COMMON.INTERACT'
7448       include 'COMMON.CONTACTS'
7449       include 'COMMON.TORSION'
7450       include 'COMMON.VAR'
7451       include 'COMMON.GEO'
7452       include 'COMMON.FFIELD'
7453       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7454      & auxvec1(2),auxmat1(2,2)
7455       logical swap
7456 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7457 C                                                                              C
7458 C      Parallel       Antiparallel                                             C
7459 C                                                                              C
7460 C          o             o                                                     C
7461 C         /l\   /   \   /j\                                                    C
7462 C        /   \ /     \ /   \                                                   C
7463 C       /| o |o       o| o |\                                                  C
7464 C     \ j|/k\|      \  |/k\|l                                                  C
7465 C      \ /   \       \ /   \                                                   C
7466 C       o     \       o     \                                                  C
7467 C       i             i                                                        C
7468 C                                                                              C
7469 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7470 C
7471 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7472 C           energy moment and not to the cluster cumulant.
7473 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7474       iti=itortyp(itype(i))
7475       itj=itortyp(itype(j))
7476       if (j.lt.nres-1) then
7477         itj1=itortyp(itype(j+1))
7478       else
7479         itj1=ntortyp+1
7480       endif
7481       itk=itortyp(itype(k))
7482       if (k.lt.nres-1) then
7483         itk1=itortyp(itype(k+1))
7484       else
7485         itk1=ntortyp+1
7486       endif
7487       itl=itortyp(itype(l))
7488       if (l.lt.nres-1) then
7489         itl1=itortyp(itype(l+1))
7490       else
7491         itl1=ntortyp+1
7492       endif
7493 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7494 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7495 cd     & ' itl',itl,' itl1',itl1
7496 #ifdef MOMENT
7497       if (imat.eq.1) then
7498         s1=dip(3,jj,i)*dip(3,kk,k)
7499       else
7500         s1=dip(2,jj,j)*dip(2,kk,l)
7501       endif
7502 #endif
7503       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7504       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7505       if (j.eq.l+1) then
7506         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7507         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7508       else
7509         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7510         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7511       endif
7512       call transpose2(EUg(1,1,k),auxmat(1,1))
7513       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7514       vv(1)=pizda(1,1)-pizda(2,2)
7515       vv(2)=pizda(2,1)+pizda(1,2)
7516       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7517 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7518 #ifdef MOMENT
7519       eello6_graph4=-(s1+s2+s3+s4)
7520 #else
7521       eello6_graph4=-(s2+s3+s4)
7522 #endif
7523       if (.not. calc_grad) return
7524 C Derivatives in gamma(i-1)
7525       if (i.gt.1) then
7526 #ifdef MOMENT
7527         if (imat.eq.1) then
7528           s1=dipderg(2,jj,i)*dip(3,kk,k)
7529         else
7530           s1=dipderg(4,jj,j)*dip(2,kk,l)
7531         endif
7532 #endif
7533         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7534         if (j.eq.l+1) then
7535           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7536           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7537         else
7538           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7539           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7540         endif
7541         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7542         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7543 cd          write (2,*) 'turn6 derivatives'
7544 #ifdef MOMENT
7545           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7546 #else
7547           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7548 #endif
7549         else
7550 #ifdef MOMENT
7551           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7552 #else
7553           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7554 #endif
7555         endif
7556       endif
7557 C Derivatives in gamma(k-1)
7558 #ifdef MOMENT
7559       if (imat.eq.1) then
7560         s1=dip(3,jj,i)*dipderg(2,kk,k)
7561       else
7562         s1=dip(2,jj,j)*dipderg(4,kk,l)
7563       endif
7564 #endif
7565       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7566       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7567       if (j.eq.l+1) then
7568         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7569         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7570       else
7571         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7572         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7573       endif
7574       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7575       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7576       vv(1)=pizda(1,1)-pizda(2,2)
7577       vv(2)=pizda(2,1)+pizda(1,2)
7578       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7579       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7580 #ifdef MOMENT
7581         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7582 #else
7583         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7584 #endif
7585       else
7586 #ifdef MOMENT
7587         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7588 #else
7589         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7590 #endif
7591       endif
7592 C Derivatives in gamma(j-1) or gamma(l-1)
7593       if (l.eq.j+1 .and. l.gt.1) then
7594         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7595         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7596         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7597         vv(1)=pizda(1,1)-pizda(2,2)
7598         vv(2)=pizda(2,1)+pizda(1,2)
7599         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7600         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7601       else if (j.gt.1) then
7602         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7603         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7604         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7605         vv(1)=pizda(1,1)-pizda(2,2)
7606         vv(2)=pizda(2,1)+pizda(1,2)
7607         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7608         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7609           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7610         else
7611           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7612         endif
7613       endif
7614 C Cartesian derivatives.
7615       do iii=1,2
7616         do kkk=1,5
7617           do lll=1,3
7618 #ifdef MOMENT
7619             if (iii.eq.1) then
7620               if (imat.eq.1) then
7621                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7622               else
7623                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7624               endif
7625             else
7626               if (imat.eq.1) then
7627                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7628               else
7629                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7630               endif
7631             endif
7632 #endif
7633             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7634      &        auxvec(1))
7635             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7636             if (j.eq.l+1) then
7637               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7638      &          b1(1,itj1),auxvec(1))
7639               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7640             else
7641               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7642      &          b1(1,itl1),auxvec(1))
7643               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7644             endif
7645             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7646      &        pizda(1,1))
7647             vv(1)=pizda(1,1)-pizda(2,2)
7648             vv(2)=pizda(2,1)+pizda(1,2)
7649             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7650             if (swap) then
7651               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7652 #ifdef MOMENT
7653                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7654      &             -(s1+s2+s4)
7655 #else
7656                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7657      &             -(s2+s4)
7658 #endif
7659                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7660               else
7661 #ifdef MOMENT
7662                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7663 #else
7664                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7665 #endif
7666                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7667               endif
7668             else
7669 #ifdef MOMENT
7670               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7671 #else
7672               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7673 #endif
7674               if (l.eq.j+1) then
7675                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7676               else
7677                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7678               endif
7679             endif
7680           enddo
7681         enddo
7682       enddo
7683       return
7684       end
7685 c----------------------------------------------------------------------------
7686       double precision function eello_turn6(i,jj,kk)
7687       implicit real*8 (a-h,o-z)
7688       include 'DIMENSIONS'
7689       include 'DIMENSIONS.ZSCOPT'
7690       include 'COMMON.IOUNITS'
7691       include 'COMMON.CHAIN'
7692       include 'COMMON.DERIV'
7693       include 'COMMON.INTERACT'
7694       include 'COMMON.CONTACTS'
7695       include 'COMMON.TORSION'
7696       include 'COMMON.VAR'
7697       include 'COMMON.GEO'
7698       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7699      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7700      &  ggg1(3),ggg2(3)
7701       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7702      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7703 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7704 C           the respective energy moment and not to the cluster cumulant.
7705       eello_turn6=0.0d0
7706       j=i+4
7707       k=i+1
7708       l=i+3
7709       iti=itortyp(itype(i))
7710       itk=itortyp(itype(k))
7711       itk1=itortyp(itype(k+1))
7712       itl=itortyp(itype(l))
7713       itj=itortyp(itype(j))
7714 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7715 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7716 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7717 cd        eello6=0.0d0
7718 cd        return
7719 cd      endif
7720 cd      write (iout,*)
7721 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7722 cd     &   ' and',k,l
7723 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7724       do iii=1,2
7725         do kkk=1,5
7726           do lll=1,3
7727             derx_turn(lll,kkk,iii)=0.0d0
7728           enddo
7729         enddo
7730       enddo
7731 cd      eij=1.0d0
7732 cd      ekl=1.0d0
7733 cd      ekont=1.0d0
7734       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7735 cd      eello6_5=0.0d0
7736 cd      write (2,*) 'eello6_5',eello6_5
7737 #ifdef MOMENT
7738       call transpose2(AEA(1,1,1),auxmat(1,1))
7739       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7740       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7741       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7742 #else
7743       s1 = 0.0d0
7744 #endif
7745       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7746       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7747       s2 = scalar2(b1(1,itk),vtemp1(1))
7748 #ifdef MOMENT
7749       call transpose2(AEA(1,1,2),atemp(1,1))
7750       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7751       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7752       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7753 #else
7754       s8=0.0d0
7755 #endif
7756       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7757       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7758       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7759 #ifdef MOMENT
7760       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7761       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7762       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7763       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7764       ss13 = scalar2(b1(1,itk),vtemp4(1))
7765       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7766 #else
7767       s13=0.0d0
7768 #endif
7769 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7770 c      s1=0.0d0
7771 c      s2=0.0d0
7772 c      s8=0.0d0
7773 c      s12=0.0d0
7774 c      s13=0.0d0
7775       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7776       if (calc_grad) then
7777 C Derivatives in gamma(i+2)
7778 #ifdef MOMENT
7779       call transpose2(AEA(1,1,1),auxmatd(1,1))
7780       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7781       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7782       call transpose2(AEAderg(1,1,2),atempd(1,1))
7783       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7784       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7785 #else
7786       s8d=0.0d0
7787 #endif
7788       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7789       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7790       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7791 c      s1d=0.0d0
7792 c      s2d=0.0d0
7793 c      s8d=0.0d0
7794 c      s12d=0.0d0
7795 c      s13d=0.0d0
7796       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7797 C Derivatives in gamma(i+3)
7798 #ifdef MOMENT
7799       call transpose2(AEA(1,1,1),auxmatd(1,1))
7800       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7801       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7802       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7803 #else
7804       s1d=0.0d0
7805 #endif
7806       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7807       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7808       s2d = scalar2(b1(1,itk),vtemp1d(1))
7809 #ifdef MOMENT
7810       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7811       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7812 #endif
7813       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7814 #ifdef MOMENT
7815       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7816       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7817       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7818 #else
7819       s13d=0.0d0
7820 #endif
7821 c      s1d=0.0d0
7822 c      s2d=0.0d0
7823 c      s8d=0.0d0
7824 c      s12d=0.0d0
7825 c      s13d=0.0d0
7826 #ifdef MOMENT
7827       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7828      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7829 #else
7830       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7831      &               -0.5d0*ekont*(s2d+s12d)
7832 #endif
7833 C Derivatives in gamma(i+4)
7834       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7835       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7836       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7837 #ifdef MOMENT
7838       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7839       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7840       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7841 #else
7842       s13d = 0.0d0
7843 #endif
7844 c      s1d=0.0d0
7845 c      s2d=0.0d0
7846 c      s8d=0.0d0
7847 C      s12d=0.0d0
7848 c      s13d=0.0d0
7849 #ifdef MOMENT
7850       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7851 #else
7852       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7853 #endif
7854 C Derivatives in gamma(i+5)
7855 #ifdef MOMENT
7856       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7857       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7858       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7859 #else
7860       s1d = 0.0d0
7861 #endif
7862       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7863       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7864       s2d = scalar2(b1(1,itk),vtemp1d(1))
7865 #ifdef MOMENT
7866       call transpose2(AEA(1,1,2),atempd(1,1))
7867       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7868       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7869 #else
7870       s8d = 0.0d0
7871 #endif
7872       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7873       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7874 #ifdef MOMENT
7875       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7876       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7877       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7878 #else
7879       s13d = 0.0d0
7880 #endif
7881 c      s1d=0.0d0
7882 c      s2d=0.0d0
7883 c      s8d=0.0d0
7884 c      s12d=0.0d0
7885 c      s13d=0.0d0
7886 #ifdef MOMENT
7887       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7888      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7889 #else
7890       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7891      &               -0.5d0*ekont*(s2d+s12d)
7892 #endif
7893 C Cartesian derivatives
7894       do iii=1,2
7895         do kkk=1,5
7896           do lll=1,3
7897 #ifdef MOMENT
7898             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7899             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7900             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7901 #else
7902             s1d = 0.0d0
7903 #endif
7904             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7905             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7906      &          vtemp1d(1))
7907             s2d = scalar2(b1(1,itk),vtemp1d(1))
7908 #ifdef MOMENT
7909             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7910             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7911             s8d = -(atempd(1,1)+atempd(2,2))*
7912      &           scalar2(cc(1,1,itl),vtemp2(1))
7913 #else
7914             s8d = 0.0d0
7915 #endif
7916             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7917      &           auxmatd(1,1))
7918             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7919             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7920 c      s1d=0.0d0
7921 c      s2d=0.0d0
7922 c      s8d=0.0d0
7923 c      s12d=0.0d0
7924 c      s13d=0.0d0
7925 #ifdef MOMENT
7926             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7927      &        - 0.5d0*(s1d+s2d)
7928 #else
7929             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7930      &        - 0.5d0*s2d
7931 #endif
7932 #ifdef MOMENT
7933             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7934      &        - 0.5d0*(s8d+s12d)
7935 #else
7936             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7937      &        - 0.5d0*s12d
7938 #endif
7939           enddo
7940         enddo
7941       enddo
7942 #ifdef MOMENT
7943       do kkk=1,5
7944         do lll=1,3
7945           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7946      &      achuj_tempd(1,1))
7947           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7948           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7949           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7950           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7951           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7952      &      vtemp4d(1))
7953           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7954           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7955           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7956         enddo
7957       enddo
7958 #endif
7959 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7960 cd     &  16*eel_turn6_num
7961 cd      goto 1112
7962       if (j.lt.nres-1) then
7963         j1=j+1
7964         j2=j-1
7965       else
7966         j1=j-1
7967         j2=j-2
7968       endif
7969       if (l.lt.nres-1) then
7970         l1=l+1
7971         l2=l-1
7972       else
7973         l1=l-1
7974         l2=l-2
7975       endif
7976       do ll=1,3
7977         ggg1(ll)=eel_turn6*g_contij(ll,1)
7978         ggg2(ll)=eel_turn6*g_contij(ll,2)
7979         ghalf=0.5d0*ggg1(ll)
7980 cd        ghalf=0.0d0
7981         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7982      &    +ekont*derx_turn(ll,2,1)
7983         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7984         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7985      &    +ekont*derx_turn(ll,4,1)
7986         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7987         ghalf=0.5d0*ggg2(ll)
7988 cd        ghalf=0.0d0
7989         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7990      &    +ekont*derx_turn(ll,2,2)
7991         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7992         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7993      &    +ekont*derx_turn(ll,4,2)
7994         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7995       enddo
7996 cd      goto 1112
7997       do m=i+1,j-1
7998         do ll=1,3
7999           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8000         enddo
8001       enddo
8002       do m=k+1,l-1
8003         do ll=1,3
8004           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8005         enddo
8006       enddo
8007 1112  continue
8008       do m=i+2,j2
8009         do ll=1,3
8010           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8011         enddo
8012       enddo
8013       do m=k+2,l2
8014         do ll=1,3
8015           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8016         enddo
8017       enddo
8018 cd      do iii=1,nres-3
8019 cd        write (2,*) iii,g_corr6_loc(iii)
8020 cd      enddo
8021       endif
8022       eello_turn6=ekont*eel_turn6
8023 cd      write (2,*) 'ekont',ekont
8024 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8025       return
8026       end
8027 crc-------------------------------------------------
8028       SUBROUTINE MATVEC2(A1,V1,V2)
8029       implicit real*8 (a-h,o-z)
8030       include 'DIMENSIONS'
8031       DIMENSION A1(2,2),V1(2),V2(2)
8032 c      DO 1 I=1,2
8033 c        VI=0.0
8034 c        DO 3 K=1,2
8035 c    3     VI=VI+A1(I,K)*V1(K)
8036 c        Vaux(I)=VI
8037 c    1 CONTINUE
8038
8039       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8040       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8041
8042       v2(1)=vaux1
8043       v2(2)=vaux2
8044       END
8045 C---------------------------------------
8046       SUBROUTINE MATMAT2(A1,A2,A3)
8047       implicit real*8 (a-h,o-z)
8048       include 'DIMENSIONS'
8049       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8050 c      DIMENSION AI3(2,2)
8051 c        DO  J=1,2
8052 c          A3IJ=0.0
8053 c          DO K=1,2
8054 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8055 c          enddo
8056 c          A3(I,J)=A3IJ
8057 c       enddo
8058 c      enddo
8059
8060       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8061       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8062       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8063       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8064
8065       A3(1,1)=AI3_11
8066       A3(2,1)=AI3_21
8067       A3(1,2)=AI3_12
8068       A3(2,2)=AI3_22
8069       END
8070
8071 c-------------------------------------------------------------------------
8072       double precision function scalar2(u,v)
8073       implicit none
8074       double precision u(2),v(2)
8075       double precision sc
8076       integer i
8077       scalar2=u(1)*v(1)+u(2)*v(2)
8078       return
8079       end
8080
8081 C-----------------------------------------------------------------------------
8082
8083       subroutine transpose2(a,at)
8084       implicit none
8085       double precision a(2,2),at(2,2)
8086       at(1,1)=a(1,1)
8087       at(1,2)=a(2,1)
8088       at(2,1)=a(1,2)
8089       at(2,2)=a(2,2)
8090       return
8091       end
8092 c--------------------------------------------------------------------------
8093       subroutine transpose(n,a,at)
8094       implicit none
8095       integer n,i,j
8096       double precision a(n,n),at(n,n)
8097       do i=1,n
8098         do j=1,n
8099           at(j,i)=a(i,j)
8100         enddo
8101       enddo
8102       return
8103       end
8104 C---------------------------------------------------------------------------
8105       subroutine prodmat3(a1,a2,kk,transp,prod)
8106       implicit none
8107       integer i,j
8108       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8109       logical transp
8110 crc      double precision auxmat(2,2),prod_(2,2)
8111
8112       if (transp) then
8113 crc        call transpose2(kk(1,1),auxmat(1,1))
8114 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8115 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8116
8117            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8118      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8119            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8120      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8121            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8122      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8123            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8124      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8125
8126       else
8127 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8128 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8129
8130            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8131      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8132            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8133      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8134            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8135      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8136            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8137      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8138
8139       endif
8140 c      call transpose2(a2(1,1),a2t(1,1))
8141
8142 crc      print *,transp
8143 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8144 crc      print *,((prod(i,j),i=1,2),j=1,2)
8145
8146       return
8147       end
8148 C-----------------------------------------------------------------------------
8149       double precision function scalar(u,v)
8150       implicit none
8151       double precision u(3),v(3)
8152       double precision sc
8153       integer i
8154       sc=0.0d0
8155       do i=1,3
8156         sc=sc+u(i)*v(i)
8157       enddo
8158       scalar=sc
8159       return
8160       end
8161