source/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   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           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5259         enddo
5260         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5261 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5262 c     &gloc_sc(intertyp,i-3,icg)
5263         if (lprn)
5264      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5265      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5266      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5267      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5268         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5269        enddo !intertyp
5270       enddo
5271 c        do i=1,nres
5272 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5273 c        enddo
5274       return
5275       end
5276 c------------------------------------------------------------------------------
5277       subroutine multibody(ecorr)
5278 C This subroutine calculates multi-body contributions to energy following
5279 C the idea of Skolnick et al. If side chains I and J make a contact and
5280 C at the same time side chains I+1 and J+1 make a contact, an extra
5281 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5282       implicit real*8 (a-h,o-z)
5283       include 'DIMENSIONS'
5284       include 'COMMON.IOUNITS'
5285       include 'COMMON.DERIV'
5286       include 'COMMON.INTERACT'
5287       include 'COMMON.CONTACTS'
5288       double precision gx(3),gx1(3)
5289       logical lprn
5290
5291 C Set lprn=.true. for debugging
5292       lprn=.false.
5293
5294       if (lprn) then
5295         write (iout,'(a)') 'Contact function values:'
5296         do i=nnt,nct-2
5297           write (iout,'(i2,20(1x,i2,f10.5))')
5298      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5299         enddo
5300       endif
5301       ecorr=0.0D0
5302       do i=nnt,nct
5303         do j=1,3
5304           gradcorr(j,i)=0.0D0
5305           gradxorr(j,i)=0.0D0
5306         enddo
5307       enddo
5308       do i=nnt,nct-2
5309
5310         DO ISHIFT = 3,4
5311
5312         i1=i+ishift
5313         num_conti=num_cont(i)
5314         num_conti1=num_cont(i1)
5315         do jj=1,num_conti
5316           j=jcont(jj,i)
5317           do kk=1,num_conti1
5318             j1=jcont(kk,i1)
5319             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5320 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5321 cd   &                   ' ishift=',ishift
5322 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5323 C The system gains extra energy.
5324               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5325             endif   ! j1==j+-ishift
5326           enddo     ! kk
5327         enddo       ! jj
5328
5329         ENDDO ! ISHIFT
5330
5331       enddo         ! i
5332       return
5333       end
5334 c------------------------------------------------------------------------------
5335       double precision function esccorr(i,j,k,l,jj,kk)
5336       implicit real*8 (a-h,o-z)
5337       include 'DIMENSIONS'
5338       include 'COMMON.IOUNITS'
5339       include 'COMMON.DERIV'
5340       include 'COMMON.INTERACT'
5341       include 'COMMON.CONTACTS'
5342       double precision gx(3),gx1(3)
5343       logical lprn
5344       lprn=.false.
5345       eij=facont(jj,i)
5346       ekl=facont(kk,k)
5347 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5348 C Calculate the multi-body contribution to energy.
5349 C Calculate multi-body contributions to the gradient.
5350 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5351 cd   & k,l,(gacont(m,kk,k),m=1,3)
5352       do m=1,3
5353         gx(m) =ekl*gacont(m,jj,i)
5354         gx1(m)=eij*gacont(m,kk,k)
5355         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5356         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5357         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5358         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5359       enddo
5360       do m=i,j-1
5361         do ll=1,3
5362           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5363         enddo
5364       enddo
5365       do m=k,l-1
5366         do ll=1,3
5367           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5368         enddo
5369       enddo
5370       esccorr=-eij*ekl
5371       return
5372       end
5373 c------------------------------------------------------------------------------
5374 #ifdef MPL
5375       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5376       implicit real*8 (a-h,o-z)
5377       include 'DIMENSIONS'
5378       integer dimen1,dimen2,atom,indx
5379       double precision buffer(dimen1,dimen2)
5380       double precision zapas
5381       common /contacts_hb/ zapas(3,20,maxres,7),
5382      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5383      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5384       num_kont=num_cont_hb(atom)
5385       do i=1,num_kont
5386         do k=1,7
5387           do j=1,3
5388             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5389           enddo ! j
5390         enddo ! k
5391         buffer(i,indx+22)=facont_hb(i,atom)
5392         buffer(i,indx+23)=ees0p(i,atom)
5393         buffer(i,indx+24)=ees0m(i,atom)
5394         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5395       enddo ! i
5396       buffer(1,indx+26)=dfloat(num_kont)
5397       return
5398       end
5399 c------------------------------------------------------------------------------
5400       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5401       implicit real*8 (a-h,o-z)
5402       include 'DIMENSIONS'
5403       integer dimen1,dimen2,atom,indx
5404       double precision buffer(dimen1,dimen2)
5405       double precision zapas
5406       common /contacts_hb/ zapas(3,20,maxres,7),
5407      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5408      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5409       num_kont=buffer(1,indx+26)
5410       num_kont_old=num_cont_hb(atom)
5411       num_cont_hb(atom)=num_kont+num_kont_old
5412       do i=1,num_kont
5413         ii=i+num_kont_old
5414         do k=1,7
5415           do j=1,3
5416             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5417           enddo ! j
5418         enddo ! k
5419         facont_hb(ii,atom)=buffer(i,indx+22)
5420         ees0p(ii,atom)=buffer(i,indx+23)
5421         ees0m(ii,atom)=buffer(i,indx+24)
5422         jcont_hb(ii,atom)=buffer(i,indx+25)
5423       enddo ! i
5424       return
5425       end
5426 c------------------------------------------------------------------------------
5427 #endif
5428       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5429 C This subroutine calculates multi-body contributions to hydrogen-bonding
5430       implicit real*8 (a-h,o-z)
5431       include 'DIMENSIONS'
5432       include 'DIMENSIONS.ZSCOPT'
5433       include 'COMMON.IOUNITS'
5434 #ifdef MPL
5435       include 'COMMON.INFO'
5436 #endif
5437       include 'COMMON.FFIELD'
5438       include 'COMMON.DERIV'
5439       include 'COMMON.INTERACT'
5440       include 'COMMON.CONTACTS'
5441 #ifdef MPL
5442       parameter (max_cont=maxconts)
5443       parameter (max_dim=2*(8*3+2))
5444       parameter (msglen1=max_cont*max_dim*4)
5445       parameter (msglen2=2*msglen1)
5446       integer source,CorrelType,CorrelID,Error
5447       double precision buffer(max_cont,max_dim)
5448 #endif
5449       double precision gx(3),gx1(3)
5450       logical lprn,ldone
5451
5452 C Set lprn=.true. for debugging
5453       lprn=.false.
5454 #ifdef MPL
5455       n_corr=0
5456       n_corr1=0
5457       if (fgProcs.le.1) goto 30
5458       if (lprn) then
5459         write (iout,'(a)') 'Contact function values:'
5460         do i=nnt,nct-2
5461           write (iout,'(2i3,50(1x,i2,f5.2))')
5462      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5463      &    j=1,num_cont_hb(i))
5464         enddo
5465       endif
5466 C Caution! Following code assumes that electrostatic interactions concerning
5467 C a given atom are split among at most two processors!
5468       CorrelType=477
5469       CorrelID=MyID+1
5470       ldone=.false.
5471       do i=1,max_cont
5472         do j=1,max_dim
5473           buffer(i,j)=0.0D0
5474         enddo
5475       enddo
5476       mm=mod(MyRank,2)
5477 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5478       if (mm) 20,20,10
5479    10 continue
5480 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5481       if (MyRank.gt.0) then
5482 C Send correlation contributions to the preceding processor
5483         msglen=msglen1
5484         nn=num_cont_hb(iatel_s)
5485         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5486 cd      write (iout,*) 'The BUFFER array:'
5487 cd      do i=1,nn
5488 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5489 cd      enddo
5490         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5491           msglen=msglen2
5492             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5493 C Clear the contacts of the atom passed to the neighboring processor
5494         nn=num_cont_hb(iatel_s+1)
5495 cd      do i=1,nn
5496 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5497 cd      enddo
5498             num_cont_hb(iatel_s)=0
5499         endif
5500 cd      write (iout,*) 'Processor ',MyID,MyRank,
5501 cd   & ' is sending correlation contribution to processor',MyID-1,
5502 cd   & ' msglen=',msglen
5503 cd      write (*,*) 'Processor ',MyID,MyRank,
5504 cd   & ' is sending correlation contribution to processor',MyID-1,
5505 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5506         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5507 cd      write (iout,*) 'Processor ',MyID,
5508 cd   & ' has sent correlation contribution to processor',MyID-1,
5509 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5510 cd      write (*,*) 'Processor ',MyID,
5511 cd   & ' has sent correlation contribution to processor',MyID-1,
5512 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5513         msglen=msglen1
5514       endif ! (MyRank.gt.0)
5515       if (ldone) goto 30
5516       ldone=.true.
5517    20 continue
5518 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5519       if (MyRank.lt.fgProcs-1) then
5520 C Receive correlation contributions from the next processor
5521         msglen=msglen1
5522         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5523 cd      write (iout,*) 'Processor',MyID,
5524 cd   & ' is receiving correlation contribution from processor',MyID+1,
5525 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5526 cd      write (*,*) 'Processor',MyID,
5527 cd   & ' is receiving correlation contribution from processor',MyID+1,
5528 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5529         nbytes=-1
5530         do while (nbytes.le.0)
5531           call mp_probe(MyID+1,CorrelType,nbytes)
5532         enddo
5533 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5534         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5535 cd      write (iout,*) 'Processor',MyID,
5536 cd   & ' has received correlation contribution from processor',MyID+1,
5537 cd   & ' msglen=',msglen,' nbytes=',nbytes
5538 cd      write (iout,*) 'The received BUFFER array:'
5539 cd      do i=1,max_cont
5540 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5541 cd      enddo
5542         if (msglen.eq.msglen1) then
5543           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5544         else if (msglen.eq.msglen2)  then
5545           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5546           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5547         else
5548           write (iout,*)
5549      & 'ERROR!!!! message length changed while processing correlations.'
5550           write (*,*)
5551      & 'ERROR!!!! message length changed while processing correlations.'
5552           call mp_stopall(Error)
5553         endif ! msglen.eq.msglen1
5554       endif ! MyRank.lt.fgProcs-1
5555       if (ldone) goto 30
5556       ldone=.true.
5557       goto 10
5558    30 continue
5559 #endif
5560       if (lprn) then
5561         write (iout,'(a)') 'Contact function values:'
5562         do i=nnt,nct-2
5563           write (iout,'(2i3,50(1x,i2,f5.2))')
5564      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5565      &    j=1,num_cont_hb(i))
5566         enddo
5567       endif
5568       ecorr=0.0D0
5569 C Remove the loop below after debugging !!!
5570       do i=nnt,nct
5571         do j=1,3
5572           gradcorr(j,i)=0.0D0
5573           gradxorr(j,i)=0.0D0
5574         enddo
5575       enddo
5576 C Calculate the local-electrostatic correlation terms
5577       do i=iatel_s,iatel_e+1
5578         i1=i+1
5579         num_conti=num_cont_hb(i)
5580         num_conti1=num_cont_hb(i+1)
5581         do jj=1,num_conti
5582           j=jcont_hb(jj,i)
5583           do kk=1,num_conti1
5584             j1=jcont_hb(kk,i1)
5585 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5586 c     &         ' jj=',jj,' kk=',kk
5587             if (j1.eq.j+1 .or. j1.eq.j-1) then
5588 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5589 C The system gains extra energy.
5590               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5591               n_corr=n_corr+1
5592             else if (j1.eq.j) then
5593 C Contacts I-J and I-(J+1) occur simultaneously.
5594 C The system loses extra energy.
5595 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5596             endif
5597           enddo ! kk
5598           do kk=1,num_conti
5599             j1=jcont_hb(kk,i)
5600 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5601 c    &         ' jj=',jj,' kk=',kk
5602             if (j1.eq.j+1) then
5603 C Contacts I-J and (I+1)-J occur simultaneously.
5604 C The system loses extra energy.
5605 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5606             endif ! j1==j+1
5607           enddo ! kk
5608         enddo ! jj
5609       enddo ! i
5610       return
5611       end
5612 c------------------------------------------------------------------------------
5613       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5614      &  n_corr1)
5615 C This subroutine calculates multi-body contributions to hydrogen-bonding
5616       implicit real*8 (a-h,o-z)
5617       include 'DIMENSIONS'
5618       include 'DIMENSIONS.ZSCOPT'
5619       include 'COMMON.IOUNITS'
5620 #ifdef MPL
5621       include 'COMMON.INFO'
5622 #endif
5623       include 'COMMON.FFIELD'
5624       include 'COMMON.DERIV'
5625       include 'COMMON.INTERACT'
5626       include 'COMMON.CONTACTS'
5627 #ifdef MPL
5628       parameter (max_cont=maxconts)
5629       parameter (max_dim=2*(8*3+2))
5630       parameter (msglen1=max_cont*max_dim*4)
5631       parameter (msglen2=2*msglen1)
5632       integer source,CorrelType,CorrelID,Error
5633       double precision buffer(max_cont,max_dim)
5634 #endif
5635       double precision gx(3),gx1(3)
5636       logical lprn,ldone
5637
5638 C Set lprn=.true. for debugging
5639       lprn=.false.
5640       eturn6=0.0d0
5641 #ifdef MPL
5642       n_corr=0
5643       n_corr1=0
5644       if (fgProcs.le.1) goto 30
5645       if (lprn) then
5646         write (iout,'(a)') 'Contact function values:'
5647         do i=nnt,nct-2
5648           write (iout,'(2i3,50(1x,i2,f5.2))')
5649      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5650      &    j=1,num_cont_hb(i))
5651         enddo
5652       endif
5653 C Caution! Following code assumes that electrostatic interactions concerning
5654 C a given atom are split among at most two processors!
5655       CorrelType=477
5656       CorrelID=MyID+1
5657       ldone=.false.
5658       do i=1,max_cont
5659         do j=1,max_dim
5660           buffer(i,j)=0.0D0
5661         enddo
5662       enddo
5663       mm=mod(MyRank,2)
5664 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5665       if (mm) 20,20,10
5666    10 continue
5667 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5668       if (MyRank.gt.0) then
5669 C Send correlation contributions to the preceding processor
5670         msglen=msglen1
5671         nn=num_cont_hb(iatel_s)
5672         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5673 cd      write (iout,*) 'The BUFFER array:'
5674 cd      do i=1,nn
5675 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5676 cd      enddo
5677         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5678           msglen=msglen2
5679             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5680 C Clear the contacts of the atom passed to the neighboring processor
5681         nn=num_cont_hb(iatel_s+1)
5682 cd      do i=1,nn
5683 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5684 cd      enddo
5685             num_cont_hb(iatel_s)=0
5686         endif
5687 cd      write (iout,*) 'Processor ',MyID,MyRank,
5688 cd   & ' is sending correlation contribution to processor',MyID-1,
5689 cd   & ' msglen=',msglen
5690 cd      write (*,*) 'Processor ',MyID,MyRank,
5691 cd   & ' is sending correlation contribution to processor',MyID-1,
5692 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5693         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5694 cd      write (iout,*) 'Processor ',MyID,
5695 cd   & ' has sent correlation contribution to processor',MyID-1,
5696 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5697 cd      write (*,*) 'Processor ',MyID,
5698 cd   & ' has sent correlation contribution to processor',MyID-1,
5699 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5700         msglen=msglen1
5701       endif ! (MyRank.gt.0)
5702       if (ldone) goto 30
5703       ldone=.true.
5704    20 continue
5705 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5706       if (MyRank.lt.fgProcs-1) then
5707 C Receive correlation contributions from the next processor
5708         msglen=msglen1
5709         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5710 cd      write (iout,*) 'Processor',MyID,
5711 cd   & ' is receiving correlation contribution from processor',MyID+1,
5712 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5713 cd      write (*,*) 'Processor',MyID,
5714 cd   & ' is receiving correlation contribution from processor',MyID+1,
5715 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5716         nbytes=-1
5717         do while (nbytes.le.0)
5718           call mp_probe(MyID+1,CorrelType,nbytes)
5719         enddo
5720 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5721         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5722 cd      write (iout,*) 'Processor',MyID,
5723 cd   & ' has received correlation contribution from processor',MyID+1,
5724 cd   & ' msglen=',msglen,' nbytes=',nbytes
5725 cd      write (iout,*) 'The received BUFFER array:'
5726 cd      do i=1,max_cont
5727 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5728 cd      enddo
5729         if (msglen.eq.msglen1) then
5730           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5731         else if (msglen.eq.msglen2)  then
5732           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5733           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5734         else
5735           write (iout,*)
5736      & 'ERROR!!!! message length changed while processing correlations.'
5737           write (*,*)
5738      & 'ERROR!!!! message length changed while processing correlations.'
5739           call mp_stopall(Error)
5740         endif ! msglen.eq.msglen1
5741       endif ! MyRank.lt.fgProcs-1
5742       if (ldone) goto 30
5743       ldone=.true.
5744       goto 10
5745    30 continue
5746 #endif
5747       if (lprn) then
5748         write (iout,'(a)') 'Contact function values:'
5749         do i=nnt,nct-2
5750           write (iout,'(2i3,50(1x,i2,f5.2))')
5751      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5752      &    j=1,num_cont_hb(i))
5753         enddo
5754       endif
5755       ecorr=0.0D0
5756       ecorr5=0.0d0
5757       ecorr6=0.0d0
5758 C Remove the loop below after debugging !!!
5759       do i=nnt,nct
5760         do j=1,3
5761           gradcorr(j,i)=0.0D0
5762           gradxorr(j,i)=0.0D0
5763         enddo
5764       enddo
5765 C Calculate the dipole-dipole interaction energies
5766       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5767       do i=iatel_s,iatel_e+1
5768         num_conti=num_cont_hb(i)
5769         do jj=1,num_conti
5770           j=jcont_hb(jj,i)
5771           call dipole(i,j,jj)
5772         enddo
5773       enddo
5774       endif
5775 C Calculate the local-electrostatic correlation terms
5776       do i=iatel_s,iatel_e+1
5777         i1=i+1
5778         num_conti=num_cont_hb(i)
5779         num_conti1=num_cont_hb(i+1)
5780         do jj=1,num_conti
5781           j=jcont_hb(jj,i)
5782           do kk=1,num_conti1
5783             j1=jcont_hb(kk,i1)
5784 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5785 c     &         ' jj=',jj,' kk=',kk
5786             if (j1.eq.j+1 .or. j1.eq.j-1) then
5787 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5788 C The system gains extra energy.
5789               n_corr=n_corr+1
5790               sqd1=dsqrt(d_cont(jj,i))
5791               sqd2=dsqrt(d_cont(kk,i1))
5792               sred_geom = sqd1*sqd2
5793               IF (sred_geom.lt.cutoff_corr) THEN
5794                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5795      &            ekont,fprimcont)
5796 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5797 c     &         ' jj=',jj,' kk=',kk
5798                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5799                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5800                 do l=1,3
5801                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5802                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5803                 enddo
5804                 n_corr1=n_corr1+1
5805 cd               write (iout,*) 'sred_geom=',sred_geom,
5806 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5807                 call calc_eello(i,j,i+1,j1,jj,kk)
5808                 if (wcorr4.gt.0.0d0)
5809      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5810                 if (wcorr5.gt.0.0d0)
5811      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5812 c                print *,"wcorr5",ecorr5
5813 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5814 cd                write(2,*)'ijkl',i,j,i+1,j1
5815                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5816      &               .or. wturn6.eq.0.0d0))then
5817 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5818                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5819 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5820 cd     &            'ecorr6=',ecorr6
5821 cd                write (iout,'(4e15.5)') sred_geom,
5822 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5823 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5824 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5825                 else if (wturn6.gt.0.0d0
5826      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5827 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5828                   eturn6=eturn6+eello_turn6(i,jj,kk)
5829 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5830                 endif
5831               ENDIF
5832 1111          continue
5833             else if (j1.eq.j) then
5834 C Contacts I-J and I-(J+1) occur simultaneously.
5835 C The system loses extra energy.
5836 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5837             endif
5838           enddo ! kk
5839           do kk=1,num_conti
5840             j1=jcont_hb(kk,i)
5841 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5842 c    &         ' jj=',jj,' kk=',kk
5843             if (j1.eq.j+1) then
5844 C Contacts I-J and (I+1)-J occur simultaneously.
5845 C The system loses extra energy.
5846 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5847             endif ! j1==j+1
5848           enddo ! kk
5849         enddo ! jj
5850       enddo ! i
5851       return
5852       end
5853 c------------------------------------------------------------------------------
5854       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5855       implicit real*8 (a-h,o-z)
5856       include 'DIMENSIONS'
5857       include 'COMMON.IOUNITS'
5858       include 'COMMON.DERIV'
5859       include 'COMMON.INTERACT'
5860       include 'COMMON.CONTACTS'
5861       double precision gx(3),gx1(3)
5862       logical lprn
5863       lprn=.false.
5864       eij=facont_hb(jj,i)
5865       ekl=facont_hb(kk,k)
5866       ees0pij=ees0p(jj,i)
5867       ees0pkl=ees0p(kk,k)
5868       ees0mij=ees0m(jj,i)
5869       ees0mkl=ees0m(kk,k)
5870       ekont=eij*ekl
5871       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5872 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5873 C Following 4 lines for diagnostics.
5874 cd    ees0pkl=0.0D0
5875 cd    ees0pij=1.0D0
5876 cd    ees0mkl=0.0D0
5877 cd    ees0mij=1.0D0
5878 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5879 c    &   ' and',k,l
5880 c     write (iout,*)'Contacts have occurred for peptide groups',
5881 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5882 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5883 C Calculate the multi-body contribution to energy.
5884       ecorr=ecorr+ekont*ees
5885       if (calc_grad) then
5886 C Calculate multi-body contributions to the gradient.
5887       do ll=1,3
5888         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5889         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5890      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5891      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5892         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5893      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5894      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5895         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5896         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5897      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5898      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5899         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5900      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5901      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5902       enddo
5903       do m=i+1,j-1
5904         do ll=1,3
5905           gradcorr(ll,m)=gradcorr(ll,m)+
5906      &     ees*ekl*gacont_hbr(ll,jj,i)-
5907      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5908      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5909         enddo
5910       enddo
5911       do m=k+1,l-1
5912         do ll=1,3
5913           gradcorr(ll,m)=gradcorr(ll,m)+
5914      &     ees*eij*gacont_hbr(ll,kk,k)-
5915      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5916      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5917         enddo
5918       enddo
5919       endif
5920       ehbcorr=ekont*ees
5921       return
5922       end
5923 C---------------------------------------------------------------------------
5924       subroutine dipole(i,j,jj)
5925       implicit real*8 (a-h,o-z)
5926       include 'DIMENSIONS'
5927       include 'DIMENSIONS.ZSCOPT'
5928       include 'COMMON.IOUNITS'
5929       include 'COMMON.CHAIN'
5930       include 'COMMON.FFIELD'
5931       include 'COMMON.DERIV'
5932       include 'COMMON.INTERACT'
5933       include 'COMMON.CONTACTS'
5934       include 'COMMON.TORSION'
5935       include 'COMMON.VAR'
5936       include 'COMMON.GEO'
5937       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5938      &  auxmat(2,2)
5939       iti1 = itortyp(itype(i+1))
5940       if (j.lt.nres-1) then
5941         itj1 = itortyp(itype(j+1))
5942       else
5943         itj1=ntortyp+1
5944       endif
5945       do iii=1,2
5946         dipi(iii,1)=Ub2(iii,i)
5947         dipderi(iii)=Ub2der(iii,i)
5948         dipi(iii,2)=b1(iii,iti1)
5949         dipj(iii,1)=Ub2(iii,j)
5950         dipderj(iii)=Ub2der(iii,j)
5951         dipj(iii,2)=b1(iii,itj1)
5952       enddo
5953       kkk=0
5954       do iii=1,2
5955         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5956         do jjj=1,2
5957           kkk=kkk+1
5958           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5959         enddo
5960       enddo
5961       if (.not.calc_grad) return
5962       do kkk=1,5
5963         do lll=1,3
5964           mmm=0
5965           do iii=1,2
5966             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5967      &        auxvec(1))
5968             do jjj=1,2
5969               mmm=mmm+1
5970               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5971             enddo
5972           enddo
5973         enddo
5974       enddo
5975       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5976       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5977       do iii=1,2
5978         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5979       enddo
5980       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5981       do iii=1,2
5982         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5983       enddo
5984       return
5985       end
5986 C---------------------------------------------------------------------------
5987       subroutine calc_eello(i,j,k,l,jj,kk)
5988 C
5989 C This subroutine computes matrices and vectors needed to calculate
5990 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5991 C
5992       implicit real*8 (a-h,o-z)
5993       include 'DIMENSIONS'
5994       include 'DIMENSIONS.ZSCOPT'
5995       include 'COMMON.IOUNITS'
5996       include 'COMMON.CHAIN'
5997       include 'COMMON.DERIV'
5998       include 'COMMON.INTERACT'
5999       include 'COMMON.CONTACTS'
6000       include 'COMMON.TORSION'
6001       include 'COMMON.VAR'
6002       include 'COMMON.GEO'
6003       include 'COMMON.FFIELD'
6004       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6005      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6006       logical lprn
6007       common /kutas/ lprn
6008 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6009 cd     & ' jj=',jj,' kk=',kk
6010 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6011       do iii=1,2
6012         do jjj=1,2
6013           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6014           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6015         enddo
6016       enddo
6017       call transpose2(aa1(1,1),aa1t(1,1))
6018       call transpose2(aa2(1,1),aa2t(1,1))
6019       do kkk=1,5
6020         do lll=1,3
6021           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6022      &      aa1tder(1,1,lll,kkk))
6023           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6024      &      aa2tder(1,1,lll,kkk))
6025         enddo
6026       enddo
6027       if (l.eq.j+1) then
6028 C parallel orientation of the two CA-CA-CA frames.
6029         if (i.gt.1) then
6030           iti=itortyp(itype(i))
6031         else
6032           iti=ntortyp+1
6033         endif
6034         itk1=itortyp(itype(k+1))
6035         itj=itortyp(itype(j))
6036         if (l.lt.nres-1) then
6037           itl1=itortyp(itype(l+1))
6038         else
6039           itl1=ntortyp+1
6040         endif
6041 C A1 kernel(j+1) A2T
6042 cd        do iii=1,2
6043 cd          write (iout,'(3f10.5,5x,3f10.5)')
6044 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6045 cd        enddo
6046         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6047      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6048      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6049 C Following matrices are needed only for 6-th order cumulants
6050         IF (wcorr6.gt.0.0d0) THEN
6051         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6052      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6053      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6054         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6055      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6056      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6057      &   ADtEAderx(1,1,1,1,1,1))
6058         lprn=.false.
6059         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6060      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6061      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6062      &   ADtEA1derx(1,1,1,1,1,1))
6063         ENDIF
6064 C End 6-th order cumulants
6065 cd        lprn=.false.
6066 cd        if (lprn) then
6067 cd        write (2,*) 'In calc_eello6'
6068 cd        do iii=1,2
6069 cd          write (2,*) 'iii=',iii
6070 cd          do kkk=1,5
6071 cd            write (2,*) 'kkk=',kkk
6072 cd            do jjj=1,2
6073 cd              write (2,'(3(2f10.5),5x)')
6074 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6075 cd            enddo
6076 cd          enddo
6077 cd        enddo
6078 cd        endif
6079         call transpose2(EUgder(1,1,k),auxmat(1,1))
6080         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6081         call transpose2(EUg(1,1,k),auxmat(1,1))
6082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6083         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6084         do iii=1,2
6085           do kkk=1,5
6086             do lll=1,3
6087               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6088      &          EAEAderx(1,1,lll,kkk,iii,1))
6089             enddo
6090           enddo
6091         enddo
6092 C A1T kernel(i+1) A2
6093         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6094      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6095      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6096 C Following matrices are needed only for 6-th order cumulants
6097         IF (wcorr6.gt.0.0d0) THEN
6098         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6099      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6100      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6101         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6102      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6103      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6104      &   ADtEAderx(1,1,1,1,1,2))
6105         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6106      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6107      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6108      &   ADtEA1derx(1,1,1,1,1,2))
6109         ENDIF
6110 C End 6-th order cumulants
6111         call transpose2(EUgder(1,1,l),auxmat(1,1))
6112         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6113         call transpose2(EUg(1,1,l),auxmat(1,1))
6114         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6115         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6116         do iii=1,2
6117           do kkk=1,5
6118             do lll=1,3
6119               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6120      &          EAEAderx(1,1,lll,kkk,iii,2))
6121             enddo
6122           enddo
6123         enddo
6124 C AEAb1 and AEAb2
6125 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6126 C They are needed only when the fifth- or the sixth-order cumulants are
6127 C indluded.
6128         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6129         call transpose2(AEA(1,1,1),auxmat(1,1))
6130         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6131         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6132         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6133         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6134         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6135         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6136         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6137         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6138         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6139         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6140         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6141         call transpose2(AEA(1,1,2),auxmat(1,1))
6142         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6143         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6144         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6145         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6146         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6147         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6148         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6149         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6150         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6151         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6152         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6153 C Calculate the Cartesian derivatives of the vectors.
6154         do iii=1,2
6155           do kkk=1,5
6156             do lll=1,3
6157               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6158               call matvec2(auxmat(1,1),b1(1,iti),
6159      &          AEAb1derx(1,lll,kkk,iii,1,1))
6160               call matvec2(auxmat(1,1),Ub2(1,i),
6161      &          AEAb2derx(1,lll,kkk,iii,1,1))
6162               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6163      &          AEAb1derx(1,lll,kkk,iii,2,1))
6164               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6165      &          AEAb2derx(1,lll,kkk,iii,2,1))
6166               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6167               call matvec2(auxmat(1,1),b1(1,itj),
6168      &          AEAb1derx(1,lll,kkk,iii,1,2))
6169               call matvec2(auxmat(1,1),Ub2(1,j),
6170      &          AEAb2derx(1,lll,kkk,iii,1,2))
6171               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6172      &          AEAb1derx(1,lll,kkk,iii,2,2))
6173               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6174      &          AEAb2derx(1,lll,kkk,iii,2,2))
6175             enddo
6176           enddo
6177         enddo
6178         ENDIF
6179 C End vectors
6180       else
6181 C Antiparallel orientation of the two CA-CA-CA frames.
6182         if (i.gt.1) then
6183           iti=itortyp(itype(i))
6184         else
6185           iti=ntortyp+1
6186         endif
6187         itk1=itortyp(itype(k+1))
6188         itl=itortyp(itype(l))
6189         itj=itortyp(itype(j))
6190         if (j.lt.nres-1) then
6191           itj1=itortyp(itype(j+1))
6192         else
6193           itj1=ntortyp+1
6194         endif
6195 C A2 kernel(j-1)T A1T
6196         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6197      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6198      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6199 C Following matrices are needed only for 6-th order cumulants
6200         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6201      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6202         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6203      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6204      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6205         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6206      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6207      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6208      &   ADtEAderx(1,1,1,1,1,1))
6209         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6210      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6211      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6212      &   ADtEA1derx(1,1,1,1,1,1))
6213         ENDIF
6214 C End 6-th order cumulants
6215         call transpose2(EUgder(1,1,k),auxmat(1,1))
6216         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6217         call transpose2(EUg(1,1,k),auxmat(1,1))
6218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6219         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6220         do iii=1,2
6221           do kkk=1,5
6222             do lll=1,3
6223               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6224      &          EAEAderx(1,1,lll,kkk,iii,1))
6225             enddo
6226           enddo
6227         enddo
6228 C A2T kernel(i+1)T A1
6229         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6230      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6231      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6232 C Following matrices are needed only for 6-th order cumulants
6233         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6234      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6235         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6236      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6237      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6238         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6239      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6240      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6241      &   ADtEAderx(1,1,1,1,1,2))
6242         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6243      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6244      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6245      &   ADtEA1derx(1,1,1,1,1,2))
6246         ENDIF
6247 C End 6-th order cumulants
6248         call transpose2(EUgder(1,1,j),auxmat(1,1))
6249         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6250         call transpose2(EUg(1,1,j),auxmat(1,1))
6251         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6252         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6253         do iii=1,2
6254           do kkk=1,5
6255             do lll=1,3
6256               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6257      &          EAEAderx(1,1,lll,kkk,iii,2))
6258             enddo
6259           enddo
6260         enddo
6261 C AEAb1 and AEAb2
6262 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6263 C They are needed only when the fifth- or the sixth-order cumulants are
6264 C indluded.
6265         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6266      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6267         call transpose2(AEA(1,1,1),auxmat(1,1))
6268         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6269         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6270         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6271         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6272         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6273         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6274         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6275         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6276         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6277         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6278         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6279         call transpose2(AEA(1,1,2),auxmat(1,1))
6280         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6281         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6282         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6283         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6284         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6285         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6286         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6287         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6288         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6289         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6290         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6291 C Calculate the Cartesian derivatives of the vectors.
6292         do iii=1,2
6293           do kkk=1,5
6294             do lll=1,3
6295               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6296               call matvec2(auxmat(1,1),b1(1,iti),
6297      &          AEAb1derx(1,lll,kkk,iii,1,1))
6298               call matvec2(auxmat(1,1),Ub2(1,i),
6299      &          AEAb2derx(1,lll,kkk,iii,1,1))
6300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6301      &          AEAb1derx(1,lll,kkk,iii,2,1))
6302               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6303      &          AEAb2derx(1,lll,kkk,iii,2,1))
6304               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6305               call matvec2(auxmat(1,1),b1(1,itl),
6306      &          AEAb1derx(1,lll,kkk,iii,1,2))
6307               call matvec2(auxmat(1,1),Ub2(1,l),
6308      &          AEAb2derx(1,lll,kkk,iii,1,2))
6309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6310      &          AEAb1derx(1,lll,kkk,iii,2,2))
6311               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6312      &          AEAb2derx(1,lll,kkk,iii,2,2))
6313             enddo
6314           enddo
6315         enddo
6316         ENDIF
6317 C End vectors
6318       endif
6319       return
6320       end
6321 C---------------------------------------------------------------------------
6322       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6323      &  KK,KKderg,AKA,AKAderg,AKAderx)
6324       implicit none
6325       integer nderg
6326       logical transp
6327       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6328      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6329      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6330       integer iii,kkk,lll
6331       integer jjj,mmm
6332       logical lprn
6333       common /kutas/ lprn
6334       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6335       do iii=1,nderg
6336         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6337      &    AKAderg(1,1,iii))
6338       enddo
6339 cd      if (lprn) write (2,*) 'In kernel'
6340       do kkk=1,5
6341 cd        if (lprn) write (2,*) 'kkk=',kkk
6342         do lll=1,3
6343           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6344      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6345 cd          if (lprn) then
6346 cd            write (2,*) 'lll=',lll
6347 cd            write (2,*) 'iii=1'
6348 cd            do jjj=1,2
6349 cd              write (2,'(3(2f10.5),5x)')
6350 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6351 cd            enddo
6352 cd          endif
6353           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6354      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6355 cd          if (lprn) then
6356 cd            write (2,*) 'lll=',lll
6357 cd            write (2,*) 'iii=2'
6358 cd            do jjj=1,2
6359 cd              write (2,'(3(2f10.5),5x)')
6360 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6361 cd            enddo
6362 cd          endif
6363         enddo
6364       enddo
6365       return
6366       end
6367 C---------------------------------------------------------------------------
6368       double precision function eello4(i,j,k,l,jj,kk)
6369       implicit real*8 (a-h,o-z)
6370       include 'DIMENSIONS'
6371       include 'DIMENSIONS.ZSCOPT'
6372       include 'COMMON.IOUNITS'
6373       include 'COMMON.CHAIN'
6374       include 'COMMON.DERIV'
6375       include 'COMMON.INTERACT'
6376       include 'COMMON.CONTACTS'
6377       include 'COMMON.TORSION'
6378       include 'COMMON.VAR'
6379       include 'COMMON.GEO'
6380       double precision pizda(2,2),ggg1(3),ggg2(3)
6381 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6382 cd        eello4=0.0d0
6383 cd        return
6384 cd      endif
6385 cd      print *,'eello4:',i,j,k,l,jj,kk
6386 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6387 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6388 cold      eij=facont_hb(jj,i)
6389 cold      ekl=facont_hb(kk,k)
6390 cold      ekont=eij*ekl
6391       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6392       if (calc_grad) then
6393 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6394       gcorr_loc(k-1)=gcorr_loc(k-1)
6395      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6396       if (l.eq.j+1) then
6397         gcorr_loc(l-1)=gcorr_loc(l-1)
6398      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6399       else
6400         gcorr_loc(j-1)=gcorr_loc(j-1)
6401      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6402       endif
6403       do iii=1,2
6404         do kkk=1,5
6405           do lll=1,3
6406             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6407      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6408 cd            derx(lll,kkk,iii)=0.0d0
6409           enddo
6410         enddo
6411       enddo
6412 cd      gcorr_loc(l-1)=0.0d0
6413 cd      gcorr_loc(j-1)=0.0d0
6414 cd      gcorr_loc(k-1)=0.0d0
6415 cd      eel4=1.0d0
6416 cd      write (iout,*)'Contacts have occurred for peptide groups',
6417 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6418 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6419       if (j.lt.nres-1) then
6420         j1=j+1
6421         j2=j-1
6422       else
6423         j1=j-1
6424         j2=j-2
6425       endif
6426       if (l.lt.nres-1) then
6427         l1=l+1
6428         l2=l-1
6429       else
6430         l1=l-1
6431         l2=l-2
6432       endif
6433       do ll=1,3
6434 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6435         ggg1(ll)=eel4*g_contij(ll,1)
6436         ggg2(ll)=eel4*g_contij(ll,2)
6437         ghalf=0.5d0*ggg1(ll)
6438 cd        ghalf=0.0d0
6439         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6440         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6441         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6442         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6443 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6444         ghalf=0.5d0*ggg2(ll)
6445 cd        ghalf=0.0d0
6446         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6447         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6448         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6449         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6450       enddo
6451 cd      goto 1112
6452       do m=i+1,j-1
6453         do ll=1,3
6454 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6455           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6456         enddo
6457       enddo
6458       do m=k+1,l-1
6459         do ll=1,3
6460 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6461           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6462         enddo
6463       enddo
6464 1112  continue
6465       do m=i+2,j2
6466         do ll=1,3
6467           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6468         enddo
6469       enddo
6470       do m=k+2,l2
6471         do ll=1,3
6472           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6473         enddo
6474       enddo
6475 cd      do iii=1,nres-3
6476 cd        write (2,*) iii,gcorr_loc(iii)
6477 cd      enddo
6478       endif
6479       eello4=ekont*eel4
6480 cd      write (2,*) 'ekont',ekont
6481 cd      write (iout,*) 'eello4',ekont*eel4
6482       return
6483       end
6484 C---------------------------------------------------------------------------
6485       double precision function eello5(i,j,k,l,jj,kk)
6486       implicit real*8 (a-h,o-z)
6487       include 'DIMENSIONS'
6488       include 'DIMENSIONS.ZSCOPT'
6489       include 'COMMON.IOUNITS'
6490       include 'COMMON.CHAIN'
6491       include 'COMMON.DERIV'
6492       include 'COMMON.INTERACT'
6493       include 'COMMON.CONTACTS'
6494       include 'COMMON.TORSION'
6495       include 'COMMON.VAR'
6496       include 'COMMON.GEO'
6497       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6498       double precision ggg1(3),ggg2(3)
6499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6500 C                                                                              C
6501 C                            Parallel chains                                   C
6502 C                                                                              C
6503 C          o             o                   o             o                   C
6504 C         /l\           / \             \   / \           / \   /              C
6505 C        /   \         /   \             \ /   \         /   \ /               C
6506 C       j| o |l1       | o |              o| o |         | o |o                C
6507 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6508 C      \i/   \         /   \ /             /   \         /   \                 C
6509 C       o    k1             o                                                  C
6510 C         (I)          (II)                (III)          (IV)                 C
6511 C                                                                              C
6512 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6513 C                                                                              C
6514 C                            Antiparallel chains                               C
6515 C                                                                              C
6516 C          o             o                   o             o                   C
6517 C         /j\           / \             \   / \           / \   /              C
6518 C        /   \         /   \             \ /   \         /   \ /               C
6519 C      j1| o |l        | o |              o| o |         | o |o                C
6520 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6521 C      \i/   \         /   \ /             /   \         /   \                 C
6522 C       o     k1            o                                                  C
6523 C         (I)          (II)                (III)          (IV)                 C
6524 C                                                                              C
6525 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6526 C                                                                              C
6527 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6528 C                                                                              C
6529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6530 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6531 cd        eello5=0.0d0
6532 cd        return
6533 cd      endif
6534 cd      write (iout,*)
6535 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6536 cd     &   ' and',k,l
6537       itk=itortyp(itype(k))
6538       itl=itortyp(itype(l))
6539       itj=itortyp(itype(j))
6540       eello5_1=0.0d0
6541       eello5_2=0.0d0
6542       eello5_3=0.0d0
6543       eello5_4=0.0d0
6544 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6545 cd     &   eel5_3_num,eel5_4_num)
6546       do iii=1,2
6547         do kkk=1,5
6548           do lll=1,3
6549             derx(lll,kkk,iii)=0.0d0
6550           enddo
6551         enddo
6552       enddo
6553 cd      eij=facont_hb(jj,i)
6554 cd      ekl=facont_hb(kk,k)
6555 cd      ekont=eij*ekl
6556 cd      write (iout,*)'Contacts have occurred for peptide groups',
6557 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6558 cd      goto 1111
6559 C Contribution from the graph I.
6560 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6561 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6562       call transpose2(EUg(1,1,k),auxmat(1,1))
6563       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6564       vv(1)=pizda(1,1)-pizda(2,2)
6565       vv(2)=pizda(1,2)+pizda(2,1)
6566       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6567      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6568       if (calc_grad) then
6569 C Explicit gradient in virtual-dihedral angles.
6570       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6571      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6572      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6573       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6574       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6575       vv(1)=pizda(1,1)-pizda(2,2)
6576       vv(2)=pizda(1,2)+pizda(2,1)
6577       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6578      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6579      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6580       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6581       vv(1)=pizda(1,1)-pizda(2,2)
6582       vv(2)=pizda(1,2)+pizda(2,1)
6583       if (l.eq.j+1) then
6584         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6585      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6587       else
6588         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6589      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6591       endif
6592 C Cartesian gradient
6593       do iii=1,2
6594         do kkk=1,5
6595           do lll=1,3
6596             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6597      &        pizda(1,1))
6598             vv(1)=pizda(1,1)-pizda(2,2)
6599             vv(2)=pizda(1,2)+pizda(2,1)
6600             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6601      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6602      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6603           enddo
6604         enddo
6605       enddo
6606 c      goto 1112
6607       endif
6608 c1111  continue
6609 C Contribution from graph II
6610       call transpose2(EE(1,1,itk),auxmat(1,1))
6611       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6612       vv(1)=pizda(1,1)+pizda(2,2)
6613       vv(2)=pizda(2,1)-pizda(1,2)
6614       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6615      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6616       if (calc_grad) then
6617 C Explicit gradient in virtual-dihedral angles.
6618       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6619      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6620       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6621       vv(1)=pizda(1,1)+pizda(2,2)
6622       vv(2)=pizda(2,1)-pizda(1,2)
6623       if (l.eq.j+1) then
6624         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6625      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6626      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6627       else
6628         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6629      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6630      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6631       endif
6632 C Cartesian gradient
6633       do iii=1,2
6634         do kkk=1,5
6635           do lll=1,3
6636             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6637      &        pizda(1,1))
6638             vv(1)=pizda(1,1)+pizda(2,2)
6639             vv(2)=pizda(2,1)-pizda(1,2)
6640             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6641      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6642      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6643           enddo
6644         enddo
6645       enddo
6646 cd      goto 1112
6647       endif
6648 cd1111  continue
6649       if (l.eq.j+1) then
6650 cd        goto 1110
6651 C Parallel orientation
6652 C Contribution from graph III
6653         call transpose2(EUg(1,1,l),auxmat(1,1))
6654         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6655         vv(1)=pizda(1,1)-pizda(2,2)
6656         vv(2)=pizda(1,2)+pizda(2,1)
6657         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6658      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6659         if (calc_grad) then
6660 C Explicit gradient in virtual-dihedral angles.
6661         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6662      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6663      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6664         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6665         vv(1)=pizda(1,1)-pizda(2,2)
6666         vv(2)=pizda(1,2)+pizda(2,1)
6667         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6668      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6669      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6670         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6671         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6672         vv(1)=pizda(1,1)-pizda(2,2)
6673         vv(2)=pizda(1,2)+pizda(2,1)
6674         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6675      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6676      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6677 C Cartesian gradient
6678         do iii=1,2
6679           do kkk=1,5
6680             do lll=1,3
6681               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6682      &          pizda(1,1))
6683               vv(1)=pizda(1,1)-pizda(2,2)
6684               vv(2)=pizda(1,2)+pizda(2,1)
6685               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6686      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6687      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6688             enddo
6689           enddo
6690         enddo
6691 cd        goto 1112
6692         endif
6693 C Contribution from graph IV
6694 cd1110    continue
6695         call transpose2(EE(1,1,itl),auxmat(1,1))
6696         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6697         vv(1)=pizda(1,1)+pizda(2,2)
6698         vv(2)=pizda(2,1)-pizda(1,2)
6699         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6700      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6701         if (calc_grad) then
6702 C Explicit gradient in virtual-dihedral angles.
6703         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6704      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6705         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6706         vv(1)=pizda(1,1)+pizda(2,2)
6707         vv(2)=pizda(2,1)-pizda(1,2)
6708         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6709      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6710      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6711 C Cartesian gradient
6712         do iii=1,2
6713           do kkk=1,5
6714             do lll=1,3
6715               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6716      &          pizda(1,1))
6717               vv(1)=pizda(1,1)+pizda(2,2)
6718               vv(2)=pizda(2,1)-pizda(1,2)
6719               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6720      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6721      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6722             enddo
6723           enddo
6724         enddo
6725         endif
6726       else
6727 C Antiparallel orientation
6728 C Contribution from graph III
6729 c        goto 1110
6730         call transpose2(EUg(1,1,j),auxmat(1,1))
6731         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6732         vv(1)=pizda(1,1)-pizda(2,2)
6733         vv(2)=pizda(1,2)+pizda(2,1)
6734         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6735      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6736         if (calc_grad) then
6737 C Explicit gradient in virtual-dihedral angles.
6738         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6739      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6740      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6741         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6742         vv(1)=pizda(1,1)-pizda(2,2)
6743         vv(2)=pizda(1,2)+pizda(2,1)
6744         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6745      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6746      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6747         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6748         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6749         vv(1)=pizda(1,1)-pizda(2,2)
6750         vv(2)=pizda(1,2)+pizda(2,1)
6751         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6752      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6753      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6754 C Cartesian gradient
6755         do iii=1,2
6756           do kkk=1,5
6757             do lll=1,3
6758               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6759      &          pizda(1,1))
6760               vv(1)=pizda(1,1)-pizda(2,2)
6761               vv(2)=pizda(1,2)+pizda(2,1)
6762               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6763      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6764      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6765             enddo
6766           enddo
6767         enddo
6768 cd        goto 1112
6769         endif
6770 C Contribution from graph IV
6771 1110    continue
6772         call transpose2(EE(1,1,itj),auxmat(1,1))
6773         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6774         vv(1)=pizda(1,1)+pizda(2,2)
6775         vv(2)=pizda(2,1)-pizda(1,2)
6776         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6777      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6778         if (calc_grad) then
6779 C Explicit gradient in virtual-dihedral angles.
6780         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6781      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6782         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6783         vv(1)=pizda(1,1)+pizda(2,2)
6784         vv(2)=pizda(2,1)-pizda(1,2)
6785         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6786      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6787      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6788 C Cartesian gradient
6789         do iii=1,2
6790           do kkk=1,5
6791             do lll=1,3
6792               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6793      &          pizda(1,1))
6794               vv(1)=pizda(1,1)+pizda(2,2)
6795               vv(2)=pizda(2,1)-pizda(1,2)
6796               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6797      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6798      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6799             enddo
6800           enddo
6801         enddo
6802       endif
6803       endif
6804 1112  continue
6805       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6806 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6807 cd        write (2,*) 'ijkl',i,j,k,l
6808 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6809 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6810 cd      endif
6811 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6812 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6813 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6814 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6815       if (calc_grad) then
6816       if (j.lt.nres-1) then
6817         j1=j+1
6818         j2=j-1
6819       else
6820         j1=j-1
6821         j2=j-2
6822       endif
6823       if (l.lt.nres-1) then
6824         l1=l+1
6825         l2=l-1
6826       else
6827         l1=l-1
6828         l2=l-2
6829       endif
6830 cd      eij=1.0d0
6831 cd      ekl=1.0d0
6832 cd      ekont=1.0d0
6833 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6834       do ll=1,3
6835         ggg1(ll)=eel5*g_contij(ll,1)
6836         ggg2(ll)=eel5*g_contij(ll,2)
6837 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6838         ghalf=0.5d0*ggg1(ll)
6839 cd        ghalf=0.0d0
6840         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6841         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6842         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6843         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6844 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6845         ghalf=0.5d0*ggg2(ll)
6846 cd        ghalf=0.0d0
6847         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6848         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6849         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6850         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6851       enddo
6852 cd      goto 1112
6853       do m=i+1,j-1
6854         do ll=1,3
6855 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6856           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6857         enddo
6858       enddo
6859       do m=k+1,l-1
6860         do ll=1,3
6861 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6862           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6863         enddo
6864       enddo
6865 c1112  continue
6866       do m=i+2,j2
6867         do ll=1,3
6868           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6869         enddo
6870       enddo
6871       do m=k+2,l2
6872         do ll=1,3
6873           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6874         enddo
6875       enddo
6876 cd      do iii=1,nres-3
6877 cd        write (2,*) iii,g_corr5_loc(iii)
6878 cd      enddo
6879       endif
6880       eello5=ekont*eel5
6881 cd      write (2,*) 'ekont',ekont
6882 cd      write (iout,*) 'eello5',ekont*eel5
6883       return
6884       end
6885 c--------------------------------------------------------------------------
6886       double precision function eello6(i,j,k,l,jj,kk)
6887       implicit real*8 (a-h,o-z)
6888       include 'DIMENSIONS'
6889       include 'DIMENSIONS.ZSCOPT'
6890       include 'COMMON.IOUNITS'
6891       include 'COMMON.CHAIN'
6892       include 'COMMON.DERIV'
6893       include 'COMMON.INTERACT'
6894       include 'COMMON.CONTACTS'
6895       include 'COMMON.TORSION'
6896       include 'COMMON.VAR'
6897       include 'COMMON.GEO'
6898       include 'COMMON.FFIELD'
6899       double precision ggg1(3),ggg2(3)
6900 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6901 cd        eello6=0.0d0
6902 cd        return
6903 cd      endif
6904 cd      write (iout,*)
6905 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6906 cd     &   ' and',k,l
6907       eello6_1=0.0d0
6908       eello6_2=0.0d0
6909       eello6_3=0.0d0
6910       eello6_4=0.0d0
6911       eello6_5=0.0d0
6912       eello6_6=0.0d0
6913 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6914 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6915       do iii=1,2
6916         do kkk=1,5
6917           do lll=1,3
6918             derx(lll,kkk,iii)=0.0d0
6919           enddo
6920         enddo
6921       enddo
6922 cd      eij=facont_hb(jj,i)
6923 cd      ekl=facont_hb(kk,k)
6924 cd      ekont=eij*ekl
6925 cd      eij=1.0d0
6926 cd      ekl=1.0d0
6927 cd      ekont=1.0d0
6928       if (l.eq.j+1) then
6929         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6930         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6931         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6932         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6933         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6934         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6935       else
6936         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6937         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6938         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6939         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6940         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6941           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6942         else
6943           eello6_5=0.0d0
6944         endif
6945         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6946       endif
6947 C If turn contributions are considered, they will be handled separately.
6948       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6949 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6950 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6951 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6952 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6953 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6954 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6955 cd      goto 1112
6956       if (calc_grad) then
6957       if (j.lt.nres-1) then
6958         j1=j+1
6959         j2=j-1
6960       else
6961         j1=j-1
6962         j2=j-2
6963       endif
6964       if (l.lt.nres-1) then
6965         l1=l+1
6966         l2=l-1
6967       else
6968         l1=l-1
6969         l2=l-2
6970       endif
6971       do ll=1,3
6972         ggg1(ll)=eel6*g_contij(ll,1)
6973         ggg2(ll)=eel6*g_contij(ll,2)
6974 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6975         ghalf=0.5d0*ggg1(ll)
6976 cd        ghalf=0.0d0
6977         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6978         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6979         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6980         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6981         ghalf=0.5d0*ggg2(ll)
6982 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6983 cd        ghalf=0.0d0
6984         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6985         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6986         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6987         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6988       enddo
6989 cd      goto 1112
6990       do m=i+1,j-1
6991         do ll=1,3
6992 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6993           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6994         enddo
6995       enddo
6996       do m=k+1,l-1
6997         do ll=1,3
6998 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6999           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7000         enddo
7001       enddo
7002 1112  continue
7003       do m=i+2,j2
7004         do ll=1,3
7005           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7006         enddo
7007       enddo
7008       do m=k+2,l2
7009         do ll=1,3
7010           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7011         enddo
7012       enddo
7013 cd      do iii=1,nres-3
7014 cd        write (2,*) iii,g_corr6_loc(iii)
7015 cd      enddo
7016       endif
7017       eello6=ekont*eel6
7018 cd      write (2,*) 'ekont',ekont
7019 cd      write (iout,*) 'eello6',ekont*eel6
7020       return
7021       end
7022 c--------------------------------------------------------------------------
7023       double precision function eello6_graph1(i,j,k,l,imat,swap)
7024       implicit real*8 (a-h,o-z)
7025       include 'DIMENSIONS'
7026       include 'DIMENSIONS.ZSCOPT'
7027       include 'COMMON.IOUNITS'
7028       include 'COMMON.CHAIN'
7029       include 'COMMON.DERIV'
7030       include 'COMMON.INTERACT'
7031       include 'COMMON.CONTACTS'
7032       include 'COMMON.TORSION'
7033       include 'COMMON.VAR'
7034       include 'COMMON.GEO'
7035       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7036       logical swap
7037       logical lprn
7038       common /kutas/ lprn
7039 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7040 C                                                                              C
7041 C      Parallel       Antiparallel                                             C
7042 C                                                                              C
7043 C          o             o                                                     C
7044 C         /l\           /j\                                                    C
7045 C        /   \         /   \                                                   C
7046 C       /| o |         | o |\                                                  C
7047 C     \ j|/k\|  /   \  |/k\|l /                                                C
7048 C      \ /   \ /     \ /   \ /                                                 C
7049 C       o     o       o     o                                                  C
7050 C       i             i                                                        C
7051 C                                                                              C
7052 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7053       itk=itortyp(itype(k))
7054       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7055       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7056       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7057       call transpose2(EUgC(1,1,k),auxmat(1,1))
7058       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7059       vv1(1)=pizda1(1,1)-pizda1(2,2)
7060       vv1(2)=pizda1(1,2)+pizda1(2,1)
7061       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7062       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7063       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7064       s5=scalar2(vv(1),Dtobr2(1,i))
7065 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7066       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7067       if (.not. calc_grad) return
7068       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7069      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7070      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7071      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7072      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7073      & +scalar2(vv(1),Dtobr2der(1,i)))
7074       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7075       vv1(1)=pizda1(1,1)-pizda1(2,2)
7076       vv1(2)=pizda1(1,2)+pizda1(2,1)
7077       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7078       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7079       if (l.eq.j+1) then
7080         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7081      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7082      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7083      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7084      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7085       else
7086         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7087      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7088      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7089      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7090      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7091       endif
7092       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7093       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7094       vv1(1)=pizda1(1,1)-pizda1(2,2)
7095       vv1(2)=pizda1(1,2)+pizda1(2,1)
7096       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7097      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7098      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7099      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7100       do iii=1,2
7101         if (swap) then
7102           ind=3-iii
7103         else
7104           ind=iii
7105         endif
7106         do kkk=1,5
7107           do lll=1,3
7108             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7109             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7110             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7111             call transpose2(EUgC(1,1,k),auxmat(1,1))
7112             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7113      &        pizda1(1,1))
7114             vv1(1)=pizda1(1,1)-pizda1(2,2)
7115             vv1(2)=pizda1(1,2)+pizda1(2,1)
7116             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7117             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7118      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7119             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7120      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7121             s5=scalar2(vv(1),Dtobr2(1,i))
7122             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7123           enddo
7124         enddo
7125       enddo
7126       return
7127       end
7128 c----------------------------------------------------------------------------
7129       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7130       implicit real*8 (a-h,o-z)
7131       include 'DIMENSIONS'
7132       include 'DIMENSIONS.ZSCOPT'
7133       include 'COMMON.IOUNITS'
7134       include 'COMMON.CHAIN'
7135       include 'COMMON.DERIV'
7136       include 'COMMON.INTERACT'
7137       include 'COMMON.CONTACTS'
7138       include 'COMMON.TORSION'
7139       include 'COMMON.VAR'
7140       include 'COMMON.GEO'
7141       logical swap
7142       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7143      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7144       logical lprn
7145       common /kutas/ lprn
7146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7147 C                                                                              C
7148 C      Parallel       Antiparallel                                             C
7149 C                                                                              C
7150 C          o             o                                                     C
7151 C     \   /l\           /j\   /                                                C
7152 C      \ /   \         /   \ /                                                 C
7153 C       o| o |         | o |o                                                  C
7154 C     \ j|/k\|      \  |/k\|l                                                  C
7155 C      \ /   \       \ /   \                                                   C
7156 C       o             o                                                        C
7157 C       i             i                                                        C
7158 C                                                                              C
7159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7160 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7161 C AL 7/4/01 s1 would occur in the sixth-order moment,
7162 C           but not in a cluster cumulant
7163 #ifdef MOMENT
7164       s1=dip(1,jj,i)*dip(1,kk,k)
7165 #endif
7166       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7167       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7168       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7169       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7170       call transpose2(EUg(1,1,k),auxmat(1,1))
7171       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7172       vv(1)=pizda(1,1)-pizda(2,2)
7173       vv(2)=pizda(1,2)+pizda(2,1)
7174       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7175 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7176 #ifdef MOMENT
7177       eello6_graph2=-(s1+s2+s3+s4)
7178 #else
7179       eello6_graph2=-(s2+s3+s4)
7180 #endif
7181 c      eello6_graph2=-s3
7182       if (.not. calc_grad) return
7183 C Derivatives in gamma(i-1)
7184       if (i.gt.1) then
7185 #ifdef MOMENT
7186         s1=dipderg(1,jj,i)*dip(1,kk,k)
7187 #endif
7188         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7189         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7190         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7191         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7192 #ifdef MOMENT
7193         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7194 #else
7195         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7196 #endif
7197 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7198       endif
7199 C Derivatives in gamma(k-1)
7200 #ifdef MOMENT
7201       s1=dip(1,jj,i)*dipderg(1,kk,k)
7202 #endif
7203       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7204       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7205       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7206       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7207       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7208       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7209       vv(1)=pizda(1,1)-pizda(2,2)
7210       vv(2)=pizda(1,2)+pizda(2,1)
7211       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7212 #ifdef MOMENT
7213       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7214 #else
7215       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7216 #endif
7217 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7218 C Derivatives in gamma(j-1) or gamma(l-1)
7219       if (j.gt.1) then
7220 #ifdef MOMENT
7221         s1=dipderg(3,jj,i)*dip(1,kk,k)
7222 #endif
7223         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7224         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7225         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7226         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7227         vv(1)=pizda(1,1)-pizda(2,2)
7228         vv(2)=pizda(1,2)+pizda(2,1)
7229         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7230 #ifdef MOMENT
7231         if (swap) then
7232           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7233         else
7234           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7235         endif
7236 #endif
7237         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7238 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7239       endif
7240 C Derivatives in gamma(l-1) or gamma(j-1)
7241       if (l.gt.1) then
7242 #ifdef MOMENT
7243         s1=dip(1,jj,i)*dipderg(3,kk,k)
7244 #endif
7245         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7246         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7247         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7248         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7249         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7250         vv(1)=pizda(1,1)-pizda(2,2)
7251         vv(2)=pizda(1,2)+pizda(2,1)
7252         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7253 #ifdef MOMENT
7254         if (swap) then
7255           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7256         else
7257           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7258         endif
7259 #endif
7260         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7261 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7262       endif
7263 C Cartesian derivatives.
7264       if (lprn) then
7265         write (2,*) 'In eello6_graph2'
7266         do iii=1,2
7267           write (2,*) 'iii=',iii
7268           do kkk=1,5
7269             write (2,*) 'kkk=',kkk
7270             do jjj=1,2
7271               write (2,'(3(2f10.5),5x)')
7272      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7273             enddo
7274           enddo
7275         enddo
7276       endif
7277       do iii=1,2
7278         do kkk=1,5
7279           do lll=1,3
7280 #ifdef MOMENT
7281             if (iii.eq.1) then
7282               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7283             else
7284               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7285             endif
7286 #endif
7287             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7288      &        auxvec(1))
7289             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7290             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7291      &        auxvec(1))
7292             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7293             call transpose2(EUg(1,1,k),auxmat(1,1))
7294             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7295      &        pizda(1,1))
7296             vv(1)=pizda(1,1)-pizda(2,2)
7297             vv(2)=pizda(1,2)+pizda(2,1)
7298             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7299 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7300 #ifdef MOMENT
7301             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7302 #else
7303             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7304 #endif
7305             if (swap) then
7306               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7307             else
7308               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7309             endif
7310           enddo
7311         enddo
7312       enddo
7313       return
7314       end
7315 c----------------------------------------------------------------------------
7316       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7317       implicit real*8 (a-h,o-z)
7318       include 'DIMENSIONS'
7319       include 'DIMENSIONS.ZSCOPT'
7320       include 'COMMON.IOUNITS'
7321       include 'COMMON.CHAIN'
7322       include 'COMMON.DERIV'
7323       include 'COMMON.INTERACT'
7324       include 'COMMON.CONTACTS'
7325       include 'COMMON.TORSION'
7326       include 'COMMON.VAR'
7327       include 'COMMON.GEO'
7328       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7329       logical swap
7330 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7331 C                                                                              C
7332 C      Parallel       Antiparallel                                             C
7333 C                                                                              C
7334 C          o             o                                                     C
7335 C         /l\   /   \   /j\                                                    C
7336 C        /   \ /     \ /   \                                                   C
7337 C       /| o |o       o| o |\                                                  C
7338 C       j|/k\|  /      |/k\|l /                                                C
7339 C        /   \ /       /   \ /                                                 C
7340 C       /     o       /     o                                                  C
7341 C       i             i                                                        C
7342 C                                                                              C
7343 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7344 C
7345 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7346 C           energy moment and not to the cluster cumulant.
7347       iti=itortyp(itype(i))
7348       if (j.lt.nres-1) then
7349         itj1=itortyp(itype(j+1))
7350       else
7351         itj1=ntortyp+1
7352       endif
7353       itk=itortyp(itype(k))
7354       itk1=itortyp(itype(k+1))
7355       if (l.lt.nres-1) then
7356         itl1=itortyp(itype(l+1))
7357       else
7358         itl1=ntortyp+1
7359       endif
7360 #ifdef MOMENT
7361       s1=dip(4,jj,i)*dip(4,kk,k)
7362 #endif
7363       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7364       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7365       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7366       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7367       call transpose2(EE(1,1,itk),auxmat(1,1))
7368       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7369       vv(1)=pizda(1,1)+pizda(2,2)
7370       vv(2)=pizda(2,1)-pizda(1,2)
7371       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7372 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7373 #ifdef MOMENT
7374       eello6_graph3=-(s1+s2+s3+s4)
7375 #else
7376       eello6_graph3=-(s2+s3+s4)
7377 #endif
7378 c      eello6_graph3=-s4
7379       if (.not. calc_grad) return
7380 C Derivatives in gamma(k-1)
7381       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7382       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7383       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7384       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7385 C Derivatives in gamma(l-1)
7386       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7387       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7388       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7389       vv(1)=pizda(1,1)+pizda(2,2)
7390       vv(2)=pizda(2,1)-pizda(1,2)
7391       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7392       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7393 C Cartesian derivatives.
7394       do iii=1,2
7395         do kkk=1,5
7396           do lll=1,3
7397 #ifdef MOMENT
7398             if (iii.eq.1) then
7399               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7400             else
7401               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7402             endif
7403 #endif
7404             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7405      &        auxvec(1))
7406             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7407             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7408      &        auxvec(1))
7409             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7410             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7411      &        pizda(1,1))
7412             vv(1)=pizda(1,1)+pizda(2,2)
7413             vv(2)=pizda(2,1)-pizda(1,2)
7414             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7415 #ifdef MOMENT
7416             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7417 #else
7418             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7419 #endif
7420             if (swap) then
7421               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7422             else
7423               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7424             endif
7425 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7426           enddo
7427         enddo
7428       enddo
7429       return
7430       end
7431 c----------------------------------------------------------------------------
7432       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7433       implicit real*8 (a-h,o-z)
7434       include 'DIMENSIONS'
7435       include 'DIMENSIONS.ZSCOPT'
7436       include 'COMMON.IOUNITS'
7437       include 'COMMON.CHAIN'
7438       include 'COMMON.DERIV'
7439       include 'COMMON.INTERACT'
7440       include 'COMMON.CONTACTS'
7441       include 'COMMON.TORSION'
7442       include 'COMMON.VAR'
7443       include 'COMMON.GEO'
7444       include 'COMMON.FFIELD'
7445       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7446      & auxvec1(2),auxmat1(2,2)
7447       logical swap
7448 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7449 C                                                                              C
7450 C      Parallel       Antiparallel                                             C
7451 C                                                                              C
7452 C          o             o                                                     C
7453 C         /l\   /   \   /j\                                                    C
7454 C        /   \ /     \ /   \                                                   C
7455 C       /| o |o       o| o |\                                                  C
7456 C     \ j|/k\|      \  |/k\|l                                                  C
7457 C      \ /   \       \ /   \                                                   C
7458 C       o     \       o     \                                                  C
7459 C       i             i                                                        C
7460 C                                                                              C
7461 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7462 C
7463 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7464 C           energy moment and not to the cluster cumulant.
7465 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7466       iti=itortyp(itype(i))
7467       itj=itortyp(itype(j))
7468       if (j.lt.nres-1) then
7469         itj1=itortyp(itype(j+1))
7470       else
7471         itj1=ntortyp+1
7472       endif
7473       itk=itortyp(itype(k))
7474       if (k.lt.nres-1) then
7475         itk1=itortyp(itype(k+1))
7476       else
7477         itk1=ntortyp+1
7478       endif
7479       itl=itortyp(itype(l))
7480       if (l.lt.nres-1) then
7481         itl1=itortyp(itype(l+1))
7482       else
7483         itl1=ntortyp+1
7484       endif
7485 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7486 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7487 cd     & ' itl',itl,' itl1',itl1
7488 #ifdef MOMENT
7489       if (imat.eq.1) then
7490         s1=dip(3,jj,i)*dip(3,kk,k)
7491       else
7492         s1=dip(2,jj,j)*dip(2,kk,l)
7493       endif
7494 #endif
7495       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7496       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7497       if (j.eq.l+1) then
7498         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7499         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7500       else
7501         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7502         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7503       endif
7504       call transpose2(EUg(1,1,k),auxmat(1,1))
7505       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7506       vv(1)=pizda(1,1)-pizda(2,2)
7507       vv(2)=pizda(2,1)+pizda(1,2)
7508       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7509 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7510 #ifdef MOMENT
7511       eello6_graph4=-(s1+s2+s3+s4)
7512 #else
7513       eello6_graph4=-(s2+s3+s4)
7514 #endif
7515       if (.not. calc_grad) return
7516 C Derivatives in gamma(i-1)
7517       if (i.gt.1) then
7518 #ifdef MOMENT
7519         if (imat.eq.1) then
7520           s1=dipderg(2,jj,i)*dip(3,kk,k)
7521         else
7522           s1=dipderg(4,jj,j)*dip(2,kk,l)
7523         endif
7524 #endif
7525         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7526         if (j.eq.l+1) then
7527           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7528           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7529         else
7530           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7531           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7532         endif
7533         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7534         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7535 cd          write (2,*) 'turn6 derivatives'
7536 #ifdef MOMENT
7537           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7538 #else
7539           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7540 #endif
7541         else
7542 #ifdef MOMENT
7543           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7544 #else
7545           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7546 #endif
7547         endif
7548       endif
7549 C Derivatives in gamma(k-1)
7550 #ifdef MOMENT
7551       if (imat.eq.1) then
7552         s1=dip(3,jj,i)*dipderg(2,kk,k)
7553       else
7554         s1=dip(2,jj,j)*dipderg(4,kk,l)
7555       endif
7556 #endif
7557       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7558       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7559       if (j.eq.l+1) then
7560         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7561         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7562       else
7563         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7564         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7565       endif
7566       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7567       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7568       vv(1)=pizda(1,1)-pizda(2,2)
7569       vv(2)=pizda(2,1)+pizda(1,2)
7570       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7571       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7572 #ifdef MOMENT
7573         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7574 #else
7575         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7576 #endif
7577       else
7578 #ifdef MOMENT
7579         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7580 #else
7581         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7582 #endif
7583       endif
7584 C Derivatives in gamma(j-1) or gamma(l-1)
7585       if (l.eq.j+1 .and. l.gt.1) then
7586         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7587         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7588         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7589         vv(1)=pizda(1,1)-pizda(2,2)
7590         vv(2)=pizda(2,1)+pizda(1,2)
7591         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7592         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7593       else if (j.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         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7601           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7602         else
7603           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7604         endif
7605       endif
7606 C Cartesian derivatives.
7607       do iii=1,2
7608         do kkk=1,5
7609           do lll=1,3
7610 #ifdef MOMENT
7611             if (iii.eq.1) then
7612               if (imat.eq.1) then
7613                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7614               else
7615                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7616               endif
7617             else
7618               if (imat.eq.1) then
7619                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7620               else
7621                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7622               endif
7623             endif
7624 #endif
7625             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7626      &        auxvec(1))
7627             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7628             if (j.eq.l+1) then
7629               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7630      &          b1(1,itj1),auxvec(1))
7631               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7632             else
7633               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7634      &          b1(1,itl1),auxvec(1))
7635               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7636             endif
7637             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7638      &        pizda(1,1))
7639             vv(1)=pizda(1,1)-pizda(2,2)
7640             vv(2)=pizda(2,1)+pizda(1,2)
7641             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7642             if (swap) then
7643               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7644 #ifdef MOMENT
7645                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7646      &             -(s1+s2+s4)
7647 #else
7648                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7649      &             -(s2+s4)
7650 #endif
7651                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7652               else
7653 #ifdef MOMENT
7654                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7655 #else
7656                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7657 #endif
7658                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7659               endif
7660             else
7661 #ifdef MOMENT
7662               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7663 #else
7664               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7665 #endif
7666               if (l.eq.j+1) then
7667                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7668               else
7669                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7670               endif
7671             endif
7672           enddo
7673         enddo
7674       enddo
7675       return
7676       end
7677 c----------------------------------------------------------------------------
7678       double precision function eello_turn6(i,jj,kk)
7679       implicit real*8 (a-h,o-z)
7680       include 'DIMENSIONS'
7681       include 'DIMENSIONS.ZSCOPT'
7682       include 'COMMON.IOUNITS'
7683       include 'COMMON.CHAIN'
7684       include 'COMMON.DERIV'
7685       include 'COMMON.INTERACT'
7686       include 'COMMON.CONTACTS'
7687       include 'COMMON.TORSION'
7688       include 'COMMON.VAR'
7689       include 'COMMON.GEO'
7690       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7691      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7692      &  ggg1(3),ggg2(3)
7693       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7694      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7695 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7696 C           the respective energy moment and not to the cluster cumulant.
7697       eello_turn6=0.0d0
7698       j=i+4
7699       k=i+1
7700       l=i+3
7701       iti=itortyp(itype(i))
7702       itk=itortyp(itype(k))
7703       itk1=itortyp(itype(k+1))
7704       itl=itortyp(itype(l))
7705       itj=itortyp(itype(j))
7706 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7707 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7708 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7709 cd        eello6=0.0d0
7710 cd        return
7711 cd      endif
7712 cd      write (iout,*)
7713 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7714 cd     &   ' and',k,l
7715 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7716       do iii=1,2
7717         do kkk=1,5
7718           do lll=1,3
7719             derx_turn(lll,kkk,iii)=0.0d0
7720           enddo
7721         enddo
7722       enddo
7723 cd      eij=1.0d0
7724 cd      ekl=1.0d0
7725 cd      ekont=1.0d0
7726       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7727 cd      eello6_5=0.0d0
7728 cd      write (2,*) 'eello6_5',eello6_5
7729 #ifdef MOMENT
7730       call transpose2(AEA(1,1,1),auxmat(1,1))
7731       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7732       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7733       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7734 #else
7735       s1 = 0.0d0
7736 #endif
7737       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7738       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7739       s2 = scalar2(b1(1,itk),vtemp1(1))
7740 #ifdef MOMENT
7741       call transpose2(AEA(1,1,2),atemp(1,1))
7742       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7743       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7744       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7745 #else
7746       s8=0.0d0
7747 #endif
7748       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7749       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7750       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7751 #ifdef MOMENT
7752       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7753       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7754       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7755       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7756       ss13 = scalar2(b1(1,itk),vtemp4(1))
7757       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7758 #else
7759       s13=0.0d0
7760 #endif
7761 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7762 c      s1=0.0d0
7763 c      s2=0.0d0
7764 c      s8=0.0d0
7765 c      s12=0.0d0
7766 c      s13=0.0d0
7767       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7768       if (calc_grad) then
7769 C Derivatives in gamma(i+2)
7770 #ifdef MOMENT
7771       call transpose2(AEA(1,1,1),auxmatd(1,1))
7772       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7773       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7774       call transpose2(AEAderg(1,1,2),atempd(1,1))
7775       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7776       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7777 #else
7778       s8d=0.0d0
7779 #endif
7780       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7781       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7782       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7783 c      s1d=0.0d0
7784 c      s2d=0.0d0
7785 c      s8d=0.0d0
7786 c      s12d=0.0d0
7787 c      s13d=0.0d0
7788       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7789 C Derivatives in gamma(i+3)
7790 #ifdef MOMENT
7791       call transpose2(AEA(1,1,1),auxmatd(1,1))
7792       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7793       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7794       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7795 #else
7796       s1d=0.0d0
7797 #endif
7798       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7799       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7800       s2d = scalar2(b1(1,itk),vtemp1d(1))
7801 #ifdef MOMENT
7802       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7803       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7804 #endif
7805       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7806 #ifdef MOMENT
7807       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7808       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7809       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7810 #else
7811       s13d=0.0d0
7812 #endif
7813 c      s1d=0.0d0
7814 c      s2d=0.0d0
7815 c      s8d=0.0d0
7816 c      s12d=0.0d0
7817 c      s13d=0.0d0
7818 #ifdef MOMENT
7819       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7820      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7821 #else
7822       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7823      &               -0.5d0*ekont*(s2d+s12d)
7824 #endif
7825 C Derivatives in gamma(i+4)
7826       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7827       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7828       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7829 #ifdef MOMENT
7830       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7831       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7832       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7833 #else
7834       s13d = 0.0d0
7835 #endif
7836 c      s1d=0.0d0
7837 c      s2d=0.0d0
7838 c      s8d=0.0d0
7839 C      s12d=0.0d0
7840 c      s13d=0.0d0
7841 #ifdef MOMENT
7842       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7843 #else
7844       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7845 #endif
7846 C Derivatives in gamma(i+5)
7847 #ifdef MOMENT
7848       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7849       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7850       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7851 #else
7852       s1d = 0.0d0
7853 #endif
7854       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7855       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7856       s2d = scalar2(b1(1,itk),vtemp1d(1))
7857 #ifdef MOMENT
7858       call transpose2(AEA(1,1,2),atempd(1,1))
7859       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7860       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7861 #else
7862       s8d = 0.0d0
7863 #endif
7864       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7865       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7866 #ifdef MOMENT
7867       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7868       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7869       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7870 #else
7871       s13d = 0.0d0
7872 #endif
7873 c      s1d=0.0d0
7874 c      s2d=0.0d0
7875 c      s8d=0.0d0
7876 c      s12d=0.0d0
7877 c      s13d=0.0d0
7878 #ifdef MOMENT
7879       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7880      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7881 #else
7882       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7883      &               -0.5d0*ekont*(s2d+s12d)
7884 #endif
7885 C Cartesian derivatives
7886       do iii=1,2
7887         do kkk=1,5
7888           do lll=1,3
7889 #ifdef MOMENT
7890             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7891             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7892             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7893 #else
7894             s1d = 0.0d0
7895 #endif
7896             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7897             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7898      &          vtemp1d(1))
7899             s2d = scalar2(b1(1,itk),vtemp1d(1))
7900 #ifdef MOMENT
7901             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7902             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7903             s8d = -(atempd(1,1)+atempd(2,2))*
7904      &           scalar2(cc(1,1,itl),vtemp2(1))
7905 #else
7906             s8d = 0.0d0
7907 #endif
7908             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7909      &           auxmatd(1,1))
7910             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7911             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7912 c      s1d=0.0d0
7913 c      s2d=0.0d0
7914 c      s8d=0.0d0
7915 c      s12d=0.0d0
7916 c      s13d=0.0d0
7917 #ifdef MOMENT
7918             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7919      &        - 0.5d0*(s1d+s2d)
7920 #else
7921             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7922      &        - 0.5d0*s2d
7923 #endif
7924 #ifdef MOMENT
7925             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7926      &        - 0.5d0*(s8d+s12d)
7927 #else
7928             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7929      &        - 0.5d0*s12d
7930 #endif
7931           enddo
7932         enddo
7933       enddo
7934 #ifdef MOMENT
7935       do kkk=1,5
7936         do lll=1,3
7937           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7938      &      achuj_tempd(1,1))
7939           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7940           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7941           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7942           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7943           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7944      &      vtemp4d(1))
7945           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7946           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7947           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7948         enddo
7949       enddo
7950 #endif
7951 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7952 cd     &  16*eel_turn6_num
7953 cd      goto 1112
7954       if (j.lt.nres-1) then
7955         j1=j+1
7956         j2=j-1
7957       else
7958         j1=j-1
7959         j2=j-2
7960       endif
7961       if (l.lt.nres-1) then
7962         l1=l+1
7963         l2=l-1
7964       else
7965         l1=l-1
7966         l2=l-2
7967       endif
7968       do ll=1,3
7969         ggg1(ll)=eel_turn6*g_contij(ll,1)
7970         ggg2(ll)=eel_turn6*g_contij(ll,2)
7971         ghalf=0.5d0*ggg1(ll)
7972 cd        ghalf=0.0d0
7973         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7974      &    +ekont*derx_turn(ll,2,1)
7975         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7976         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7977      &    +ekont*derx_turn(ll,4,1)
7978         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7979         ghalf=0.5d0*ggg2(ll)
7980 cd        ghalf=0.0d0
7981         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7982      &    +ekont*derx_turn(ll,2,2)
7983         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7984         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7985      &    +ekont*derx_turn(ll,4,2)
7986         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7987       enddo
7988 cd      goto 1112
7989       do m=i+1,j-1
7990         do ll=1,3
7991           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7992         enddo
7993       enddo
7994       do m=k+1,l-1
7995         do ll=1,3
7996           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7997         enddo
7998       enddo
7999 1112  continue
8000       do m=i+2,j2
8001         do ll=1,3
8002           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8003         enddo
8004       enddo
8005       do m=k+2,l2
8006         do ll=1,3
8007           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8008         enddo
8009       enddo
8010 cd      do iii=1,nres-3
8011 cd        write (2,*) iii,g_corr6_loc(iii)
8012 cd      enddo
8013       endif
8014       eello_turn6=ekont*eel_turn6
8015 cd      write (2,*) 'ekont',ekont
8016 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8017       return
8018       end
8019 crc-------------------------------------------------
8020       SUBROUTINE MATVEC2(A1,V1,V2)
8021       implicit real*8 (a-h,o-z)
8022       include 'DIMENSIONS'
8023       DIMENSION A1(2,2),V1(2),V2(2)
8024 c      DO 1 I=1,2
8025 c        VI=0.0
8026 c        DO 3 K=1,2
8027 c    3     VI=VI+A1(I,K)*V1(K)
8028 c        Vaux(I)=VI
8029 c    1 CONTINUE
8030
8031       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8032       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8033
8034       v2(1)=vaux1
8035       v2(2)=vaux2
8036       END
8037 C---------------------------------------
8038       SUBROUTINE MATMAT2(A1,A2,A3)
8039       implicit real*8 (a-h,o-z)
8040       include 'DIMENSIONS'
8041       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8042 c      DIMENSION AI3(2,2)
8043 c        DO  J=1,2
8044 c          A3IJ=0.0
8045 c          DO K=1,2
8046 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8047 c          enddo
8048 c          A3(I,J)=A3IJ
8049 c       enddo
8050 c      enddo
8051
8052       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8053       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8054       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8055       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8056
8057       A3(1,1)=AI3_11
8058       A3(2,1)=AI3_21
8059       A3(1,2)=AI3_12
8060       A3(2,2)=AI3_22
8061       END
8062
8063 c-------------------------------------------------------------------------
8064       double precision function scalar2(u,v)
8065       implicit none
8066       double precision u(2),v(2)
8067       double precision sc
8068       integer i
8069       scalar2=u(1)*v(1)+u(2)*v(2)
8070       return
8071       end
8072
8073 C-----------------------------------------------------------------------------
8074
8075       subroutine transpose2(a,at)
8076       implicit none
8077       double precision a(2,2),at(2,2)
8078       at(1,1)=a(1,1)
8079       at(1,2)=a(2,1)
8080       at(2,1)=a(1,2)
8081       at(2,2)=a(2,2)
8082       return
8083       end
8084 c--------------------------------------------------------------------------
8085       subroutine transpose(n,a,at)
8086       implicit none
8087       integer n,i,j
8088       double precision a(n,n),at(n,n)
8089       do i=1,n
8090         do j=1,n
8091           at(j,i)=a(i,j)
8092         enddo
8093       enddo
8094       return
8095       end
8096 C---------------------------------------------------------------------------
8097       subroutine prodmat3(a1,a2,kk,transp,prod)
8098       implicit none
8099       integer i,j
8100       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8101       logical transp
8102 crc      double precision auxmat(2,2),prod_(2,2)
8103
8104       if (transp) then
8105 crc        call transpose2(kk(1,1),auxmat(1,1))
8106 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8107 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8108
8109            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8110      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8111            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8112      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8113            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8114      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8115            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8116      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8117
8118       else
8119 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8120 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8121
8122            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8123      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8124            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8125      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8126            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8127      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8128            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8129      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8130
8131       endif
8132 c      call transpose2(a2(1,1),a2t(1,1))
8133
8134 crc      print *,transp
8135 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8136 crc      print *,((prod(i,j),i=1,2),j=1,2)
8137
8138       return
8139       end
8140 C-----------------------------------------------------------------------------
8141       double precision function scalar(u,v)
8142       implicit none
8143       double precision u(3),v(3)
8144       double precision sc
8145       integer i
8146       sc=0.0d0
8147       do i=1,3
8148         sc=sc+u(i)*v(i)
8149       enddo
8150       scalar=sc
8151       return
8152       end
8153