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