source/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.CONTROL'
  26       double precision fact(6)
  27 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  28 cd    print *,'nnt=',nnt,' nct=',nct
  29 C
  30 C Compute the side-chain and electrostatic interaction energy
  31 C
  32       goto (101,102,103,104,105) ipot
  33 C Lennard-Jones potential.
  34   101 call elj(evdw,evdw_t)
  35 cd    print '(a)','Exit ELJ'
  36       goto 106
  37 C Lennard-Jones-Kihara potential (shifted).
  38   102 call eljk(evdw,evdw_t)
  39       goto 106
  40 C Berne-Pechukas potential (dilated LJ, angular dependence).
  41   103 call ebp(evdw,evdw_t)
  42       goto 106
  43 C Gay-Berne potential (shifted LJ, angular dependence).
  44   104 call egb(evdw,evdw_t)
  45       goto 106
  46 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  47   105 call egbv(evdw,evdw_t)
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  52 C
  53 C Calculate excluded-volume interaction energy between peptide groups
  54 C and side chains.
  55 C
  56       call escp(evdw2,evdw2_14)
  57 c
  58 c Calculate the bond-stretching energy
  59 c
  60       call ebond(estr)
  61 c      write (iout,*) "estr",estr
  62 C
  63 C Calculate the disulfide-bridge and other energy and the contributions
  64 C from other distance constraints.
  65 cd    print *,'Calling EHPB'
  66       call edis(ehpb)
  67 cd    print *,'EHPB exitted succesfully.'
  68 C
  69 C Calculate the virtual-bond-angle energy.
  70 C
  71       call ebend(ebe)
  72 cd    print *,'Bend energy finished.'
  73 C
  74 C Calculate the SC local energy.
  75 C
  76       call esc(escloc)
  77 cd    print *,'SCLOC energy finished.'
  78 C
  79 C Calculate the virtual-bond torsional energy.
  80 C
  81 cd    print *,'nterm=',nterm
  82       call etor(etors,edihcnstr,fact(1))
  83 C
  84 C 6/23/01 Calculate double-torsional energy
  85 C
  86       call etor_d(etors_d,fact(2))
  87 C
  88 C 21/5/07 Calculate local sicdechain correlation energy
  89 C
  90       call eback_sc_corr(esccor)
  91 C
  92 C 12/1/95 Multi-body terms
  93 C
  94       n_corr=0
  95       n_corr1=0
  96       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  97      &    .or. wturn6.gt.0.0d0) then
  98 c         print *,"calling multibody_eello"
  99          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 100 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 101 c         print *,ecorr,ecorr5,ecorr6,eturn6
 102       endif
 103       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 104          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 105       endif
 106
 107
 108 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 109       if (constr_homology.ge.1) then
 110         call e_modeller(ehomology_constr)
 111       else
 112         ehomology_constr=0.0d0
 113       endif
 114
 115 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 116
 117 C     BARTEK for dfa test!
 118       if (wdfa_dist.gt.0) call edfad(edfadis)
 119 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 120       if (wdfa_tor.gt.0) call edfat(edfator)
 121 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 122       if (wdfa_nei.gt.0) call edfan(edfanei)
 123 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 124       if (wdfa_beta.gt.0) call edfab(edfabet)
 125 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 126
 127 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 128 #ifdef SPLITELE
 129       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 130      & +wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 141      & +welec*fact(1)*(ees+evdw1)
 142      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 143      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 144      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 145      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 146      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 147      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 148      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 149      & +wdfa_beta*edfabet
 150 #endif
 151       energia(0)=etot
 152       energia(1)=evdw
 153 #ifdef SCP14
 154       energia(2)=evdw2-evdw2_14
 155       energia(17)=evdw2_14
 156 #else
 157       energia(2)=evdw2
 158       energia(17)=0.0d0
 159 #endif
 160 #ifdef SPLITELE
 161       energia(3)=ees
 162       energia(16)=evdw1
 163 #else
 164       energia(3)=ees+evdw1
 165       energia(16)=0.0d0
 166 #endif
 167       energia(4)=ecorr
 168       energia(5)=ecorr5
 169       energia(6)=ecorr6
 170       energia(7)=eel_loc
 171       energia(8)=eello_turn3
 172       energia(9)=eello_turn4
 173       energia(10)=eturn6
 174       energia(11)=ebe
 175       energia(12)=escloc
 176       energia(13)=etors
 177       energia(14)=etors_d
 178       energia(15)=ehpb
 179       energia(18)=estr
 180       energia(19)=esccor
 181       energia(20)=edihcnstr
 182       energia(21)=evdw_t
 183       energia(22)=ehomology_constr
 184       energia(23)=edfadis
 185       energia(24)=edfator
 186       energia(25)=edfanei
 187       energia(26)=edfabet
 188 c      if (dyn_ss) call dyn_set_nss
 189 c detecting NaNQ
 190 #ifdef ISNAN
 191 #ifdef AIX
 192       if (isnan(etot).ne.0) energia(0)=1.0d+99
 193 #else
 194       if (isnan(etot)) energia(0)=1.0d+99
 195 #endif
 196 #else
 197       i=0
 198 #ifdef WINPGI
 199       idumm=proc_proc(etot,i)
 200 #else
 201       call proc_proc(etot,i)
 202 #endif
 203       if(i.eq.1)energia(0)=1.0d+99
 204 #endif
 205 #ifdef MPL
 206 c     endif
 207 #endif
 208       if (calc_grad) then
 209 C
 210 C Sum up the components of the Cartesian gradient.
 211 C
 212 #ifdef SPLITELE
 213       do i=1,nct
 214         do j=1,3
 215           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 216      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 217      &                wbond*gradb(j,i)+
 218      &                wstrain*ghpbc(j,i)+
 219      &                wcorr*fact(3)*gradcorr(j,i)+
 220      &                wel_loc*fact(2)*gel_loc(j,i)+
 221      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 222      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 223      &                wcorr5*fact(4)*gradcorr5(j,i)+
 224      &                wcorr6*fact(5)*gradcorr6(j,i)+
 225      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 226      &                wsccor*fact(2)*gsccorc(j,i)+
 227      &                wdfa_dist*gdfad(j,i)+
 228      &                wdfa_tor*gdfat(j,i)+
 229      &                wdfa_nei*gdfan(j,i)+
 230      &                wdfa_beta*gdfab(j,i)
 231           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 232      &                  wbond*gradbx(j,i)+
 233      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 234      &                  wsccor*fact(2)*gsccorx(j,i)
 235         enddo
 236 #else
 237       do i=1,nct
 238         do j=1,3
 239           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 240      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 241      &                wbond*gradb(j,i)+
 242      &                wcorr*fact(3)*gradcorr(j,i)+
 243      &                wel_loc*fact(2)*gel_loc(j,i)+
 244      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 245      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 246      &                wcorr5*fact(4)*gradcorr5(j,i)+
 247      &                wcorr6*fact(5)*gradcorr6(j,i)+
 248      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 249      &                wsccor*fact(2)*gsccorc(j,i)+
 250      &                wdfa_dist*gdfad(j,i)+
 251      &                wdfa_tor*gdfat(j,i)+
 252      &                wdfa_nei*gdfan(j,i)+
 253      &                wdfa_beta*gdfab(j,i)
 254           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 255      &                  wbond*gradbx(j,i)+
 256      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 257      &                  wsccor*fact(1)*gsccorx(j,i)
 258         enddo
 259 #endif
 260       enddo
 261
 262
 263       do i=1,nres-3
 264         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 265      &   +wcorr5*fact(4)*g_corr5_loc(i)
 266      &   +wcorr6*fact(5)*g_corr6_loc(i)
 267      &   +wturn4*fact(3)*gel_loc_turn4(i)
 268      &   +wturn3*fact(2)*gel_loc_turn3(i)
 269      &   +wturn6*fact(5)*gel_loc_turn6(i)
 270      &   +wel_loc*fact(2)*gel_loc_loc(i)
 271      &   +wsccor*fact(1)*gsccor_loc(i)
 272       enddo
 273       endif
 274       return
 275       end
 276 C------------------------------------------------------------------------
 277       subroutine enerprint(energia,fact)
 278       implicit real*8 (a-h,o-z)
 279       include 'DIMENSIONS'
 280       include 'DIMENSIONS.ZSCOPT'
 281       include 'COMMON.IOUNITS'
 282       include 'COMMON.FFIELD'
 283       include 'COMMON.SBRIDGE'
 284       double precision energia(0:max_ene),fact(6)
 285       etot=energia(0)
 286       evdw=energia(1)+fact(6)*energia(21)
 287 #ifdef SCP14
 288       evdw2=energia(2)+energia(17)
 289 #else
 290       evdw2=energia(2)
 291 #endif
 292       ees=energia(3)
 293 #ifdef SPLITELE
 294       evdw1=energia(16)
 295 #endif
 296       ecorr=energia(4)
 297       ecorr5=energia(5)
 298       ecorr6=energia(6)
 299       eel_loc=energia(7)
 300       eello_turn3=energia(8)
 301       eello_turn4=energia(9)
 302       eello_turn6=energia(10)
 303       ebe=energia(11)
 304       escloc=energia(12)
 305       etors=energia(13)
 306       etors_d=energia(14)
 307       ehpb=energia(15)
 308       esccor=energia(19)
 309       edihcnstr=energia(20)
 310       estr=energia(18)
 311       ehomology_constr=energia(22)
 312       edfadis=energia(23)
 313       edfator=energia(24)
 314       edfanei=energia(25)
 315       edfabet=energia(26)
 316 #ifdef SPLITELE
 317       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 318      &  wvdwpp,
 319      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 320      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 321      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 322      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 323      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 324      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 325      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 326      &  wdfa_beta,etot
 327    10 format (/'Virtual-chain energies:'//
 328      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 329      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 330      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 331      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 332      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 333      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 334      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 335      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 336      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 337      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 338      & ' (SS bridges & dist. cnstr.)'/
 339      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 340      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 343      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 344      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 345      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 346      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 347      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 348      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 349      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 350      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 351      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 352      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 353      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 354      & 'ETOT=  ',1pE16.6,' (total)')
 355 #else
 356       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 357      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 358      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 359      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 360      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 361      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 362      &  edihcnstr,ehomology_constr,ebr*nss,
 363      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 364      &  wdfa_beta,etot
 365    10 format (/'Virtual-chain energies:'//
 366      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 367      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 368      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 369      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 370      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 371      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 372      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 373      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 374      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 375      & ' (SS bridges & dist. cnstr.)'/
 376      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 377      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 380      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 381      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 382      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 383      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 384      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 385      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 386      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 387      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 388      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 389      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 390      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 391      & 'ETOT=  ',1pE16.6,' (total)')
 392 #endif
 393       return
 394       end
 395 C-----------------------------------------------------------------------
 396       subroutine elj(evdw,evdw_t)
 397 C
 398 C This subroutine calculates the interaction energy of nonbonded side chains
 399 C assuming the LJ potential of interaction.
 400 C
 401       implicit real*8 (a-h,o-z)
 402       include 'DIMENSIONS'
 403       include 'DIMENSIONS.ZSCOPT'
 404       include "DIMENSIONS.COMPAR"
 405       parameter (accur=1.0d-10)
 406       include 'COMMON.GEO'
 407       include 'COMMON.VAR'
 408       include 'COMMON.LOCAL'
 409       include 'COMMON.CHAIN'
 410       include 'COMMON.DERIV'
 411       include 'COMMON.INTERACT'
 412       include 'COMMON.TORSION'
 413       include 'COMMON.ENEPS'
 414       include 'COMMON.SBRIDGE'
 415       include 'COMMON.NAMES'
 416       include 'COMMON.IOUNITS'
 417       include 'COMMON.CONTACTS'
 418       dimension gg(3)
 419       integer icant
 420       external icant
 421 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 422       do i=1,210
 423         do j=1,2
 424           eneps_temp(j,i)=0.0d0
 425         enddo
 426       enddo
 427       evdw=0.0D0
 428       evdw_t=0.0d0
 429       do i=iatsc_s,iatsc_e
 430         itypi=itype(i)
 431         itypi1=itype(i+1)
 432         xi=c(1,nres+i)
 433         yi=c(2,nres+i)
 434         zi=c(3,nres+i)
 435 C Change 12/1/95
 436         num_conti=0
 437 C
 438 C Calculate SC interaction energy.
 439 C
 440         do iint=1,nint_gr(i)
 441 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 442 cd   &                  'iend=',iend(i,iint)
 443           do j=istart(i,iint),iend(i,iint)
 444             itypj=itype(j)
 445             xj=c(1,nres+j)-xi
 446             yj=c(2,nres+j)-yi
 447             zj=c(3,nres+j)-zi
 448 C Change 12/1/95 to calculate four-body interactions
 449             rij=xj*xj+yj*yj+zj*zj
 450             rrij=1.0D0/rij
 451 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 452             eps0ij=eps(itypi,itypj)
 453             fac=rrij**expon2
 454             e1=fac*fac*aa(itypi,itypj)
 455             e2=fac*bb(itypi,itypj)
 456             evdwij=e1+e2
 457             ij=icant(itypi,itypj)
 458             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 459             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 460 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 461 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 462 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 463 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 464 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 465 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 466             if (bb(itypi,itypj).gt.0.0d0) then
 467               evdw=evdw+evdwij
 468             else
 469               evdw_t=evdw_t+evdwij
 470             endif
 471             if (calc_grad) then
 472 C
 473 C Calculate the components of the gradient in DC and X
 474 C
 475             fac=-rrij*(e1+evdwij)
 476             gg(1)=xj*fac
 477             gg(2)=yj*fac
 478             gg(3)=zj*fac
 479             do k=1,3
 480               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 481               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 482             enddo
 483             do k=i,j-1
 484               do l=1,3
 485                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 486               enddo
 487             enddo
 488             endif
 489 C
 490 C 12/1/95, revised on 5/20/97
 491 C
 492 C Calculate the contact function. The ith column of the array JCONT will
 493 C contain the numbers of atoms that make contacts with the atom I (of numbers
 494 C greater than I). The arrays FACONT and GACONT will contain the values of
 495 C the contact function and its derivative.
 496 C
 497 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 498 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 499 C Uncomment next line, if the correlation interactions are contact function only
 500             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 501               rij=dsqrt(rij)
 502               sigij=sigma(itypi,itypj)
 503               r0ij=rs0(itypi,itypj)
 504 C
 505 C Check whether the SC's are not too far to make a contact.
 506 C
 507               rcut=1.5d0*r0ij
 508               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 509 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 510 C
 511               if (fcont.gt.0.0D0) then
 512 C If the SC-SC distance if close to sigma, apply spline.
 513 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 514 cAdam &             fcont1,fprimcont1)
 515 cAdam           fcont1=1.0d0-fcont1
 516 cAdam           if (fcont1.gt.0.0d0) then
 517 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 518 cAdam             fcont=fcont*fcont1
 519 cAdam           endif
 520 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 521 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 522 cga             do k=1,3
 523 cga               gg(k)=gg(k)*eps0ij
 524 cga             enddo
 525 cga             eps0ij=-evdwij*eps0ij
 526 C Uncomment for AL's type of SC correlation interactions.
 527 cadam           eps0ij=-evdwij
 528                 num_conti=num_conti+1
 529                 jcont(num_conti,i)=j
 530                 facont(num_conti,i)=fcont*eps0ij
 531                 fprimcont=eps0ij*fprimcont/rij
 532                 fcont=expon*fcont
 533 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 534 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 535 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 536 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 537                 gacont(1,num_conti,i)=-fprimcont*xj
 538                 gacont(2,num_conti,i)=-fprimcont*yj
 539                 gacont(3,num_conti,i)=-fprimcont*zj
 540 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 541 cd              write (iout,'(2i3,3f10.5)')
 542 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 543               endif
 544             endif
 545           enddo      ! j
 546         enddo        ! iint
 547 C Change 12/1/95
 548         num_cont(i)=num_conti
 549       enddo          ! i
 550       if (calc_grad) then
 551       do i=1,nct
 552         do j=1,3
 553           gvdwc(j,i)=expon*gvdwc(j,i)
 554           gvdwx(j,i)=expon*gvdwx(j,i)
 555         enddo
 556       enddo
 557       endif
 558 C******************************************************************************
 559 C
 560 C                              N O T E !!!
 561 C
 562 C To save time, the factor of EXPON has been extracted from ALL components
 563 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 564 C use!
 565 C
 566 C******************************************************************************
 567       return
 568       end
 569 C-----------------------------------------------------------------------------
 570       subroutine eljk(evdw,evdw_t)
 571 C
 572 C This subroutine calculates the interaction energy of nonbonded side chains
 573 C assuming the LJK potential of interaction.
 574 C
 575       implicit real*8 (a-h,o-z)
 576       include 'DIMENSIONS'
 577       include 'DIMENSIONS.ZSCOPT'
 578       include "DIMENSIONS.COMPAR"
 579       include 'COMMON.GEO'
 580       include 'COMMON.VAR'
 581       include 'COMMON.LOCAL'
 582       include 'COMMON.CHAIN'
 583       include 'COMMON.DERIV'
 584       include 'COMMON.INTERACT'
 585       include 'COMMON.ENEPS'
 586       include 'COMMON.IOUNITS'
 587       include 'COMMON.NAMES'
 588       dimension gg(3)
 589       logical scheck
 590       integer icant
 591       external icant
 592 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 593       do i=1,210
 594         do j=1,2
 595           eneps_temp(j,i)=0.0d0
 596         enddo
 597       enddo
 598       evdw=0.0D0
 599       evdw_t=0.0d0
 600       do i=iatsc_s,iatsc_e
 601         itypi=itype(i)
 602         itypi1=itype(i+1)
 603         xi=c(1,nres+i)
 604         yi=c(2,nres+i)
 605         zi=c(3,nres+i)
 606 C
 607 C Calculate SC interaction energy.
 608 C
 609         do iint=1,nint_gr(i)
 610           do j=istart(i,iint),iend(i,iint)
 611             itypj=itype(j)
 612             xj=c(1,nres+j)-xi
 613             yj=c(2,nres+j)-yi
 614             zj=c(3,nres+j)-zi
 615             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 616             fac_augm=rrij**expon
 617             e_augm=augm(itypi,itypj)*fac_augm
 618             r_inv_ij=dsqrt(rrij)
 619             rij=1.0D0/r_inv_ij
 620             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 621             fac=r_shift_inv**expon
 622             e1=fac*fac*aa(itypi,itypj)
 623             e2=fac*bb(itypi,itypj)
 624             evdwij=e_augm+e1+e2
 625             ij=icant(itypi,itypj)
 626             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 627      &        /dabs(eps(itypi,itypj))
 628             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 629 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 630 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 631 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 632 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 633 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 634 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 635 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 636             if (bb(itypi,itypj).gt.0.0d0) then
 637               evdw=evdw+evdwij
 638             else
 639               evdw_t=evdw_t+evdwij
 640             endif
 641             if (calc_grad) then
 642 C
 643 C Calculate the components of the gradient in DC and X
 644 C
 645             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 646             gg(1)=xj*fac
 647             gg(2)=yj*fac
 648             gg(3)=zj*fac
 649             do k=1,3
 650               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 651               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 652             enddo
 653             do k=i,j-1
 654               do l=1,3
 655                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 656               enddo
 657             enddo
 658             endif
 659           enddo      ! j
 660         enddo        ! iint
 661       enddo          ! i
 662       if (calc_grad) then
 663       do i=1,nct
 664         do j=1,3
 665           gvdwc(j,i)=expon*gvdwc(j,i)
 666           gvdwx(j,i)=expon*gvdwx(j,i)
 667         enddo
 668       enddo
 669       endif
 670       return
 671       end
 672 C-----------------------------------------------------------------------------
 673       subroutine ebp(evdw,evdw_t)
 674 C
 675 C This subroutine calculates the interaction energy of nonbonded side chains
 676 C assuming the Berne-Pechukas potential of interaction.
 677 C
 678       implicit real*8 (a-h,o-z)
 679       include 'DIMENSIONS'
 680       include 'DIMENSIONS.ZSCOPT'
 681       include "DIMENSIONS.COMPAR"
 682       include 'COMMON.GEO'
 683       include 'COMMON.VAR'
 684       include 'COMMON.LOCAL'
 685       include 'COMMON.CHAIN'
 686       include 'COMMON.DERIV'
 687       include 'COMMON.NAMES'
 688       include 'COMMON.INTERACT'
 689       include 'COMMON.ENEPS'
 690       include 'COMMON.IOUNITS'
 691       include 'COMMON.CALC'
 692       common /srutu/ icall
 693 c     double precision rrsave(maxdim)
 694       logical lprn
 695       integer icant
 696       external icant
 697       do i=1,210
 698         do j=1,2
 699           eneps_temp(j,i)=0.0d0
 700         enddo
 701       enddo
 702       evdw=0.0D0
 703       evdw_t=0.0d0
 704 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 705 c     if (icall.eq.0) then
 706 c       lprn=.true.
 707 c     else
 708         lprn=.false.
 709 c     endif
 710       ind=0
 711       do i=iatsc_s,iatsc_e
 712         itypi=itype(i)
 713         itypi1=itype(i+1)
 714         xi=c(1,nres+i)
 715         yi=c(2,nres+i)
 716         zi=c(3,nres+i)
 717         dxi=dc_norm(1,nres+i)
 718         dyi=dc_norm(2,nres+i)
 719         dzi=dc_norm(3,nres+i)
 720         dsci_inv=vbld_inv(i+nres)
 721 C
 722 C Calculate SC interaction energy.
 723 C
 724         do iint=1,nint_gr(i)
 725           do j=istart(i,iint),iend(i,iint)
 726             ind=ind+1
 727             itypj=itype(j)
 728             dscj_inv=vbld_inv(j+nres)
 729             chi1=chi(itypi,itypj)
 730             chi2=chi(itypj,itypi)
 731             chi12=chi1*chi2
 732             chip1=chip(itypi)
 733             chip2=chip(itypj)
 734             chip12=chip1*chip2
 735             alf1=alp(itypi)
 736             alf2=alp(itypj)
 737             alf12=0.5D0*(alf1+alf2)
 738 C For diagnostics only!!!
 739 c           chi1=0.0D0
 740 c           chi2=0.0D0
 741 c           chi12=0.0D0
 742 c           chip1=0.0D0
 743 c           chip2=0.0D0
 744 c           chip12=0.0D0
 745 c           alf1=0.0D0
 746 c           alf2=0.0D0
 747 c           alf12=0.0D0
 748             xj=c(1,nres+j)-xi
 749             yj=c(2,nres+j)-yi
 750             zj=c(3,nres+j)-zi
 751             dxj=dc_norm(1,nres+j)
 752             dyj=dc_norm(2,nres+j)
 753             dzj=dc_norm(3,nres+j)
 754             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 755 cd          if (icall.eq.0) then
 756 cd            rrsave(ind)=rrij
 757 cd          else
 758 cd            rrij=rrsave(ind)
 759 cd          endif
 760             rij=dsqrt(rrij)
 761 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 762             call sc_angular
 763 C Calculate whole angle-dependent part of epsilon and contributions
 764 C to its derivatives
 765             fac=(rrij*sigsq)**expon2
 766             e1=fac*fac*aa(itypi,itypj)
 767             e2=fac*bb(itypi,itypj)
 768             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 769             eps2der=evdwij*eps3rt
 770             eps3der=evdwij*eps2rt
 771             evdwij=evdwij*eps2rt*eps3rt
 772             ij=icant(itypi,itypj)
 773             aux=eps1*eps2rt**2*eps3rt**2
 774             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 775      &        /dabs(eps(itypi,itypj))
 776             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 777             if (bb(itypi,itypj).gt.0.0d0) then
 778               evdw=evdw+evdwij
 779             else
 780               evdw_t=evdw_t+evdwij
 781             endif
 782             if (calc_grad) then
 783             if (lprn) then
 784             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 785             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 786 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 787 cd     &        restyp(itypi),i,restyp(itypj),j,
 788 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 789 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 790 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 791 cd     &        evdwij
 792             endif
 793 C Calculate gradient components.
 794             e1=e1*eps1*eps2rt**2*eps3rt**2
 795             fac=-expon*(e1+evdwij)
 796             sigder=fac/sigsq
 797             fac=rrij*fac
 798 C Calculate radial part of the gradient
 799             gg(1)=xj*fac
 800             gg(2)=yj*fac
 801             gg(3)=zj*fac
 802 C Calculate the angular part of the gradient and sum add the contributions
 803 C to the appropriate components of the Cartesian gradient.
 804             call sc_grad
 805             endif
 806           enddo      ! j
 807         enddo        ! iint
 808       enddo          ! i
 809 c     stop
 810       return
 811       end
 812 C-----------------------------------------------------------------------------
 813       subroutine egb(evdw,evdw_t)
 814 C
 815 C This subroutine calculates the interaction energy of nonbonded side chains
 816 C assuming the Gay-Berne potential of interaction.
 817 C
 818       implicit real*8 (a-h,o-z)
 819       include 'DIMENSIONS'
 820       include 'DIMENSIONS.ZSCOPT'
 821       include "DIMENSIONS.COMPAR"
 822       include 'COMMON.GEO'
 823       include 'COMMON.VAR'
 824       include 'COMMON.LOCAL'
 825       include 'COMMON.CHAIN'
 826       include 'COMMON.DERIV'
 827       include 'COMMON.NAMES'
 828       include 'COMMON.INTERACT'
 829       include 'COMMON.ENEPS'
 830       include 'COMMON.IOUNITS'
 831       include 'COMMON.CALC'
 832       include 'COMMON.SBRIDGE'
 833       logical lprn
 834       common /srutu/icall
 835       integer icant
 836       external icant
 837       do i=1,210
 838         do j=1,2
 839           eneps_temp(j,i)=0.0d0
 840         enddo
 841       enddo
 842 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 843       evdw=0.0D0
 844       evdw_t=0.0d0
 845       lprn=.false.
 846 c      if (icall.gt.0) lprn=.true.
 847       ind=0
 848       do i=iatsc_s,iatsc_e
 849         itypi=itype(i)
 850         itypi1=itype(i+1)
 851         xi=c(1,nres+i)
 852         yi=c(2,nres+i)
 853         zi=c(3,nres+i)
 854         dxi=dc_norm(1,nres+i)
 855         dyi=dc_norm(2,nres+i)
 856         dzi=dc_norm(3,nres+i)
 857         dsci_inv=vbld_inv(i+nres)
 858 C
 859 C Calculate SC interaction energy.
 860 C
 861         do iint=1,nint_gr(i)
 862           do j=istart(i,iint),iend(i,iint)
 863 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 864 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 865 C formation no electrostatic interactions should be calculated. If it
 866 C would be allowed NaN would appear
 867             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 868 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 869 C residue can or cannot form disulfide bond. There is still bug allowing
 870 C Cys...Cys...Cys bond formation
 871               call dyn_ssbond_ene(i,j,evdwij)
 872 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 873 C function in ssMD.F
 874               evdw=evdw+evdwij
 875 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 876 c     &                        'evdw',i,j,evdwij,' ss'
 877             ELSE
 878             ind=ind+1
 879             itypj=itype(j)
 880             dscj_inv=vbld_inv(j+nres)
 881             sig0ij=sigma(itypi,itypj)
 882             chi1=chi(itypi,itypj)
 883             chi2=chi(itypj,itypi)
 884             chi12=chi1*chi2
 885             chip1=chip(itypi)
 886             chip2=chip(itypj)
 887             chip12=chip1*chip2
 888             alf1=alp(itypi)
 889             alf2=alp(itypj)
 890             alf12=0.5D0*(alf1+alf2)
 891 C For diagnostics only!!!
 892 c           chi1=0.0D0
 893 c           chi2=0.0D0
 894 c           chi12=0.0D0
 895 c           chip1=0.0D0
 896 c           chip2=0.0D0
 897 c           chip12=0.0D0
 898 c           alf1=0.0D0
 899 c           alf2=0.0D0
 900 c           alf12=0.0D0
 901             xj=c(1,nres+j)-xi
 902             yj=c(2,nres+j)-yi
 903             zj=c(3,nres+j)-zi
 904             dxj=dc_norm(1,nres+j)
 905             dyj=dc_norm(2,nres+j)
 906             dzj=dc_norm(3,nres+j)
 907 c            write (iout,*) i,j,xj,yj,zj
 908             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 909             rij=dsqrt(rrij)
 910 C Calculate angle-dependent terms of energy and contributions to their
 911 C derivatives.
 912             call sc_angular
 913             sigsq=1.0D0/sigsq
 914             sig=sig0ij*dsqrt(sigsq)
 915             rij_shift=1.0D0/rij-sig+sig0ij
 916 C I hate to put IF's in the loops, but here don't have another choice!!!!
 917             if (rij_shift.le.0.0D0) then
 918               evdw=1.0D20
 919               return
 920             endif
 921             sigder=-sig*sigsq
 922 c---------------------------------------------------------------
 923             rij_shift=1.0D0/rij_shift
 924             fac=rij_shift**expon
 925             e1=fac*fac*aa(itypi,itypj)
 926             e2=fac*bb(itypi,itypj)
 927             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 928             eps2der=evdwij*eps3rt
 929             eps3der=evdwij*eps2rt
 930             evdwij=evdwij*eps2rt*eps3rt
 931             if (bb(itypi,itypj).gt.0) then
 932               evdw=evdw+evdwij
 933             else
 934               evdw_t=evdw_t+evdwij
 935             endif
 936             ij=icant(itypi,itypj)
 937             aux=eps1*eps2rt**2*eps3rt**2
 938             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 939      &        /dabs(eps(itypi,itypj))
 940             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 941 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 942 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 943 c     &         aux*e2/eps(itypi,itypj)
 944 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 945             if (lprn) then
 946             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 947             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 948             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 949      &        restyp(itypi),i,restyp(itypj),j,
 950      &        epsi,sigm,chi1,chi2,chip1,chip2,
 951      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 952      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 953      &        evdwij
 954             endif
 955             if (calc_grad) then
 956 C Calculate gradient components.
 957             e1=e1*eps1*eps2rt**2*eps3rt**2
 958             fac=-expon*(e1+evdwij)*rij_shift
 959             sigder=fac*sigder
 960             fac=rij*fac
 961 C Calculate the radial part of the gradient
 962             gg(1)=xj*fac
 963             gg(2)=yj*fac
 964             gg(3)=zj*fac
 965 C Calculate angular part of the gradient.
 966             call sc_grad
 967             endif
 968             ENDIF    ! dyn_ss
 969           enddo      ! j
 970         enddo        ! iint
 971       enddo          ! i
 972       return
 973       end
 974 C-----------------------------------------------------------------------------
 975       subroutine egbv(evdw,evdw_t)
 976 C
 977 C This subroutine calculates the interaction energy of nonbonded side chains
 978 C assuming the Gay-Berne-Vorobjev potential of interaction.
 979 C
 980       implicit real*8 (a-h,o-z)
 981       include 'DIMENSIONS'
 982       include 'DIMENSIONS.ZSCOPT'
 983       include "DIMENSIONS.COMPAR"
 984       include 'COMMON.GEO'
 985       include 'COMMON.VAR'
 986       include 'COMMON.LOCAL'
 987       include 'COMMON.CHAIN'
 988       include 'COMMON.DERIV'
 989       include 'COMMON.NAMES'
 990       include 'COMMON.INTERACT'
 991       include 'COMMON.ENEPS'
 992       include 'COMMON.IOUNITS'
 993       include 'COMMON.CALC'
 994       common /srutu/ icall
 995       logical lprn
 996       integer icant
 997       external icant
 998       do i=1,210
 999         do j=1,2
1000           eneps_temp(j,i)=0.0d0
1001         enddo
1002       enddo
1003       evdw=0.0D0
1004       evdw_t=0.0d0
1005 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1006       evdw=0.0D0
1007       lprn=.false.
1008 c      if (icall.gt.0) lprn=.true.
1009       ind=0
1010       do i=iatsc_s,iatsc_e
1011         itypi=itype(i)
1012         itypi1=itype(i+1)
1013         xi=c(1,nres+i)
1014         yi=c(2,nres+i)
1015         zi=c(3,nres+i)
1016         dxi=dc_norm(1,nres+i)
1017         dyi=dc_norm(2,nres+i)
1018         dzi=dc_norm(3,nres+i)
1019         dsci_inv=vbld_inv(i+nres)
1020 C
1021 C Calculate SC interaction energy.
1022 C
1023         do iint=1,nint_gr(i)
1024           do j=istart(i,iint),iend(i,iint)
1025             ind=ind+1
1026             itypj=itype(j)
1027             dscj_inv=vbld_inv(j+nres)
1028             sig0ij=sigma(itypi,itypj)
1029             r0ij=r0(itypi,itypj)
1030             chi1=chi(itypi,itypj)
1031             chi2=chi(itypj,itypi)
1032             chi12=chi1*chi2
1033             chip1=chip(itypi)
1034             chip2=chip(itypj)
1035             chip12=chip1*chip2
1036             alf1=alp(itypi)
1037             alf2=alp(itypj)
1038             alf12=0.5D0*(alf1+alf2)
1039 C For diagnostics only!!!
1040 c           chi1=0.0D0
1041 c           chi2=0.0D0
1042 c           chi12=0.0D0
1043 c           chip1=0.0D0
1044 c           chip2=0.0D0
1045 c           chip12=0.0D0
1046 c           alf1=0.0D0
1047 c           alf2=0.0D0
1048 c           alf12=0.0D0
1049             xj=c(1,nres+j)-xi
1050             yj=c(2,nres+j)-yi
1051             zj=c(3,nres+j)-zi
1052             dxj=dc_norm(1,nres+j)
1053             dyj=dc_norm(2,nres+j)
1054             dzj=dc_norm(3,nres+j)
1055             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1056             rij=dsqrt(rrij)
1057 C Calculate angle-dependent terms of energy and contributions to their
1058 C derivatives.
1059             call sc_angular
1060             sigsq=1.0D0/sigsq
1061             sig=sig0ij*dsqrt(sigsq)
1062             rij_shift=1.0D0/rij-sig+r0ij
1063 C I hate to put IF's in the loops, but here don't have another choice!!!!
1064             if (rij_shift.le.0.0D0) then
1065               evdw=1.0D20
1066               return
1067             endif
1068             sigder=-sig*sigsq
1069 c---------------------------------------------------------------
1070             rij_shift=1.0D0/rij_shift
1071             fac=rij_shift**expon
1072             e1=fac*fac*aa(itypi,itypj)
1073             e2=fac*bb(itypi,itypj)
1074             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1075             eps2der=evdwij*eps3rt
1076             eps3der=evdwij*eps2rt
1077             fac_augm=rrij**expon
1078             e_augm=augm(itypi,itypj)*fac_augm
1079             evdwij=evdwij*eps2rt*eps3rt
1080             if (bb(itypi,itypj).gt.0.0d0) then
1081               evdw=evdw+evdwij+e_augm
1082             else
1083               evdw_t=evdw_t+evdwij+e_augm
1084             endif
1085             ij=icant(itypi,itypj)
1086             aux=eps1*eps2rt**2*eps3rt**2
1087             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1088      &        /dabs(eps(itypi,itypj))
1089             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1090 c            eneps_temp(ij)=eneps_temp(ij)
1091 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1092 c            if (lprn) then
1093 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1096 c     &        restyp(itypi),i,restyp(itypj),j,
1097 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1098 c     &        chi1,chi2,chip1,chip2,
1099 c     &        eps1,eps2rt**2,eps3rt**2,
1100 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1101 c     &        evdwij+e_augm
1102 c            endif
1103             if (calc_grad) then
1104 C Calculate gradient components.
1105             e1=e1*eps1*eps2rt**2*eps3rt**2
1106             fac=-expon*(e1+evdwij)*rij_shift
1107             sigder=fac*sigder
1108             fac=rij*fac-2*expon*rrij*e_augm
1109 C Calculate the radial part of the gradient
1110             gg(1)=xj*fac
1111             gg(2)=yj*fac
1112             gg(3)=zj*fac
1113 C Calculate angular part of the gradient.
1114             call sc_grad
1115             endif
1116           enddo      ! j
1117         enddo        ! iint
1118       enddo          ! i
1119       return
1120       end
1121 C-----------------------------------------------------------------------------
1122       subroutine sc_angular
1123 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1124 C om12. Called by ebp, egb, and egbv.
1125       implicit none
1126       include 'COMMON.CALC'
1127       erij(1)=xj*rij
1128       erij(2)=yj*rij
1129       erij(3)=zj*rij
1130       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1131       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1132       om12=dxi*dxj+dyi*dyj+dzi*dzj
1133       chiom12=chi12*om12
1134 C Calculate eps1(om12) and its derivative in om12
1135       faceps1=1.0D0-om12*chiom12
1136       faceps1_inv=1.0D0/faceps1
1137       eps1=dsqrt(faceps1_inv)
1138 C Following variable is eps1*deps1/dom12
1139       eps1_om12=faceps1_inv*chiom12
1140 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1141 C and om12.
1142       om1om2=om1*om2
1143       chiom1=chi1*om1
1144       chiom2=chi2*om2
1145       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1146       sigsq=1.0D0-facsig*faceps1_inv
1147       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1148       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1149       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1150 C Calculate eps2 and its derivatives in om1, om2, and om12.
1151       chipom1=chip1*om1
1152       chipom2=chip2*om2
1153       chipom12=chip12*om12
1154       facp=1.0D0-om12*chipom12
1155       facp_inv=1.0D0/facp
1156       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1157 C Following variable is the square root of eps2
1158       eps2rt=1.0D0-facp1*facp_inv
1159 C Following three variables are the derivatives of the square root of eps
1160 C in om1, om2, and om12.
1161       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1162       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1163       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1164 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1165       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1166 C Calculate whole angle-dependent part of epsilon and contributions
1167 C to its derivatives
1168       return
1169       end
1170 C----------------------------------------------------------------------------
1171       subroutine sc_grad
1172       implicit real*8 (a-h,o-z)
1173       include 'DIMENSIONS'
1174       include 'DIMENSIONS.ZSCOPT'
1175       include 'COMMON.CHAIN'
1176       include 'COMMON.DERIV'
1177       include 'COMMON.CALC'
1178       double precision dcosom1(3),dcosom2(3)
1179       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1180       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1181       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1182      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1183       do k=1,3
1184         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1185         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1186       enddo
1187       do k=1,3
1188         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1189       enddo
1190       do k=1,3
1191         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1192      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1193      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1194         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1196      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1197       enddo
1198 C
1199 C Calculate the components of the gradient in DC and X
1200 C
1201       do k=i,j-1
1202         do l=1,3
1203           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1204         enddo
1205       enddo
1206       return
1207       end
1208 c------------------------------------------------------------------------------
1209       subroutine vec_and_deriv
1210       implicit real*8 (a-h,o-z)
1211       include 'DIMENSIONS'
1212       include 'DIMENSIONS.ZSCOPT'
1213       include 'COMMON.IOUNITS'
1214       include 'COMMON.GEO'
1215       include 'COMMON.VAR'
1216       include 'COMMON.LOCAL'
1217       include 'COMMON.CHAIN'
1218       include 'COMMON.VECTORS'
1219       include 'COMMON.DERIV'
1220       include 'COMMON.INTERACT'
1221       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1222 C Compute the local reference systems. For reference system (i), the
1223 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1224 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1225       do i=1,nres-1
1226 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1227           if (i.eq.nres-1) then
1228 C Case of the last full residue
1229 C Compute the Z-axis
1230             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1231             costh=dcos(pi-theta(nres))
1232             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1233             do k=1,3
1234               uz(k,i)=fac*uz(k,i)
1235             enddo
1236             if (calc_grad) then
1237 C Compute the derivatives of uz
1238             uzder(1,1,1)= 0.0d0
1239             uzder(2,1,1)=-dc_norm(3,i-1)
1240             uzder(3,1,1)= dc_norm(2,i-1)
1241             uzder(1,2,1)= dc_norm(3,i-1)
1242             uzder(2,2,1)= 0.0d0
1243             uzder(3,2,1)=-dc_norm(1,i-1)
1244             uzder(1,3,1)=-dc_norm(2,i-1)
1245             uzder(2,3,1)= dc_norm(1,i-1)
1246             uzder(3,3,1)= 0.0d0
1247             uzder(1,1,2)= 0.0d0
1248             uzder(2,1,2)= dc_norm(3,i)
1249             uzder(3,1,2)=-dc_norm(2,i)
1250             uzder(1,2,2)=-dc_norm(3,i)
1251             uzder(2,2,2)= 0.0d0
1252             uzder(3,2,2)= dc_norm(1,i)
1253             uzder(1,3,2)= dc_norm(2,i)
1254             uzder(2,3,2)=-dc_norm(1,i)
1255             uzder(3,3,2)= 0.0d0
1256             endif
1257 C Compute the Y-axis
1258             facy=fac
1259             do k=1,3
1260               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1261             enddo
1262             if (calc_grad) then
1263 C Compute the derivatives of uy
1264             do j=1,3
1265               do k=1,3
1266                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1267      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1268                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1269               enddo
1270               uyder(j,j,1)=uyder(j,j,1)-costh
1271               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1272             enddo
1273             do j=1,2
1274               do k=1,3
1275                 do l=1,3
1276                   uygrad(l,k,j,i)=uyder(l,k,j)
1277                   uzgrad(l,k,j,i)=uzder(l,k,j)
1278                 enddo
1279               enddo
1280             enddo
1281             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1282             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1283             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1284             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1285             endif
1286           else
1287 C Other residues
1288 C Compute the Z-axis
1289             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1290             costh=dcos(pi-theta(i+2))
1291             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1292             do k=1,3
1293               uz(k,i)=fac*uz(k,i)
1294             enddo
1295             if (calc_grad) then
1296 C Compute the derivatives of uz
1297             uzder(1,1,1)= 0.0d0
1298             uzder(2,1,1)=-dc_norm(3,i+1)
1299             uzder(3,1,1)= dc_norm(2,i+1)
1300             uzder(1,2,1)= dc_norm(3,i+1)
1301             uzder(2,2,1)= 0.0d0
1302             uzder(3,2,1)=-dc_norm(1,i+1)
1303             uzder(1,3,1)=-dc_norm(2,i+1)
1304             uzder(2,3,1)= dc_norm(1,i+1)
1305             uzder(3,3,1)= 0.0d0
1306             uzder(1,1,2)= 0.0d0
1307             uzder(2,1,2)= dc_norm(3,i)
1308             uzder(3,1,2)=-dc_norm(2,i)
1309             uzder(1,2,2)=-dc_norm(3,i)
1310             uzder(2,2,2)= 0.0d0
1311             uzder(3,2,2)= dc_norm(1,i)
1312             uzder(1,3,2)= dc_norm(2,i)
1313             uzder(2,3,2)=-dc_norm(1,i)
1314             uzder(3,3,2)= 0.0d0
1315             endif
1316 C Compute the Y-axis
1317             facy=fac
1318             do k=1,3
1319               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1320             enddo
1321             if (calc_grad) then
1322 C Compute the derivatives of uy
1323             do j=1,3
1324               do k=1,3
1325                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1326      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1327                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1328               enddo
1329               uyder(j,j,1)=uyder(j,j,1)-costh
1330               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1331             enddo
1332             do j=1,2
1333               do k=1,3
1334                 do l=1,3
1335                   uygrad(l,k,j,i)=uyder(l,k,j)
1336                   uzgrad(l,k,j,i)=uzder(l,k,j)
1337                 enddo
1338               enddo
1339             enddo
1340             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1341             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1342             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1343             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1344           endif
1345           endif
1346       enddo
1347       if (calc_grad) then
1348       do i=1,nres-1
1349         vbld_inv_temp(1)=vbld_inv(i+1)
1350         if (i.lt.nres-1) then
1351           vbld_inv_temp(2)=vbld_inv(i+2)
1352         else
1353           vbld_inv_temp(2)=vbld_inv(i)
1354         endif
1355         do j=1,2
1356           do k=1,3
1357             do l=1,3
1358               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1359               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1360             enddo
1361           enddo
1362         enddo
1363       enddo
1364       endif
1365       return
1366       end
1367 C-----------------------------------------------------------------------------
1368       subroutine vec_and_deriv_test
1369       implicit real*8 (a-h,o-z)
1370       include 'DIMENSIONS'
1371       include 'DIMENSIONS.ZSCOPT'
1372       include 'COMMON.IOUNITS'
1373       include 'COMMON.GEO'
1374       include 'COMMON.VAR'
1375       include 'COMMON.LOCAL'
1376       include 'COMMON.CHAIN'
1377       include 'COMMON.VECTORS'
1378       dimension uyder(3,3,2),uzder(3,3,2)
1379 C Compute the local reference systems. For reference system (i), the
1380 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1381 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1382       do i=1,nres-1
1383           if (i.eq.nres-1) then
1384 C Case of the last full residue
1385 C Compute the Z-axis
1386             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1387             costh=dcos(pi-theta(nres))
1388             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1389 c            write (iout,*) 'fac',fac,
1390 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1391             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             do k=1,3
1393               uz(k,i)=fac*uz(k,i)
1394             enddo
1395 C Compute the derivatives of uz
1396             uzder(1,1,1)= 0.0d0
1397             uzder(2,1,1)=-dc_norm(3,i-1)
1398             uzder(3,1,1)= dc_norm(2,i-1)
1399             uzder(1,2,1)= dc_norm(3,i-1)
1400             uzder(2,2,1)= 0.0d0
1401             uzder(3,2,1)=-dc_norm(1,i-1)
1402             uzder(1,3,1)=-dc_norm(2,i-1)
1403             uzder(2,3,1)= dc_norm(1,i-1)
1404             uzder(3,3,1)= 0.0d0
1405             uzder(1,1,2)= 0.0d0
1406             uzder(2,1,2)= dc_norm(3,i)
1407             uzder(3,1,2)=-dc_norm(2,i)
1408             uzder(1,2,2)=-dc_norm(3,i)
1409             uzder(2,2,2)= 0.0d0
1410             uzder(3,2,2)= dc_norm(1,i)
1411             uzder(1,3,2)= dc_norm(2,i)
1412             uzder(2,3,2)=-dc_norm(1,i)
1413             uzder(3,3,2)= 0.0d0
1414 C Compute the Y-axis
1415             do k=1,3
1416               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1417             enddo
1418             facy=fac
1419             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1420      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1421      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1422             do k=1,3
1423 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1424               uy(k,i)=
1425 c     &        facy*(
1426      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1427      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1428 c     &        )
1429             enddo
1430 c            write (iout,*) 'facy',facy,
1431 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1432             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             do k=1,3
1434               uy(k,i)=facy*uy(k,i)
1435             enddo
1436 C Compute the derivatives of uy
1437             do j=1,3
1438               do k=1,3
1439                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1440      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1441                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1442               enddo
1443 c              uyder(j,j,1)=uyder(j,j,1)-costh
1444 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1445               uyder(j,j,1)=uyder(j,j,1)
1446      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1447               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1448      &          +uyder(j,j,2)
1449             enddo
1450             do j=1,2
1451               do k=1,3
1452                 do l=1,3
1453                   uygrad(l,k,j,i)=uyder(l,k,j)
1454                   uzgrad(l,k,j,i)=uzder(l,k,j)
1455                 enddo
1456               enddo
1457             enddo
1458             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1459             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1460             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1461             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1462           else
1463 C Other residues
1464 C Compute the Z-axis
1465             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1466             costh=dcos(pi-theta(i+2))
1467             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1468             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1469             do k=1,3
1470               uz(k,i)=fac*uz(k,i)
1471             enddo
1472 C Compute the derivatives of uz
1473             uzder(1,1,1)= 0.0d0
1474             uzder(2,1,1)=-dc_norm(3,i+1)
1475             uzder(3,1,1)= dc_norm(2,i+1)
1476             uzder(1,2,1)= dc_norm(3,i+1)
1477             uzder(2,2,1)= 0.0d0
1478             uzder(3,2,1)=-dc_norm(1,i+1)
1479             uzder(1,3,1)=-dc_norm(2,i+1)
1480             uzder(2,3,1)= dc_norm(1,i+1)
1481             uzder(3,3,1)= 0.0d0
1482             uzder(1,1,2)= 0.0d0
1483             uzder(2,1,2)= dc_norm(3,i)
1484             uzder(3,1,2)=-dc_norm(2,i)
1485             uzder(1,2,2)=-dc_norm(3,i)
1486             uzder(2,2,2)= 0.0d0
1487             uzder(3,2,2)= dc_norm(1,i)
1488             uzder(1,3,2)= dc_norm(2,i)
1489             uzder(2,3,2)=-dc_norm(1,i)
1490             uzder(3,3,2)= 0.0d0
1491 C Compute the Y-axis
1492             facy=fac
1493             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1494      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1495      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1496             do k=1,3
1497 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1498               uy(k,i)=
1499 c     &        facy*(
1500      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1501      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1502 c     &        )
1503             enddo
1504 c            write (iout,*) 'facy',facy,
1505 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1506             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             do k=1,3
1508               uy(k,i)=facy*uy(k,i)
1509             enddo
1510 C Compute the derivatives of uy
1511             do j=1,3
1512               do k=1,3
1513                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1514      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1515                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1516               enddo
1517 c              uyder(j,j,1)=uyder(j,j,1)-costh
1518 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1519               uyder(j,j,1)=uyder(j,j,1)
1520      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1521               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1522      &          +uyder(j,j,2)
1523             enddo
1524             do j=1,2
1525               do k=1,3
1526                 do l=1,3
1527                   uygrad(l,k,j,i)=uyder(l,k,j)
1528                   uzgrad(l,k,j,i)=uzder(l,k,j)
1529                 enddo
1530               enddo
1531             enddo
1532             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1533             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1534             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1535             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1536           endif
1537       enddo
1538       do i=1,nres-1
1539         do j=1,2
1540           do k=1,3
1541             do l=1,3
1542               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1543               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1544             enddo
1545           enddo
1546         enddo
1547       enddo
1548       return
1549       end
1550 C-----------------------------------------------------------------------------
1551       subroutine check_vecgrad
1552       implicit real*8 (a-h,o-z)
1553       include 'DIMENSIONS'
1554       include 'DIMENSIONS.ZSCOPT'
1555       include 'COMMON.IOUNITS'
1556       include 'COMMON.GEO'
1557       include 'COMMON.VAR'
1558       include 'COMMON.LOCAL'
1559       include 'COMMON.CHAIN'
1560       include 'COMMON.VECTORS'
1561       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1562       dimension uyt(3,maxres),uzt(3,maxres)
1563       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1564       double precision delta /1.0d-7/
1565       call vec_and_deriv
1566 cd      do i=1,nres
1567 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1570 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1571 cd     &     (dc_norm(if90,i),if90=1,3)
1572 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1574 cd          write(iout,'(a)')
1575 cd      enddo
1576       do i=1,nres
1577         do j=1,2
1578           do k=1,3
1579             do l=1,3
1580               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1581               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1582             enddo
1583           enddo
1584         enddo
1585       enddo
1586       call vec_and_deriv
1587       do i=1,nres
1588         do j=1,3
1589           uyt(j,i)=uy(j,i)
1590           uzt(j,i)=uz(j,i)
1591         enddo
1592       enddo
1593       do i=1,nres
1594 cd        write (iout,*) 'i=',i
1595         do k=1,3
1596           erij(k)=dc_norm(k,i)
1597         enddo
1598         do j=1,3
1599           do k=1,3
1600             dc_norm(k,i)=erij(k)
1601           enddo
1602           dc_norm(j,i)=dc_norm(j,i)+delta
1603 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1604 c          do k=1,3
1605 c            dc_norm(k,i)=dc_norm(k,i)/fac
1606 c          enddo
1607 c          write (iout,*) (dc_norm(k,i),k=1,3)
1608 c          write (iout,*) (erij(k),k=1,3)
1609           call vec_and_deriv
1610           do k=1,3
1611             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1612             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1613             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1614             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1615           enddo
1616 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1617 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1618 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1619         enddo
1620         do k=1,3
1621           dc_norm(k,i)=erij(k)
1622         enddo
1623 cd        do k=1,3
1624 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1625 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1626 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1627 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1628 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1629 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1630 cd          write (iout,'(a)')
1631 cd        enddo
1632       enddo
1633       return
1634       end
1635 C--------------------------------------------------------------------------
1636       subroutine set_matrices
1637       implicit real*8 (a-h,o-z)
1638       include 'DIMENSIONS'
1639       include 'DIMENSIONS.ZSCOPT'
1640       include 'COMMON.IOUNITS'
1641       include 'COMMON.GEO'
1642       include 'COMMON.VAR'
1643       include 'COMMON.LOCAL'
1644       include 'COMMON.CHAIN'
1645       include 'COMMON.DERIV'
1646       include 'COMMON.INTERACT'
1647       include 'COMMON.CONTACTS'
1648       include 'COMMON.TORSION'
1649       include 'COMMON.VECTORS'
1650       include 'COMMON.FFIELD'
1651       double precision auxvec(2),auxmat(2,2)
1652 C
1653 C Compute the virtual-bond-torsional-angle dependent quantities needed
1654 C to calculate the el-loc multibody terms of various order.
1655 C
1656       do i=3,nres+1
1657         if (i .lt. nres+1) then
1658           sin1=dsin(phi(i))
1659           cos1=dcos(phi(i))
1660           sintab(i-2)=sin1
1661           costab(i-2)=cos1
1662           obrot(1,i-2)=cos1
1663           obrot(2,i-2)=sin1
1664           sin2=dsin(2*phi(i))
1665           cos2=dcos(2*phi(i))
1666           sintab2(i-2)=sin2
1667           costab2(i-2)=cos2
1668           obrot2(1,i-2)=cos2
1669           obrot2(2,i-2)=sin2
1670           Ug(1,1,i-2)=-cos1
1671           Ug(1,2,i-2)=-sin1
1672           Ug(2,1,i-2)=-sin1
1673           Ug(2,2,i-2)= cos1
1674           Ug2(1,1,i-2)=-cos2
1675           Ug2(1,2,i-2)=-sin2
1676           Ug2(2,1,i-2)=-sin2
1677           Ug2(2,2,i-2)= cos2
1678         else
1679           costab(i-2)=1.0d0
1680           sintab(i-2)=0.0d0
1681           obrot(1,i-2)=1.0d0
1682           obrot(2,i-2)=0.0d0
1683           obrot2(1,i-2)=0.0d0
1684           obrot2(2,i-2)=0.0d0
1685           Ug(1,1,i-2)=1.0d0
1686           Ug(1,2,i-2)=0.0d0
1687           Ug(2,1,i-2)=0.0d0
1688           Ug(2,2,i-2)=1.0d0
1689           Ug2(1,1,i-2)=0.0d0
1690           Ug2(1,2,i-2)=0.0d0
1691           Ug2(2,1,i-2)=0.0d0
1692           Ug2(2,2,i-2)=0.0d0
1693         endif
1694         if (i .gt. 3 .and. i .lt. nres+1) then
1695           obrot_der(1,i-2)=-sin1
1696           obrot_der(2,i-2)= cos1
1697           Ugder(1,1,i-2)= sin1
1698           Ugder(1,2,i-2)=-cos1
1699           Ugder(2,1,i-2)=-cos1
1700           Ugder(2,2,i-2)=-sin1
1701           dwacos2=cos2+cos2
1702           dwasin2=sin2+sin2
1703           obrot2_der(1,i-2)=-dwasin2
1704           obrot2_der(2,i-2)= dwacos2
1705           Ug2der(1,1,i-2)= dwasin2
1706           Ug2der(1,2,i-2)=-dwacos2
1707           Ug2der(2,1,i-2)=-dwacos2
1708           Ug2der(2,2,i-2)=-dwasin2
1709         else
1710           obrot_der(1,i-2)=0.0d0
1711           obrot_der(2,i-2)=0.0d0
1712           Ugder(1,1,i-2)=0.0d0
1713           Ugder(1,2,i-2)=0.0d0
1714           Ugder(2,1,i-2)=0.0d0
1715           Ugder(2,2,i-2)=0.0d0
1716           obrot2_der(1,i-2)=0.0d0
1717           obrot2_der(2,i-2)=0.0d0
1718           Ug2der(1,1,i-2)=0.0d0
1719           Ug2der(1,2,i-2)=0.0d0
1720           Ug2der(2,1,i-2)=0.0d0
1721           Ug2der(2,2,i-2)=0.0d0
1722         endif
1723         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1724           iti = itortyp(itype(i-2))
1725         else
1726           iti=ntortyp+1
1727         endif
1728         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1729           iti1 = itortyp(itype(i-1))
1730         else
1731           iti1=ntortyp+1
1732         endif
1733 cd        write (iout,*) '*******i',i,' iti1',iti
1734 cd        write (iout,*) 'b1',b1(:,iti)
1735 cd        write (iout,*) 'b2',b2(:,iti)
1736 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1737         if (i .gt. iatel_s+2) then
1738           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1739           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1740           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1741           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1742           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1743           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1744           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1745         else
1746           do k=1,2
1747             Ub2(k,i-2)=0.0d0
1748             Ctobr(k,i-2)=0.0d0
1749             Dtobr2(k,i-2)=0.0d0
1750             do l=1,2
1751               EUg(l,k,i-2)=0.0d0
1752               CUg(l,k,i-2)=0.0d0
1753               DUg(l,k,i-2)=0.0d0
1754               DtUg2(l,k,i-2)=0.0d0
1755             enddo
1756           enddo
1757         endif
1758         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1759         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1760         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1761         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1762         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1763         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1764         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1765         do k=1,2
1766           muder(k,i-2)=Ub2der(k,i-2)
1767         enddo
1768         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1769           iti1 = itortyp(itype(i-1))
1770         else
1771           iti1=ntortyp+1
1772         endif
1773         do k=1,2
1774           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1775         enddo
1776 C Vectors and matrices dependent on a single virtual-bond dihedral.
1777         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1778         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1779         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1780         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1782         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1783         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1784         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1785         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1786 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1787 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1788       enddo
1789 C Matrices dependent on two consecutive virtual-bond dihedrals.
1790 C The order of matrices is from left to right.
1791       do i=2,nres-1
1792         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1793         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1794         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1795         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1796         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1797         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1798         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1799         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1800       enddo
1801 cd      do i=1,nres
1802 cd        iti = itortyp(itype(i))
1803 cd        write (iout,*) i
1804 cd        do j=1,2
1805 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1806 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1807 cd        enddo
1808 cd      enddo
1809       return
1810       end
1811 C--------------------------------------------------------------------------
1812       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1813 C
1814 C This subroutine calculates the average interaction energy and its gradient
1815 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1816 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1817 C The potential depends both on the distance of peptide-group centers and on
1818 C the orientation of the CA-CA virtual bonds.
1819 C
1820       implicit real*8 (a-h,o-z)
1821       include 'DIMENSIONS'
1822       include 'DIMENSIONS.ZSCOPT'
1823       include 'COMMON.CONTROL'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.GEO'
1826       include 'COMMON.VAR'
1827       include 'COMMON.LOCAL'
1828       include 'COMMON.CHAIN'
1829       include 'COMMON.DERIV'
1830       include 'COMMON.INTERACT'
1831       include 'COMMON.CONTACTS'
1832       include 'COMMON.TORSION'
1833       include 'COMMON.VECTORS'
1834       include 'COMMON.FFIELD'
1835       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1836      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1837       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1838      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1839       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1840 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1841       double precision scal_el /0.5d0/
1842 C 12/13/98
1843 C 13-go grudnia roku pamietnego...
1844       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1845      &                   0.0d0,1.0d0,0.0d0,
1846      &                   0.0d0,0.0d0,1.0d0/
1847 cd      write(iout,*) 'In EELEC'
1848 cd      do i=1,nloctyp
1849 cd        write(iout,*) 'Type',i
1850 cd        write(iout,*) 'B1',B1(:,i)
1851 cd        write(iout,*) 'B2',B2(:,i)
1852 cd        write(iout,*) 'CC',CC(:,:,i)
1853 cd        write(iout,*) 'DD',DD(:,:,i)
1854 cd        write(iout,*) 'EE',EE(:,:,i)
1855 cd      enddo
1856 cd      call check_vecgrad
1857 cd      stop
1858       if (icheckgrad.eq.1) then
1859         do i=1,nres-1
1860           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1861           do k=1,3
1862             dc_norm(k,i)=dc(k,i)*fac
1863           enddo
1864 c          write (iout,*) 'i',i,' fac',fac
1865         enddo
1866       endif
1867       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1868      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1869      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1870 cd      if (wel_loc.gt.0.0d0) then
1871         if (icheckgrad.eq.1) then
1872         call vec_and_deriv_test
1873         else
1874         call vec_and_deriv
1875         endif
1876         call set_matrices
1877       endif
1878 cd      do i=1,nres-1
1879 cd        write (iout,*) 'i=',i
1880 cd        do k=1,3
1881 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1882 cd        enddo
1883 cd        do k=1,3
1884 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1885 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1886 cd        enddo
1887 cd      enddo
1888       num_conti_hb=0
1889       ees=0.0D0
1890       evdw1=0.0D0
1891       eel_loc=0.0d0
1892       eello_turn3=0.0d0
1893       eello_turn4=0.0d0
1894       ind=0
1895       do i=1,nres
1896         num_cont_hb(i)=0
1897       enddo
1898 cd      print '(a)','Enter EELEC'
1899 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1900       do i=1,nres
1901         gel_loc_loc(i)=0.0d0
1902         gcorr_loc(i)=0.0d0
1903       enddo
1904       do i=iatel_s,iatel_e
1905         if (itel(i).eq.0) goto 1215
1906         dxi=dc(1,i)
1907         dyi=dc(2,i)
1908         dzi=dc(3,i)
1909         dx_normi=dc_norm(1,i)
1910         dy_normi=dc_norm(2,i)
1911         dz_normi=dc_norm(3,i)
1912         xmedi=c(1,i)+0.5d0*dxi
1913         ymedi=c(2,i)+0.5d0*dyi
1914         zmedi=c(3,i)+0.5d0*dzi
1915         num_conti=0
1916 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1917         do j=ielstart(i),ielend(i)
1918           if (itel(j).eq.0) goto 1216
1919           ind=ind+1
1920           iteli=itel(i)
1921           itelj=itel(j)
1922           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1923           aaa=app(iteli,itelj)
1924           bbb=bpp(iteli,itelj)
1925 C Diagnostics only!!!
1926 c         aaa=0.0D0
1927 c         bbb=0.0D0
1928 c         ael6i=0.0D0
1929 c         ael3i=0.0D0
1930 C End diagnostics
1931           ael6i=ael6(iteli,itelj)
1932           ael3i=ael3(iteli,itelj)
1933           dxj=dc(1,j)
1934           dyj=dc(2,j)
1935           dzj=dc(3,j)
1936           dx_normj=dc_norm(1,j)
1937           dy_normj=dc_norm(2,j)
1938           dz_normj=dc_norm(3,j)
1939           xj=c(1,j)+0.5D0*dxj-xmedi
1940           yj=c(2,j)+0.5D0*dyj-ymedi
1941           zj=c(3,j)+0.5D0*dzj-zmedi
1942           rij=xj*xj+yj*yj+zj*zj
1943           rrmij=1.0D0/rij
1944           rij=dsqrt(rij)
1945           rmij=1.0D0/rij
1946           r3ij=rrmij*rmij
1947           r6ij=r3ij*r3ij
1948           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1949           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1950           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1951           fac=cosa-3.0D0*cosb*cosg
1952           ev1=aaa*r6ij*r6ij
1953 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1954           if (j.eq.i+2) ev1=scal_el*ev1
1955           ev2=bbb*r6ij
1956           fac3=ael6i*r6ij
1957           fac4=ael3i*r3ij
1958           evdwij=ev1+ev2
1959           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1960           el2=fac4*fac
1961           eesij=el1+el2
1962 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1963 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1964           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1965           ees=ees+eesij
1966           evdw1=evdw1+evdwij
1967 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1968 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1969 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1970 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1971 C
1972 C Calculate contributions to the Cartesian gradient.
1973 C
1974 #ifdef SPLITELE
1975           facvdw=-6*rrmij*(ev1+evdwij)
1976           facel=-3*rrmij*(el1+eesij)
1977           fac1=fac
1978           erij(1)=xj*rmij
1979           erij(2)=yj*rmij
1980           erij(3)=zj*rmij
1981           if (calc_grad) then
1982 *
1983 * Radial derivatives. First process both termini of the fragment (i,j)
1984 *
1985           ggg(1)=facel*xj
1986           ggg(2)=facel*yj
1987           ggg(3)=facel*zj
1988           do k=1,3
1989             ghalf=0.5D0*ggg(k)
1990             gelc(k,i)=gelc(k,i)+ghalf
1991             gelc(k,j)=gelc(k,j)+ghalf
1992           enddo
1993 *
1994 * Loop over residues i+1 thru j-1.
1995 *
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           ggg(1)=facvdw*xj
2002           ggg(2)=facvdw*yj
2003           ggg(3)=facvdw*zj
2004           do k=1,3
2005             ghalf=0.5D0*ggg(k)
2006             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2007             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2008           enddo
2009 *
2010 * Loop over residues i+1 thru j-1.
2011 *
2012           do k=i+1,j-1
2013             do l=1,3
2014               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2015             enddo
2016           enddo
2017 #else
2018           facvdw=ev1+evdwij
2019           facel=el1+eesij
2020           fac1=fac
2021           fac=-3*rrmij*(facvdw+facvdw+facel)
2022           erij(1)=xj*rmij
2023           erij(2)=yj*rmij
2024           erij(3)=zj*rmij
2025           if (calc_grad) then
2026 *
2027 * Radial derivatives. First process both termini of the fragment (i,j)
2028 *
2029           ggg(1)=fac*xj
2030           ggg(2)=fac*yj
2031           ggg(3)=fac*zj
2032           do k=1,3
2033             ghalf=0.5D0*ggg(k)
2034             gelc(k,i)=gelc(k,i)+ghalf
2035             gelc(k,j)=gelc(k,j)+ghalf
2036           enddo
2037 *
2038 * Loop over residues i+1 thru j-1.
2039 *
2040           do k=i+1,j-1
2041             do l=1,3
2042               gelc(l,k)=gelc(l,k)+ggg(l)
2043             enddo
2044           enddo
2045 #endif
2046 *
2047 * Angular part
2048 *
2049           ecosa=2.0D0*fac3*fac1+fac4
2050           fac4=-3.0D0*fac4
2051           fac3=-6.0D0*fac3
2052           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2053           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2054           do k=1,3
2055             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2056             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2057           enddo
2058 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2059 cd   &          (dcosg(k),k=1,3)
2060           do k=1,3
2061             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2062           enddo
2063           do k=1,3
2064             ghalf=0.5D0*ggg(k)
2065             gelc(k,i)=gelc(k,i)+ghalf
2066      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2067      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2068             gelc(k,j)=gelc(k,j)+ghalf
2069      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2070      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2071           enddo
2072           do k=i+1,j-1
2073             do l=1,3
2074               gelc(l,k)=gelc(l,k)+ggg(l)
2075             enddo
2076           enddo
2077           endif
2078
2079           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2080      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2081      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2082 C
2083 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2084 C   energy of a peptide unit is assumed in the form of a second-order
2085 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2086 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2087 C   are computed for EVERY pair of non-contiguous peptide groups.
2088 C
2089           if (j.lt.nres-1) then
2090             j1=j+1
2091             j2=j-1
2092           else
2093             j1=j-1
2094             j2=j-2
2095           endif
2096           kkk=0
2097           do k=1,2
2098             do l=1,2
2099               kkk=kkk+1
2100               muij(kkk)=mu(k,i)*mu(l,j)
2101             enddo
2102           enddo
2103 cd         write (iout,*) 'EELEC: i',i,' j',j
2104 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2105 cd          write(iout,*) 'muij',muij
2106           ury=scalar(uy(1,i),erij)
2107           urz=scalar(uz(1,i),erij)
2108           vry=scalar(uy(1,j),erij)
2109           vrz=scalar(uz(1,j),erij)
2110           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2111           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2112           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2113           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2114 C For diagnostics only
2115 cd          a22=1.0d0
2116 cd          a23=1.0d0
2117 cd          a32=1.0d0
2118 cd          a33=1.0d0
2119           fac=dsqrt(-ael6i)*r3ij
2120 cd          write (2,*) 'fac=',fac
2121 C For diagnostics only
2122 cd          fac=1.0d0
2123           a22=a22*fac
2124           a23=a23*fac
2125           a32=a32*fac
2126           a33=a33*fac
2127 cd          write (iout,'(4i5,4f10.5)')
2128 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2129 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2130 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2131 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2132 cd          write (iout,'(4f10.5)')
2133 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2134 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2135 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2136 cd           write (iout,'(2i3,9f10.5/)') i,j,
2137 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2138           if (calc_grad) then
2139 C Derivatives of the elements of A in virtual-bond vectors
2140           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2141 cd          do k=1,3
2142 cd            do l=1,3
2143 cd              erder(k,l)=0.0d0
2144 cd            enddo
2145 cd          enddo
2146           do k=1,3
2147             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2148             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2149             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2150             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2151             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2152             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2153             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2154             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2155             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2156             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2157             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2158             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2159           enddo
2160 cd          do k=1,3
2161 cd            do l=1,3
2162 cd              uryg(k,l)=0.0d0
2163 cd              urzg(k,l)=0.0d0
2164 cd              vryg(k,l)=0.0d0
2165 cd              vrzg(k,l)=0.0d0
2166 cd            enddo
2167 cd          enddo
2168 C Compute radial contributions to the gradient
2169           facr=-3.0d0*rrmij
2170           a22der=a22*facr
2171           a23der=a23*facr
2172           a32der=a32*facr
2173           a33der=a33*facr
2174 cd          a22der=0.0d0
2175 cd          a23der=0.0d0
2176 cd          a32der=0.0d0
2177 cd          a33der=0.0d0
2178           agg(1,1)=a22der*xj
2179           agg(2,1)=a22der*yj
2180           agg(3,1)=a22der*zj
2181           agg(1,2)=a23der*xj
2182           agg(2,2)=a23der*yj
2183           agg(3,2)=a23der*zj
2184           agg(1,3)=a32der*xj
2185           agg(2,3)=a32der*yj
2186           agg(3,3)=a32der*zj
2187           agg(1,4)=a33der*xj
2188           agg(2,4)=a33der*yj
2189           agg(3,4)=a33der*zj
2190 C Add the contributions coming from er
2191           fac3=-3.0d0*fac
2192           do k=1,3
2193             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2194             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2195             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2196             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2197           enddo
2198           do k=1,3
2199 C Derivatives in DC(i)
2200             ghalf1=0.5d0*agg(k,1)
2201             ghalf2=0.5d0*agg(k,2)
2202             ghalf3=0.5d0*agg(k,3)
2203             ghalf4=0.5d0*agg(k,4)
2204             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2205      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2206             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2207      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2208             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2209      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2210             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2211      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2212 C Derivatives in DC(i+1)
2213             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2214      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2215             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2216      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2217             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2218      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2219             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2220      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2221 C Derivatives in DC(j)
2222             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2223      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2224             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2226             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2227      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2228             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2230 C Derivatives in DC(j+1) or DC(nres-1)
2231             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2232      &      -3.0d0*vryg(k,3)*ury)
2233             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vrzg(k,3)*ury)
2235             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2236      &      -3.0d0*vryg(k,3)*urz)
2237             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vrzg(k,3)*urz)
2239 cd            aggi(k,1)=ghalf1
2240 cd            aggi(k,2)=ghalf2
2241 cd            aggi(k,3)=ghalf3
2242 cd            aggi(k,4)=ghalf4
2243 C Derivatives in DC(i+1)
2244 cd            aggi1(k,1)=agg(k,1)
2245 cd            aggi1(k,2)=agg(k,2)
2246 cd            aggi1(k,3)=agg(k,3)
2247 cd            aggi1(k,4)=agg(k,4)
2248 C Derivatives in DC(j)
2249 cd            aggj(k,1)=ghalf1
2250 cd            aggj(k,2)=ghalf2
2251 cd            aggj(k,3)=ghalf3
2252 cd            aggj(k,4)=ghalf4
2253 C Derivatives in DC(j+1)
2254 cd            aggj1(k,1)=0.0d0
2255 cd            aggj1(k,2)=0.0d0
2256 cd            aggj1(k,3)=0.0d0
2257 cd            aggj1(k,4)=0.0d0
2258             if (j.eq.nres-1 .and. i.lt.j-2) then
2259               do l=1,4
2260                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2261 cd                aggj1(k,l)=agg(k,l)
2262               enddo
2263             endif
2264           enddo
2265           endif
2266 c          goto 11111
2267 C Check the loc-el terms by numerical integration
2268           acipa(1,1)=a22
2269           acipa(1,2)=a23
2270           acipa(2,1)=a32
2271           acipa(2,2)=a33
2272           a22=-a22
2273           a23=-a23
2274           do l=1,2
2275             do k=1,3
2276               agg(k,l)=-agg(k,l)
2277               aggi(k,l)=-aggi(k,l)
2278               aggi1(k,l)=-aggi1(k,l)
2279               aggj(k,l)=-aggj(k,l)
2280               aggj1(k,l)=-aggj1(k,l)
2281             enddo
2282           enddo
2283           if (j.lt.nres-1) then
2284             a22=-a22
2285             a32=-a32
2286             do l=1,3,2
2287               do k=1,3
2288                 agg(k,l)=-agg(k,l)
2289                 aggi(k,l)=-aggi(k,l)
2290                 aggi1(k,l)=-aggi1(k,l)
2291                 aggj(k,l)=-aggj(k,l)
2292                 aggj1(k,l)=-aggj1(k,l)
2293               enddo
2294             enddo
2295           else
2296             a22=-a22
2297             a23=-a23
2298             a32=-a32
2299             a33=-a33
2300             do l=1,4
2301               do k=1,3
2302                 agg(k,l)=-agg(k,l)
2303                 aggi(k,l)=-aggi(k,l)
2304                 aggi1(k,l)=-aggi1(k,l)
2305                 aggj(k,l)=-aggj(k,l)
2306                 aggj1(k,l)=-aggj1(k,l)
2307               enddo
2308             enddo
2309           endif
2310           ENDIF ! WCORR
2311 11111     continue
2312           IF (wel_loc.gt.0.0d0) THEN
2313 C Contribution to the local-electrostatic energy coming from the i-j pair
2314           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2315      &     +a33*muij(4)
2316 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2317 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2318           eel_loc=eel_loc+eel_loc_ij
2319 C Partial derivatives in virtual-bond dihedral angles gamma
2320           if (calc_grad) then
2321           if (i.gt.1)
2322      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2323      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2324      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2325           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2326      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2327      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2328 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2329 cd          write(iout,*) 'agg  ',agg
2330 cd          write(iout,*) 'aggi ',aggi
2331 cd          write(iout,*) 'aggi1',aggi1
2332 cd          write(iout,*) 'aggj ',aggj
2333 cd          write(iout,*) 'aggj1',aggj1
2334
2335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2336           do l=1,3
2337             ggg(l)=agg(l,1)*muij(1)+
2338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2339           enddo
2340           do k=i+2,j2
2341             do l=1,3
2342               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2343             enddo
2344           enddo
2345 C Remaining derivatives of eello
2346           do l=1,3
2347             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2348      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2349             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2350      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2351             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2352      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2353             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2354      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2355           enddo
2356           endif
2357           ENDIF
2358           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2359 C Contributions from turns
2360             a_temp(1,1)=a22
2361             a_temp(1,2)=a23
2362             a_temp(2,1)=a32
2363             a_temp(2,2)=a33
2364             call eturn34(i,j,eello_turn3,eello_turn4)
2365           endif
2366 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2367           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2368 C
2369 C Calculate the contact function. The ith column of the array JCONT will
2370 C contain the numbers of atoms that make contacts with the atom I (of numbers
2371 C greater than I). The arrays FACONT and GACONT will contain the values of
2372 C the contact function and its derivative.
2373 c           r0ij=1.02D0*rpp(iteli,itelj)
2374 c           r0ij=1.11D0*rpp(iteli,itelj)
2375             r0ij=2.20D0*rpp(iteli,itelj)
2376 c           r0ij=1.55D0*rpp(iteli,itelj)
2377             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2378             if (fcont.gt.0.0D0) then
2379               num_conti=num_conti+1
2380               if (num_conti.gt.maxconts) then
2381                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2382      &                         ' will skip next contacts for this conf.'
2383               else
2384                 jcont_hb(num_conti,i)=j
2385                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2386      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2387 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2388 C  terms.
2389                 d_cont(num_conti,i)=rij
2390 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2391 C     --- Electrostatic-interaction matrix ---
2392                 a_chuj(1,1,num_conti,i)=a22
2393                 a_chuj(1,2,num_conti,i)=a23
2394                 a_chuj(2,1,num_conti,i)=a32
2395                 a_chuj(2,2,num_conti,i)=a33
2396 C     --- Gradient of rij
2397                 do kkk=1,3
2398                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2399                 enddo
2400 c             if (i.eq.1) then
2401 c                a_chuj(1,1,num_conti,i)=-0.61d0
2402 c                a_chuj(1,2,num_conti,i)= 0.4d0
2403 c                a_chuj(2,1,num_conti,i)= 0.65d0
2404 c                a_chuj(2,2,num_conti,i)= 0.50d0
2405 c             else if (i.eq.2) then
2406 c                a_chuj(1,1,num_conti,i)= 0.0d0
2407 c                a_chuj(1,2,num_conti,i)= 0.0d0
2408 c                a_chuj(2,1,num_conti,i)= 0.0d0
2409 c                a_chuj(2,2,num_conti,i)= 0.0d0
2410 c             endif
2411 C     --- and its gradients
2412 cd                write (iout,*) 'i',i,' j',j
2413 cd                do kkk=1,3
2414 cd                write (iout,*) 'iii 1 kkk',kkk
2415 cd                write (iout,*) agg(kkk,:)
2416 cd                enddo
2417 cd                do kkk=1,3
2418 cd                write (iout,*) 'iii 2 kkk',kkk
2419 cd                write (iout,*) aggi(kkk,:)
2420 cd                enddo
2421 cd                do kkk=1,3
2422 cd                write (iout,*) 'iii 3 kkk',kkk
2423 cd                write (iout,*) aggi1(kkk,:)
2424 cd                enddo
2425 cd                do kkk=1,3
2426 cd                write (iout,*) 'iii 4 kkk',kkk
2427 cd                write (iout,*) aggj(kkk,:)
2428 cd                enddo
2429 cd                do kkk=1,3
2430 cd                write (iout,*) 'iii 5 kkk',kkk
2431 cd                write (iout,*) aggj1(kkk,:)
2432 cd                enddo
2433                 kkll=0
2434                 do k=1,2
2435                   do l=1,2
2436                     kkll=kkll+1
2437                     do m=1,3
2438                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2439                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2440                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2441                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2442                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2443 c                      do mm=1,5
2444 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2445 c                      enddo
2446                     enddo
2447                   enddo
2448                 enddo
2449                 ENDIF
2450                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2451 C Calculate contact energies
2452                 cosa4=4.0D0*cosa
2453                 wij=cosa-3.0D0*cosb*cosg
2454                 cosbg1=cosb+cosg
2455                 cosbg2=cosb-cosg
2456 c               fac3=dsqrt(-ael6i)/r0ij**3
2457                 fac3=dsqrt(-ael6i)*r3ij
2458                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2459                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2460 c               ees0mij=0.0D0
2461                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2462                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2463 C Diagnostics. Comment out or remove after debugging!
2464 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2465 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2466 c               ees0m(num_conti,i)=0.0D0
2467 C End diagnostics.
2468 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2469 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2470                 facont_hb(num_conti,i)=fcont
2471                 if (calc_grad) then
2472 C Angular derivatives of the contact function
2473                 ees0pij1=fac3/ees0pij
2474                 ees0mij1=fac3/ees0mij
2475                 fac3p=-3.0D0*fac3*rrmij
2476                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2477                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2478 c               ees0mij1=0.0D0
2479                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2480                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2481                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2482                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2483                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2484                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2485                 ecosap=ecosa1+ecosa2
2486                 ecosbp=ecosb1+ecosb2
2487                 ecosgp=ecosg1+ecosg2
2488                 ecosam=ecosa1-ecosa2
2489                 ecosbm=ecosb1-ecosb2
2490                 ecosgm=ecosg1-ecosg2
2491 C Diagnostics
2492 c               ecosap=ecosa1
2493 c               ecosbp=ecosb1
2494 c               ecosgp=ecosg1
2495 c               ecosam=0.0D0
2496 c               ecosbm=0.0D0
2497 c               ecosgm=0.0D0
2498 C End diagnostics
2499                 fprimcont=fprimcont/rij
2500 cd              facont_hb(num_conti,i)=1.0D0
2501 C Following line is for diagnostics.
2502 cd              fprimcont=0.0D0
2503                 do k=1,3
2504                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2505                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2506                 enddo
2507                 do k=1,3
2508                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2509                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2510                 enddo
2511                 gggp(1)=gggp(1)+ees0pijp*xj
2512                 gggp(2)=gggp(2)+ees0pijp*yj
2513                 gggp(3)=gggp(3)+ees0pijp*zj
2514                 gggm(1)=gggm(1)+ees0mijp*xj
2515                 gggm(2)=gggm(2)+ees0mijp*yj
2516                 gggm(3)=gggm(3)+ees0mijp*zj
2517 C Derivatives due to the contact function
2518                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2519                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2520                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2521                 do k=1,3
2522                   ghalfp=0.5D0*gggp(k)
2523                   ghalfm=0.5D0*gggm(k)
2524                   gacontp_hb1(k,num_conti,i)=ghalfp
2525      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2526      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2527                   gacontp_hb2(k,num_conti,i)=ghalfp
2528      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2529      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2530                   gacontp_hb3(k,num_conti,i)=gggp(k)
2531                   gacontm_hb1(k,num_conti,i)=ghalfm
2532      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2533      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2534                   gacontm_hb2(k,num_conti,i)=ghalfm
2535      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2536      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2537                   gacontm_hb3(k,num_conti,i)=gggm(k)
2538                 enddo
2539                 endif
2540 C Diagnostics. Comment out or remove after debugging!
2541 cdiag           do k=1,3
2542 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2543 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2544 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2545 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2546 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2548 cdiag           enddo
2549               ENDIF ! wcorr
2550               endif  ! num_conti.le.maxconts
2551             endif  ! fcont.gt.0
2552           endif    ! j.gt.i+1
2553  1216     continue
2554         enddo ! j
2555         num_cont_hb(i)=num_conti
2556  1215   continue
2557       enddo   ! i
2558 cd      do i=1,nres
2559 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2560 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2561 cd      enddo
2562 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2563 ccc      eel_loc=eel_loc+eello_turn3
2564       return
2565       end
2566 C-----------------------------------------------------------------------------
2567       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2568 C Third- and fourth-order contributions from turns
2569       implicit real*8 (a-h,o-z)
2570       include 'DIMENSIONS'
2571       include 'DIMENSIONS.ZSCOPT'
2572       include 'COMMON.IOUNITS'
2573       include 'COMMON.GEO'
2574       include 'COMMON.VAR'
2575       include 'COMMON.LOCAL'
2576       include 'COMMON.CHAIN'
2577       include 'COMMON.DERIV'
2578       include 'COMMON.INTERACT'
2579       include 'COMMON.CONTACTS'
2580       include 'COMMON.TORSION'
2581       include 'COMMON.VECTORS'
2582       include 'COMMON.FFIELD'
2583       dimension ggg(3)
2584       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2585      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2586      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2587       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2588      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2589       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2590       if (j.eq.i+2) then
2591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2592 C
2593 C               Third-order contributions
2594 C
2595 C                 (i+2)o----(i+3)
2596 C                      | |
2597 C                      | |
2598 C                 (i+1)o----i
2599 C
2600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2601 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2602         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2603         call transpose2(auxmat(1,1),auxmat1(1,1))
2604         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2605         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2607 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2608 cd     &    ' eello_turn3_num',4*eello_turn3_num
2609         if (calc_grad) then
2610 C Derivatives in gamma(i)
2611         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2612         call transpose2(auxmat2(1,1),pizda(1,1))
2613         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2614         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2615 C Derivatives in gamma(i+1)
2616         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2617         call transpose2(auxmat2(1,1),pizda(1,1))
2618         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2619         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2620      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2621 C Cartesian derivatives
2622         do l=1,3
2623           a_temp(1,1)=aggi(l,1)
2624           a_temp(1,2)=aggi(l,2)
2625           a_temp(2,1)=aggi(l,3)
2626           a_temp(2,2)=aggi(l,4)
2627           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2628           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2629      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2630           a_temp(1,1)=aggi1(l,1)
2631           a_temp(1,2)=aggi1(l,2)
2632           a_temp(2,1)=aggi1(l,3)
2633           a_temp(2,2)=aggi1(l,4)
2634           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2635           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2636      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2637           a_temp(1,1)=aggj(l,1)
2638           a_temp(1,2)=aggj(l,2)
2639           a_temp(2,1)=aggj(l,3)
2640           a_temp(2,2)=aggj(l,4)
2641           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2642           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2643      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2644           a_temp(1,1)=aggj1(l,1)
2645           a_temp(1,2)=aggj1(l,2)
2646           a_temp(2,1)=aggj1(l,3)
2647           a_temp(2,2)=aggj1(l,4)
2648           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2649           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2650      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2651         enddo
2652         endif
2653       else if (j.eq.i+3) then
2654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2655 C
2656 C               Fourth-order contributions
2657 C
2658 C                 (i+3)o----(i+4)
2659 C                     /  |
2660 C               (i+2)o   |
2661 C                     \  |
2662 C                 (i+1)o----i
2663 C
2664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2665 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2666         iti1=itortyp(itype(i+1))
2667         iti2=itortyp(itype(i+2))
2668         iti3=itortyp(itype(i+3))
2669         call transpose2(EUg(1,1,i+1),e1t(1,1))
2670         call transpose2(Eug(1,1,i+2),e2t(1,1))
2671         call transpose2(Eug(1,1,i+3),e3t(1,1))
2672         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2673         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2674         s1=scalar2(b1(1,iti2),auxvec(1))
2675         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2676         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2677         s2=scalar2(b1(1,iti1),auxvec(1))
2678         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2679         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2681         eello_turn4=eello_turn4-(s1+s2+s3)
2682 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2683 cd     &    ' eello_turn4_num',8*eello_turn4_num
2684 C Derivatives in gamma(i)
2685         if (calc_grad) then
2686         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2687         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2688         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2689         s1=scalar2(b1(1,iti2),auxvec(1))
2690         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2691         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2692         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2693 C Derivatives in gamma(i+1)
2694         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2695         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2696         s2=scalar2(b1(1,iti1),auxvec(1))
2697         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2698         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2699         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2701 C Derivatives in gamma(i+2)
2702         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2703         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2704         s1=scalar2(b1(1,iti2),auxvec(1))
2705         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2706         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2707         s2=scalar2(b1(1,iti1),auxvec(1))
2708         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2709         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2710         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2711         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2712 C Cartesian derivatives
2713 C Derivatives of this turn contributions in DC(i+2)
2714         if (j.lt.nres-1) then
2715           do l=1,3
2716             a_temp(1,1)=agg(l,1)
2717             a_temp(1,2)=agg(l,2)
2718             a_temp(2,1)=agg(l,3)
2719             a_temp(2,2)=agg(l,4)
2720             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2721             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2722             s1=scalar2(b1(1,iti2),auxvec(1))
2723             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2724             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2725             s2=scalar2(b1(1,iti1),auxvec(1))
2726             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2727             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2728             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2729             ggg(l)=-(s1+s2+s3)
2730             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2731           enddo
2732         endif
2733 C Remaining derivatives of this turn contribution
2734         do l=1,3
2735           a_temp(1,1)=aggi(l,1)
2736           a_temp(1,2)=aggi(l,2)
2737           a_temp(2,1)=aggi(l,3)
2738           a_temp(2,2)=aggi(l,4)
2739           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2740           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2741           s1=scalar2(b1(1,iti2),auxvec(1))
2742           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2743           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2744           s2=scalar2(b1(1,iti1),auxvec(1))
2745           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2746           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2747           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2748           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2749           a_temp(1,1)=aggi1(l,1)
2750           a_temp(1,2)=aggi1(l,2)
2751           a_temp(2,1)=aggi1(l,3)
2752           a_temp(2,2)=aggi1(l,4)
2753           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2754           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2755           s1=scalar2(b1(1,iti2),auxvec(1))
2756           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2757           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2758           s2=scalar2(b1(1,iti1),auxvec(1))
2759           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2760           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2761           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2762           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2763           a_temp(1,1)=aggj(l,1)
2764           a_temp(1,2)=aggj(l,2)
2765           a_temp(2,1)=aggj(l,3)
2766           a_temp(2,2)=aggj(l,4)
2767           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2768           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2769           s1=scalar2(b1(1,iti2),auxvec(1))
2770           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2771           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2772           s2=scalar2(b1(1,iti1),auxvec(1))
2773           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2774           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2775           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2776           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2777           a_temp(1,1)=aggj1(l,1)
2778           a_temp(1,2)=aggj1(l,2)
2779           a_temp(2,1)=aggj1(l,3)
2780           a_temp(2,2)=aggj1(l,4)
2781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2783           s1=scalar2(b1(1,iti2),auxvec(1))
2784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2786           s2=scalar2(b1(1,iti1),auxvec(1))
2787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2790           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2791         enddo
2792         endif
2793       endif
2794       return
2795       end
2796 C-----------------------------------------------------------------------------
2797       subroutine vecpr(u,v,w)
2798       implicit real*8(a-h,o-z)
2799       dimension u(3),v(3),w(3)
2800       w(1)=u(2)*v(3)-u(3)*v(2)
2801       w(2)=-u(1)*v(3)+u(3)*v(1)
2802       w(3)=u(1)*v(2)-u(2)*v(1)
2803       return
2804       end
2805 C-----------------------------------------------------------------------------
2806       subroutine unormderiv(u,ugrad,unorm,ungrad)
2807 C This subroutine computes the derivatives of a normalized vector u, given
2808 C the derivatives computed without normalization conditions, ugrad. Returns
2809 C ungrad.
2810       implicit none
2811       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2812       double precision vec(3)
2813       double precision scalar
2814       integer i,j
2815 c      write (2,*) 'ugrad',ugrad
2816 c      write (2,*) 'u',u
2817       do i=1,3
2818         vec(i)=scalar(ugrad(1,i),u(1))
2819       enddo
2820 c      write (2,*) 'vec',vec
2821       do i=1,3
2822         do j=1,3
2823           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2824         enddo
2825       enddo
2826 c      write (2,*) 'ungrad',ungrad
2827       return
2828       end
2829 C-----------------------------------------------------------------------------
2830       subroutine escp(evdw2,evdw2_14)
2831 C
2832 C This subroutine calculates the excluded-volume interaction energy between
2833 C peptide-group centers and side chains and its gradient in virtual-bond and
2834 C side-chain vectors.
2835 C
2836       implicit real*8 (a-h,o-z)
2837       include 'DIMENSIONS'
2838       include 'DIMENSIONS.ZSCOPT'
2839       include 'COMMON.GEO'
2840       include 'COMMON.VAR'
2841       include 'COMMON.LOCAL'
2842       include 'COMMON.CHAIN'
2843       include 'COMMON.DERIV'
2844       include 'COMMON.INTERACT'
2845       include 'COMMON.FFIELD'
2846       include 'COMMON.IOUNITS'
2847       dimension ggg(3)
2848       evdw2=0.0D0
2849       evdw2_14=0.0d0
2850 cd    print '(a)','Enter ESCP'
2851 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2852 c     &  ' scal14',scal14
2853       do i=iatscp_s,iatscp_e
2854         iteli=itel(i)
2855 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2856 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2857         if (iteli.eq.0) goto 1225
2858         xi=0.5D0*(c(1,i)+c(1,i+1))
2859         yi=0.5D0*(c(2,i)+c(2,i+1))
2860         zi=0.5D0*(c(3,i)+c(3,i+1))
2861
2862         do iint=1,nscp_gr(i)
2863
2864         do j=iscpstart(i,iint),iscpend(i,iint)
2865           itypj=itype(j)
2866 C Uncomment following three lines for SC-p interactions
2867 c         xj=c(1,nres+j)-xi
2868 c         yj=c(2,nres+j)-yi
2869 c         zj=c(3,nres+j)-zi
2870 C Uncomment following three lines for Ca-p interactions
2871           xj=c(1,j)-xi
2872           yj=c(2,j)-yi
2873           zj=c(3,j)-zi
2874           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2875           fac=rrij**expon2
2876           e1=fac*fac*aad(itypj,iteli)
2877           e2=fac*bad(itypj,iteli)
2878           if (iabs(j-i) .le. 2) then
2879             e1=scal14*e1
2880             e2=scal14*e2
2881             evdw2_14=evdw2_14+e1+e2
2882           endif
2883           evdwij=e1+e2
2884 c          write (iout,*) i,j,evdwij
2885           evdw2=evdw2+evdwij
2886           if (calc_grad) then
2887 C
2888 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2889 C
2890           fac=-(evdwij+e1)*rrij
2891           ggg(1)=xj*fac
2892           ggg(2)=yj*fac
2893           ggg(3)=zj*fac
2894           if (j.lt.i) then
2895 cd          write (iout,*) 'j<i'
2896 C Uncomment following three lines for SC-p interactions
2897 c           do k=1,3
2898 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2899 c           enddo
2900           else
2901 cd          write (iout,*) 'j>i'
2902             do k=1,3
2903               ggg(k)=-ggg(k)
2904 C Uncomment following line for SC-p interactions
2905 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2906             enddo
2907           endif
2908           do k=1,3
2909             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2910           enddo
2911           kstart=min0(i+1,j)
2912           kend=max0(i-1,j-1)
2913 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2914 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2915           do k=kstart,kend
2916             do l=1,3
2917               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2918             enddo
2919           enddo
2920           endif
2921         enddo
2922         enddo ! iint
2923  1225   continue
2924       enddo ! i
2925       do i=1,nct
2926         do j=1,3
2927           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2928           gradx_scp(j,i)=expon*gradx_scp(j,i)
2929         enddo
2930       enddo
2931 C******************************************************************************
2932 C
2933 C                              N O T E !!!
2934 C
2935 C To save time the factor EXPON has been extracted from ALL components
2936 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2937 C use!
2938 C
2939 C******************************************************************************
2940       return
2941       end
2942 C--------------------------------------------------------------------------
2943       subroutine edis(ehpb)
2944 C
2945 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2946 C
2947       implicit real*8 (a-h,o-z)
2948       include 'DIMENSIONS'
2949       include 'COMMON.SBRIDGE'
2950       include 'COMMON.CHAIN'
2951       include 'COMMON.DERIV'
2952       include 'COMMON.VAR'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.IOUNITS'
2955       dimension ggg(3)
2956       ehpb=0.0D0
2957 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2958 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2959       if (link_end.eq.0) return
2960       do i=link_start,link_end
2961 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2962 C CA-CA distance used in regularization of structure.
2963         ii=ihpb(i)
2964         jj=jhpb(i)
2965 C iii and jjj point to the residues for which the distance is assigned.
2966         if (ii.gt.nres) then
2967           iii=ii-nres
2968           jjj=jj-nres
2969         else
2970           iii=ii
2971           jjj=jj
2972         endif
2973 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2974 c     &    dhpb(i),dhpb1(i),forcon(i)
2975 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2976 C    distance and angle dependent SS bond potential.
2977         if (.not.dyn_ss .and. i.le.nss) then
2978 C 15/02/13 CC dynamic SSbond - additional check
2979         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2980           call ssbond_ene(iii,jjj,eij)
2981           ehpb=ehpb+2*eij
2982          endif
2983 cd          write (iout,*) "eij",eij
2984         else if (ii.gt.nres .and. jj.gt.nres) then
2985 c Restraints from contact prediction
2986           dd=dist(ii,jj)
2987           if (dhpb1(i).gt.0.0d0) then
2988             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2989             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2990 c            write (iout,*) "beta nmr",
2991 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2992           else
2993             dd=dist(ii,jj)
2994             rdis=dd-dhpb(i)
2995 C Get the force constant corresponding to this distance.
2996             waga=forcon(i)
2997 C Calculate the contribution to energy.
2998             ehpb=ehpb+waga*rdis*rdis
2999 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3000 C
3001 C Evaluate gradient.
3002 C
3003             fac=waga*rdis/dd
3004           endif
3005           do j=1,3
3006             ggg(j)=fac*(c(j,jj)-c(j,ii))
3007           enddo
3008           do j=1,3
3009             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3010             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3011           enddo
3012           do k=1,3
3013             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3014             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3015           enddo
3016         else
3017 C Calculate the distance between the two points and its difference from the
3018 C target distance.
3019           dd=dist(ii,jj)
3020           if (dhpb1(i).gt.0.0d0) then
3021             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3022             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3023 c            write (iout,*) "alph nmr",
3024 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3025           else
3026             rdis=dd-dhpb(i)
3027 C Get the force constant corresponding to this distance.
3028             waga=forcon(i)
3029 C Calculate the contribution to energy.
3030             ehpb=ehpb+waga*rdis*rdis
3031 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3032 C
3033 C Evaluate gradient.
3034 C
3035             fac=waga*rdis/dd
3036           endif
3037 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3038 cd   &   ' waga=',waga,' fac=',fac
3039             do j=1,3
3040               ggg(j)=fac*(c(j,jj)-c(j,ii))
3041             enddo
3042 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3043 C If this is a SC-SC distance, we need to calculate the contributions to the
3044 C Cartesian gradient in the SC vectors (ghpbx).
3045           if (iii.lt.ii) then
3046           do j=1,3
3047             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3048             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3049           enddo
3050           endif
3051           do k=1,3
3052             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3053             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3054           enddo
3055         endif
3056       enddo
3057       ehpb=0.5D0*ehpb
3058       return
3059       end
3060 C--------------------------------------------------------------------------
3061       subroutine ssbond_ene(i,j,eij)
3062 C
3063 C Calculate the distance and angle dependent SS-bond potential energy
3064 C using a free-energy function derived based on RHF/6-31G** ab initio
3065 C calculations of diethyl disulfide.
3066 C
3067 C A. Liwo and U. Kozlowska, 11/24/03
3068 C
3069       implicit real*8 (a-h,o-z)
3070       include 'DIMENSIONS'
3071       include 'DIMENSIONS.ZSCOPT'
3072       include 'COMMON.SBRIDGE'
3073       include 'COMMON.CHAIN'
3074       include 'COMMON.DERIV'
3075       include 'COMMON.LOCAL'
3076       include 'COMMON.INTERACT'
3077       include 'COMMON.VAR'
3078       include 'COMMON.IOUNITS'
3079       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3080       itypi=itype(i)
3081       xi=c(1,nres+i)
3082       yi=c(2,nres+i)
3083       zi=c(3,nres+i)
3084       dxi=dc_norm(1,nres+i)
3085       dyi=dc_norm(2,nres+i)
3086       dzi=dc_norm(3,nres+i)
3087       dsci_inv=dsc_inv(itypi)
3088       itypj=itype(j)
3089       dscj_inv=dsc_inv(itypj)
3090       xj=c(1,nres+j)-xi
3091       yj=c(2,nres+j)-yi
3092       zj=c(3,nres+j)-zi
3093       dxj=dc_norm(1,nres+j)
3094       dyj=dc_norm(2,nres+j)
3095       dzj=dc_norm(3,nres+j)
3096       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3097       rij=dsqrt(rrij)
3098       erij(1)=xj*rij
3099       erij(2)=yj*rij
3100       erij(3)=zj*rij
3101       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3102       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3103       om12=dxi*dxj+dyi*dyj+dzi*dzj
3104       do k=1,3
3105         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3106         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3107       enddo
3108       rij=1.0d0/rij
3109       deltad=rij-d0cm
3110       deltat1=1.0d0-om1
3111       deltat2=1.0d0+om2
3112       deltat12=om2-om1+2.0d0
3113       cosphi=om12-om1*om2
3114       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3115      &  +akct*deltad*deltat12+ebr
3116 c     &  +akct*deltad*deltat12
3117      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3118       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3119      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3120      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3121       ed=2*akcm*deltad+akct*deltat12
3122       pom1=akct*deltad
3123       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3124       eom1=-2*akth*deltat1-pom1-om2*pom2
3125       eom2= 2*akth*deltat2+pom1-om1*pom2
3126       eom12=pom2
3127       do k=1,3
3128         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3129       enddo
3130       do k=1,3
3131         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3132      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3133         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3134      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3135       enddo
3136 C
3137 C Calculate the components of the gradient in DC and X
3138 C
3139       do k=i,j-1
3140         do l=1,3
3141           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3142         enddo
3143       enddo
3144       return
3145       end
3146 C--------------------------------------------------------------------------
3147 c MODELLER restraint function
3148       subroutine e_modeller(ehomology_constr)
3149       implicit real*8 (a-h,o-z)
3150       include 'DIMENSIONS'
3151       include 'DIMENSIONS.ZSCOPT'
3152
3153       integer nnn, i, j, k, ki, irec, l
3154       integer katy, odleglosci, test7
3155       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3156       real*8 distance(max_template),distancek(max_template),
3157      &    min_odl,godl(max_template),dih_diff(max_template)
3158
3159 c
3160 c     FP - 30/10/2014 Temporary specifications for homology restraints
3161 c
3162       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3163      &                 sgtheta
3164       double precision, dimension (maxres) :: guscdiff,usc_diff
3165       double precision, dimension (max_template) ::
3166      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3167      &           theta_diff
3168
3169       include 'COMMON.SBRIDGE'
3170       include 'COMMON.CHAIN'
3171       include 'COMMON.GEO'
3172       include 'COMMON.DERIV'
3173       include 'COMMON.LOCAL'
3174       include 'COMMON.INTERACT'
3175       include 'COMMON.VAR'
3176       include 'COMMON.IOUNITS'
3177       include 'COMMON.CONTROL'
3178       include 'COMMON.HOMRESTR'
3179 c
3180       include 'COMMON.SETUP'
3181       include 'COMMON.NAMES'
3182
3183       do i=1,19
3184         distancek(i)=9999999.9
3185       enddo
3186
3187       odleg=0.0d0
3188
3189 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3190 c function)
3191 C AL 5/2/14 - Introduce list of restraints
3192 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3193 #ifdef DEBUG
3194       write(iout,*) "------- dist restrs start -------"
3195 #endif
3196       do ii = link_start_homo,link_end_homo
3197          i = ires_homo(ii)
3198          j = jres_homo(ii)
3199          dij=dist(i,j)
3200 c        write (iout,*) "dij(",i,j,") =",dij
3201          do k=1,constr_homology
3202            distance(k)=odl(k,ii)-dij
3203 c          write (iout,*) "distance(",k,") =",distance(k)
3204 c
3205 c          For Gaussian-type Urestr
3206 c
3207            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3208 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3209 c          write (iout,*) "distancek(",k,") =",distancek(k)
3210 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3211 c
3212 c          For Lorentzian-type Urestr
3213 c
3214            if (waga_dist.lt.0.0d0) then
3215               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3216               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3217      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3218            endif
3219          enddo
3220
3221          min_odl=minval(distancek)
3222 c        write (iout,* )"min_odl",min_odl
3223 #ifdef DEBUG
3224          write (iout,*) "ij dij",i,j,dij
3225          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3226          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3227          write (iout,* )"min_odl",min_odl
3228 #endif
3229          odleg2=0.0d0
3230          do k=1,constr_homology
3231 c Nie wiem po co to liczycie jeszcze raz!
3232 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3233 c     &              (2*(sigma_odl(i,j,k))**2))
3234            if (waga_dist.ge.0.0d0) then
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238             godl(k)=dexp(-distancek(k)+min_odl)
3239             odleg2=odleg2+godl(k)
3240 c
3241 c          For Lorentzian-type Urestr
3242 c
3243            else
3244             odleg2=odleg2+distancek(k)
3245            endif
3246
3247 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3248 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3249 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3250 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3251
3252          enddo
3253 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3254 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3255 #ifdef DEBUG
3256          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3257          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3258 #endif
3259            if (waga_dist.ge.0.0d0) then
3260 c
3261 c          For Gaussian-type Urestr
3262 c
3263               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3264 c
3265 c          For Lorentzian-type Urestr
3266 c
3267            else
3268               odleg=odleg+odleg2/constr_homology
3269            endif
3270 c
3271 #ifdef GRAD
3272 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3273 c Gradient
3274 c
3275 c          For Gaussian-type Urestr
3276 c
3277          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3278          sum_sgodl=0.0d0
3279          do k=1,constr_homology
3280 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3281 c     &           *waga_dist)+min_odl
3282 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3283 c
3284          if (waga_dist.ge.0.0d0) then
3285 c          For Gaussian-type Urestr
3286 c
3287            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3288 c
3289 c          For Lorentzian-type Urestr
3290 c
3291          else
3292            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3293      &           sigma_odlir(k,ii)**2)**2)
3294          endif
3295            sum_sgodl=sum_sgodl+sgodl
3296
3297 c            sgodl2=sgodl2+sgodl
3298 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3299 c      write(iout,*) "constr_homology=",constr_homology
3300 c      write(iout,*) i, j, k, "TEST K"
3301          enddo
3302          if (waga_dist.ge.0.0d0) then
3303 c
3304 c          For Gaussian-type Urestr
3305 c
3306             grad_odl3=waga_homology(iset)*waga_dist
3307      &                *sum_sgodl/(sum_godl*dij)
3308 c
3309 c          For Lorentzian-type Urestr
3310 c
3311          else
3312 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3313 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3314             grad_odl3=-waga_homology(iset)*waga_dist*
3315      &                sum_sgodl/(constr_homology*dij)
3316          endif
3317 c
3318 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3319
3320
3321 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3322 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3323 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3324
3325 ccc      write(iout,*) godl, sgodl, grad_odl3
3326
3327 c          grad_odl=grad_odl+grad_odl3
3328
3329          do jik=1,3
3330             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3331 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3332 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3333 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3334             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3335             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3336 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3337 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3338 c         if (i.eq.25.and.j.eq.27) then
3339 c         write(iout,*) "jik",jik,"i",i,"j",j
3340 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3341 c         write(iout,*) "grad_odl3",grad_odl3
3342 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3343 c         write(iout,*) "ggodl",ggodl
3344 c         write(iout,*) "ghpbc(",jik,i,")",
3345 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3346 c     &                 ghpbc(jik,j)
3347 c         endif
3348          enddo
3349 #endif
3350 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3351 ccc     & dLOG(odleg2),"-odleg=", -odleg
3352
3353       enddo ! ii-loop for dist
3354 #ifdef DEBUG
3355       write(iout,*) "------- dist restrs end -------"
3356 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3357 c    &     waga_d.eq.1.0d0) call sum_gradient
3358 #endif
3359 c Pseudo-energy and gradient from dihedral-angle restraints from
3360 c homology templates
3361 c      write (iout,*) "End of distance loop"
3362 c      call flush(iout)
3363       kat=0.0d0
3364 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3365 #ifdef DEBUG
3366       write(iout,*) "------- dih restrs start -------"
3367       do i=idihconstr_start_homo,idihconstr_end_homo
3368         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3369       enddo
3370 #endif
3371       do i=idihconstr_start_homo,idihconstr_end_homo
3372         kat2=0.0d0
3373 c        betai=beta(i,i+1,i+2,i+3)
3374         betai = phi(i+3)
3375 c       write (iout,*) "betai =",betai
3376         do k=1,constr_homology
3377           dih_diff(k)=pinorm(dih(k,i)-betai)
3378 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3379 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3380 c     &                                   -(6.28318-dih_diff(i,k))
3381 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3382 c     &                                   6.28318+dih_diff(i,k)
3383
3384           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3385 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3386           gdih(k)=dexp(kat3)
3387           kat2=kat2+gdih(k)
3388 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3389 c          write(*,*)""
3390         enddo
3391 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3392 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3393 #ifdef DEBUG
3394         write (iout,*) "i",i," betai",betai," kat2",kat2
3395         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3396 #endif
3397         if (kat2.le.1.0d-14) cycle
3398         kat=kat-dLOG(kat2/constr_homology)
3399 c       write (iout,*) "kat",kat ! sum of -ln-s
3400
3401 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3402 ccc     & dLOG(kat2), "-kat=", -kat
3403
3404 #ifdef GRAD
3405 c ----------------------------------------------------------------------
3406 c Gradient
3407 c ----------------------------------------------------------------------
3408
3409         sum_gdih=kat2
3410         sum_sgdih=0.0d0
3411         do k=1,constr_homology
3412           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3413 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3414           sum_sgdih=sum_sgdih+sgdih
3415         enddo
3416 c       grad_dih3=sum_sgdih/sum_gdih
3417         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3418
3419 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3420 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3421 ccc     & gloc(nphi+i-3,icg)
3422         gloc(i,icg)=gloc(i,icg)+grad_dih3
3423 c        if (i.eq.25) then
3424 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3425 c        endif
3426 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3427 ccc     & gloc(nphi+i-3,icg)
3428 #endif
3429       enddo ! i-loop for dih
3430 #ifdef DEBUG
3431       write(iout,*) "------- dih restrs end -------"
3432 #endif
3433
3434 c Pseudo-energy and gradient for theta angle restraints from
3435 c homology templates
3436 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3437 c adapted
3438
3439 c
3440 c     For constr_homology reference structures (FP)
3441 c
3442 c     Uconst_back_tot=0.0d0
3443       Eval=0.0d0
3444       Erot=0.0d0
3445 c     Econstr_back legacy
3446 #ifdef GRAD
3447       do i=1,nres
3448 c     do i=ithet_start,ithet_end
3449        dutheta(i)=0.0d0
3450 c     enddo
3451 c     do i=loc_start,loc_end
3452         do j=1,3
3453           duscdiff(j,i)=0.0d0
3454           duscdiffx(j,i)=0.0d0
3455         enddo
3456       enddo
3457 #endif
3458 c
3459 c     do iref=1,nref
3460 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3461 c     write (iout,*) "waga_theta",waga_theta
3462       if (waga_theta.gt.0.0d0) then
3463 #ifdef DEBUG
3464       write (iout,*) "usampl",usampl
3465       write(iout,*) "------- theta restrs start -------"
3466 c     do i=ithet_start,ithet_end
3467 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3468 c     enddo
3469 #endif
3470 c     write (iout,*) "maxres",maxres,"nres",nres
3471
3472       do i=ithet_start,ithet_end
3473 c
3474 c     do i=1,nfrag_back
3475 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3476 c
3477 c Deviation of theta angles wrt constr_homology ref structures
3478 c
3479         utheta_i=0.0d0 ! argument of Gaussian for single k
3480         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3481 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3482 c       over residues in a fragment
3483 c       write (iout,*) "theta(",i,")=",theta(i)
3484         do k=1,constr_homology
3485 c
3486 c         dtheta_i=theta(j)-thetaref(j,iref)
3487 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3488           theta_diff(k)=thetatpl(k,i)-theta(i)
3489 c
3490           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3491 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3492           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3493           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3494 c         Gradient for single Gaussian restraint in subr Econstr_back
3495 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3496 c
3497         enddo
3498 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3499 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3500
3501 c
3502 #ifdef GRAD
3503 c         Gradient for multiple Gaussian restraint
3504         sum_gtheta=gutheta_i
3505         sum_sgtheta=0.0d0
3506         do k=1,constr_homology
3507 c        New generalized expr for multiple Gaussian from Econstr_back
3508          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3509 c
3510 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3511           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3512         enddo
3513 c
3514 c       Final value of gradient using same var as in Econstr_back
3515         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3516      &               *waga_homology(iset)
3517 c       dutheta(i)=sum_sgtheta/sum_gtheta
3518 c
3519 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3520 #endif
3521         Eval=Eval-dLOG(gutheta_i/constr_homology)
3522 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3523 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3524 c       Uconst_back=Uconst_back+utheta(i)
3525       enddo ! (i-loop for theta)
3526 #ifdef DEBUG
3527       write(iout,*) "------- theta restrs end -------"
3528 #endif
3529       endif
3530 c
3531 c Deviation of local SC geometry
3532 c
3533 c Separation of two i-loops (instructed by AL - 11/3/2014)
3534 c
3535 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3536 c     write (iout,*) "waga_d",waga_d
3537
3538 #ifdef DEBUG
3539       write(iout,*) "------- SC restrs start -------"
3540       write (iout,*) "Initial duscdiff,duscdiffx"
3541       do i=loc_start,loc_end
3542         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3543      &                 (duscdiffx(jik,i),jik=1,3)
3544       enddo
3545 #endif
3546       do i=loc_start,loc_end
3547         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3548         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3549 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3550 c       write(iout,*) "xxtab, yytab, zztab"
3551 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3552         do k=1,constr_homology
3553 c
3554           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3555 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3556           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3557           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3558 c         write(iout,*) "dxx, dyy, dzz"
3559 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3560 c
3561           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3562 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3563 c         uscdiffk(k)=usc_diff(i)
3564           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3565           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3566 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3567 c     &      xxref(j),yyref(j),zzref(j)
3568         enddo
3569 c
3570 c       Gradient
3571 c
3572 c       Generalized expression for multiple Gaussian acc to that for a single
3573 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3574 c
3575 c       Original implementation
3576 c       sum_guscdiff=guscdiff(i)
3577 c
3578 c       sum_sguscdiff=0.0d0
3579 c       do k=1,constr_homology
3580 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3581 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3582 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3583 c       enddo
3584 c
3585 c       Implementation of new expressions for gradient (Jan. 2015)
3586 c
3587 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3588 #ifdef GRAD
3589         do k=1,constr_homology
3590 c
3591 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3592 c       before. Now the drivatives should be correct
3593 c
3594           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3595 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3596           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3597           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3598 c
3599 c         New implementation
3600 c
3601           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3602      &                 sigma_d(k,i) ! for the grad wrt r'
3603 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3604 c
3605 c
3606 c        New implementation
3607          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3608          do jik=1,3
3609             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3610      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3611      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3612             duscdiff(jik,i)=duscdiff(jik,i)+
3613      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3614      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3615             duscdiffx(jik,i)=duscdiffx(jik,i)+
3616      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3617      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3618 c
3619 #ifdef DEBUG
3620              write(iout,*) "jik",jik,"i",i
3621              write(iout,*) "dxx, dyy, dzz"
3622              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3623              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3624 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3625 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3626 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3627 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3628 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3629 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3630 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3631 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3632 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3633 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3634 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3635 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3636 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3637 c            endif
3638 #endif
3639          enddo
3640         enddo
3641 #endif
3642 c
3643 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3644 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3645 c
3646 c        write (iout,*) i," uscdiff",uscdiff(i)
3647 c
3648 c Put together deviations from local geometry
3649
3650 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3651 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3652         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3653 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3654 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3655 c       Uconst_back=Uconst_back+usc_diff(i)
3656 c
3657 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3658 c
3659 c     New implment: multiplied by sum_sguscdiff
3660 c
3661
3662       enddo ! (i-loop for dscdiff)
3663
3664 c      endif
3665
3666 #ifdef DEBUG
3667       write(iout,*) "------- SC restrs end -------"
3668         write (iout,*) "------ After SC loop in e_modeller ------"
3669         do i=loc_start,loc_end
3670          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3671          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3672         enddo
3673       if (waga_theta.eq.1.0d0) then
3674       write (iout,*) "in e_modeller after SC restr end: dutheta"
3675       do i=ithet_start,ithet_end
3676         write (iout,*) i,dutheta(i)
3677       enddo
3678       endif
3679       if (waga_d.eq.1.0d0) then
3680       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3681       do i=1,nres
3682         write (iout,*) i,(duscdiff(j,i),j=1,3)
3683         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3684       enddo
3685       endif
3686 #endif
3687
3688 c Total energy from homology restraints
3689 #ifdef DEBUG
3690       write (iout,*) "odleg",odleg," kat",kat
3691       write (iout,*) "odleg",odleg," kat",kat
3692       write (iout,*) "Eval",Eval," Erot",Erot
3693       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3694       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3695       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3696 #endif
3697 c
3698 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3699 c
3700 c     ehomology_constr=odleg+kat
3701 c
3702 c     For Lorentzian-type Urestr
3703 c
3704
3705       if (waga_dist.ge.0.0d0) then
3706 c
3707 c          For Gaussian-type Urestr
3708 c
3709         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3710      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3711 c     write (iout,*) "ehomology_constr=",ehomology_constr
3712       else
3713 c
3714 c          For Lorentzian-type Urestr
3715 c
3716         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3717      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3718 c     write (iout,*) "ehomology_constr=",ehomology_constr
3719       endif
3720 #ifdef DEBUG
3721       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3722      & "Eval",waga_theta,eval,
3723      &   "Erot",waga_d,Erot
3724       write (iout,*) "ehomology_constr",ehomology_constr
3725 #endif
3726       return
3727
3728   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3729   747 format(a12,i4,i4,i4,f8.3,f8.3)
3730   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3731   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3732   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3733      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3734       end
3735 c-----------------------------------------------------------------------
3736       subroutine ebond(estr)
3737 c
3738 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3739 c
3740       implicit real*8 (a-h,o-z)
3741       include 'DIMENSIONS'
3742       include 'DIMENSIONS.ZSCOPT'
3743       include 'COMMON.LOCAL'
3744       include 'COMMON.GEO'
3745       include 'COMMON.INTERACT'
3746       include 'COMMON.DERIV'
3747       include 'COMMON.VAR'
3748       include 'COMMON.CHAIN'
3749       include 'COMMON.IOUNITS'
3750       include 'COMMON.NAMES'
3751       include 'COMMON.FFIELD'
3752       include 'COMMON.CONTROL'
3753       double precision u(3),ud(3)
3754       logical :: lprn=.false.
3755       estr=0.0d0
3756       do i=nnt+1,nct
3757         diff = vbld(i)-vbldp0
3758 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3759         estr=estr+diff*diff
3760         do j=1,3
3761           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3762         enddo
3763       enddo
3764       estr=0.5d0*AKP*estr
3765 c
3766 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3767 c
3768       do i=nnt,nct
3769         iti=itype(i)
3770         if (iti.ne.10) then
3771           nbi=nbondterm(iti)
3772           if (nbi.eq.1) then
3773             diff=vbld(i+nres)-vbldsc0(1,iti)
3774             if (lprn)
3775      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3776      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3777             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3778             do j=1,3
3779               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3780             enddo
3781           else
3782             do j=1,nbi
3783               diff=vbld(i+nres)-vbldsc0(j,iti)
3784               ud(j)=aksc(j,iti)*diff
3785               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3786             enddo
3787             uprod=u(1)
3788             do j=2,nbi
3789               uprod=uprod*u(j)
3790             enddo
3791             usum=0.0d0
3792             usumsqder=0.0d0
3793             do j=1,nbi
3794               uprod1=1.0d0
3795               uprod2=1.0d0
3796               do k=1,nbi
3797                 if (k.ne.j) then
3798                   uprod1=uprod1*u(k)
3799                   uprod2=uprod2*u(k)*u(k)
3800                 endif
3801               enddo
3802               usum=usum+uprod1
3803               usumsqder=usumsqder+ud(j)*uprod2
3804             enddo
3805             if (lprn)
3806      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3807      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3808             estr=estr+uprod/usum
3809             do j=1,3
3810              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3811             enddo
3812           endif
3813         endif
3814       enddo
3815       return
3816       end
3817 #ifdef CRYST_THETA
3818 C--------------------------------------------------------------------------
3819       subroutine ebend(etheta)
3820 C
3821 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3822 C angles gamma and its derivatives in consecutive thetas and gammas.
3823 C
3824       implicit real*8 (a-h,o-z)
3825       include 'DIMENSIONS'
3826       include 'DIMENSIONS.ZSCOPT'
3827       include 'COMMON.LOCAL'
3828       include 'COMMON.GEO'
3829       include 'COMMON.INTERACT'
3830       include 'COMMON.DERIV'
3831       include 'COMMON.VAR'
3832       include 'COMMON.CHAIN'
3833       include 'COMMON.IOUNITS'
3834       include 'COMMON.NAMES'
3835       include 'COMMON.FFIELD'
3836       common /calcthet/ term1,term2,termm,diffak,ratak,
3837      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3838      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3839       double precision y(2),z(2)
3840       delta=0.02d0*pi
3841       time11=dexp(-2*time)
3842       time12=1.0d0
3843       etheta=0.0D0
3844 c      write (iout,*) "nres",nres
3845 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3846 c      write (iout,*) ithet_start,ithet_end
3847       do i=ithet_start,ithet_end
3848 C Zero the energy function and its derivative at 0 or pi.
3849         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3850         it=itype(i-1)
3851 c        if (i.gt.ithet_start .and.
3852 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3853 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3854 c          phii=phi(i)
3855 c          y(1)=dcos(phii)
3856 c          y(2)=dsin(phii)
3857 c        else
3858 c          y(1)=0.0D0
3859 c          y(2)=0.0D0
3860 c        endif
3861 c        if (i.lt.nres .and. itel(i).ne.0) then
3862 c          phii1=phi(i+1)
3863 c          z(1)=dcos(phii1)
3864 c          z(2)=dsin(phii1)
3865 c        else
3866 c          z(1)=0.0D0
3867 c          z(2)=0.0D0
3868 c        endif
3869         if (i.gt.3) then
3870 #ifdef OSF
3871           phii=phi(i)
3872           icrc=0
3873           call proc_proc(phii,icrc)
3874           if (icrc.eq.1) phii=150.0
3875 #else
3876           phii=phi(i)
3877 #endif
3878           y(1)=dcos(phii)
3879           y(2)=dsin(phii)
3880         else
3881           y(1)=0.0D0
3882           y(2)=0.0D0
3883         endif
3884         if (i.lt.nres) then
3885 #ifdef OSF
3886           phii1=phi(i+1)
3887           icrc=0
3888           call proc_proc(phii1,icrc)
3889           if (icrc.eq.1) phii1=150.0
3890           phii1=pinorm(phii1)
3891           z(1)=cos(phii1)
3892 #else
3893           phii1=phi(i+1)
3894           z(1)=dcos(phii1)
3895 #endif
3896           z(2)=dsin(phii1)
3897         else
3898           z(1)=0.0D0
3899           z(2)=0.0D0
3900         endif
3901 C Calculate the "mean" value of theta from the part of the distribution
3902 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3903 C In following comments this theta will be referred to as t_c.
3904         thet_pred_mean=0.0d0
3905         do k=1,2
3906           athetk=athet(k,it)
3907           bthetk=bthet(k,it)
3908           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3909         enddo
3910 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3911         dthett=thet_pred_mean*ssd
3912         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3913 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3914 C Derivatives of the "mean" values in gamma1 and gamma2.
3915         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3916         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3917         if (theta(i).gt.pi-delta) then
3918           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3919      &         E_tc0)
3920           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3921           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3922           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3923      &        E_theta)
3924           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3925      &        E_tc)
3926         else if (theta(i).lt.delta) then
3927           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3928           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3929           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3930      &        E_theta)
3931           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3932           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3933      &        E_tc)
3934         else
3935           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3936      &        E_theta,E_tc)
3937         endif
3938         etheta=etheta+ethetai
3939 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3940 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3941         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3942         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3943         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3944  1215   continue
3945       enddo
3946 C Ufff.... We've done all this!!!
3947       return
3948       end
3949 C---------------------------------------------------------------------------
3950       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3951      &     E_tc)
3952       implicit real*8 (a-h,o-z)
3953       include 'DIMENSIONS'
3954       include 'COMMON.LOCAL'
3955       include 'COMMON.IOUNITS'
3956       common /calcthet/ term1,term2,termm,diffak,ratak,
3957      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3958      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3959 C Calculate the contributions to both Gaussian lobes.
3960 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3961 C The "polynomial part" of the "standard deviation" of this part of
3962 C the distribution.
3963         sig=polthet(3,it)
3964         do j=2,0,-1
3965           sig=sig*thet_pred_mean+polthet(j,it)
3966         enddo
3967 C Derivative of the "interior part" of the "standard deviation of the"
3968 C gamma-dependent Gaussian lobe in t_c.
3969         sigtc=3*polthet(3,it)
3970         do j=2,1,-1
3971           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3972         enddo
3973         sigtc=sig*sigtc
3974 C Set the parameters of both Gaussian lobes of the distribution.
3975 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3976         fac=sig*sig+sigc0(it)
3977         sigcsq=fac+fac
3978         sigc=1.0D0/sigcsq
3979 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3980         sigsqtc=-4.0D0*sigcsq*sigtc
3981 c       print *,i,sig,sigtc,sigsqtc
3982 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3983         sigtc=-sigtc/(fac*fac)
3984 C Following variable is sigma(t_c)**(-2)
3985         sigcsq=sigcsq*sigcsq
3986         sig0i=sig0(it)
3987         sig0inv=1.0D0/sig0i**2
3988         delthec=thetai-thet_pred_mean
3989         delthe0=thetai-theta0i
3990         term1=-0.5D0*sigcsq*delthec*delthec
3991         term2=-0.5D0*sig0inv*delthe0*delthe0
3992 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3993 C NaNs in taking the logarithm. We extract the largest exponent which is added
3994 C to the energy (this being the log of the distribution) at the end of energy
3995 C term evaluation for this virtual-bond angle.
3996         if (term1.gt.term2) then
3997           termm=term1
3998           term2=dexp(term2-termm)
3999           term1=1.0d0
4000         else
4001           termm=term2
4002           term1=dexp(term1-termm)
4003           term2=1.0d0
4004         endif
4005 C The ratio between the gamma-independent and gamma-dependent lobes of
4006 C the distribution is a Gaussian function of thet_pred_mean too.
4007         diffak=gthet(2,it)-thet_pred_mean
4008         ratak=diffak/gthet(3,it)**2
4009         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4010 C Let's differentiate it in thet_pred_mean NOW.
4011         aktc=ak*ratak
4012 C Now put together the distribution terms to make complete distribution.
4013         termexp=term1+ak*term2
4014         termpre=sigc+ak*sig0i
4015 C Contribution of the bending energy from this theta is just the -log of
4016 C the sum of the contributions from the two lobes and the pre-exponential
4017 C factor. Simple enough, isn't it?
4018         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4019 C NOW the derivatives!!!
4020 C 6/6/97 Take into account the deformation.
4021         E_theta=(delthec*sigcsq*term1
4022      &       +ak*delthe0*sig0inv*term2)/termexp
4023         E_tc=((sigtc+aktc*sig0i)/termpre
4024      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4025      &       aktc*term2)/termexp)
4026       return
4027       end
4028 c-----------------------------------------------------------------------------
4029       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4030       implicit real*8 (a-h,o-z)
4031       include 'DIMENSIONS'
4032       include 'COMMON.LOCAL'
4033       include 'COMMON.IOUNITS'
4034       common /calcthet/ term1,term2,termm,diffak,ratak,
4035      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4036      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4037       delthec=thetai-thet_pred_mean
4038       delthe0=thetai-theta0i
4039 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4040       t3 = thetai-thet_pred_mean
4041       t6 = t3**2
4042       t9 = term1
4043       t12 = t3*sigcsq
4044       t14 = t12+t6*sigsqtc
4045       t16 = 1.0d0
4046       t21 = thetai-theta0i
4047       t23 = t21**2
4048       t26 = term2
4049       t27 = t21*t26
4050       t32 = termexp
4051       t40 = t32**2
4052       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4053      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4054      & *(-t12*t9-ak*sig0inv*t27)
4055       return
4056       end
4057 #else
4058 C--------------------------------------------------------------------------
4059       subroutine ebend(etheta)
4060 C
4061 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4062 C angles gamma and its derivatives in consecutive thetas and gammas.
4063 C ab initio-derived potentials from
4064 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4065 C
4066       implicit real*8 (a-h,o-z)
4067       include 'DIMENSIONS'
4068       include 'DIMENSIONS.ZSCOPT'
4069       include 'COMMON.LOCAL'
4070       include 'COMMON.GEO'
4071       include 'COMMON.INTERACT'
4072       include 'COMMON.DERIV'
4073       include 'COMMON.VAR'
4074       include 'COMMON.CHAIN'
4075       include 'COMMON.IOUNITS'
4076       include 'COMMON.NAMES'
4077       include 'COMMON.FFIELD'
4078       include 'COMMON.CONTROL'
4079       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4080      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4081      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4082      & sinph1ph2(maxdouble,maxdouble)
4083       logical lprn /.false./, lprn1 /.false./
4084       etheta=0.0D0
4085 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4086       do i=ithet_start,ithet_end
4087         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4088      &    (itype(i).eq.ntyp1)) cycle
4089         dethetai=0.0d0
4090         dephii=0.0d0
4091         dephii1=0.0d0
4092         theti2=0.5d0*theta(i)
4093         ityp2=ithetyp(itype(i-1))
4094         do k=1,nntheterm
4095           coskt(k)=dcos(k*theti2)
4096           sinkt(k)=dsin(k*theti2)
4097         enddo
4098         if (i.gt.3  .and. itype(i-3).ne.ntyp1) then
4099 #ifdef OSF
4100           phii=phi(i)
4101           if (phii.ne.phii) phii=150.0
4102 #else
4103           phii=phi(i)
4104 #endif
4105           ityp1=ithetyp(itype(i-2))
4106           do k=1,nsingle
4107             cosph1(k)=dcos(k*phii)
4108             sinph1(k)=dsin(k*phii)
4109           enddo
4110         else
4111           phii=0.0d0
4112           ityp1=ithetyp(itype(i-2))
4113           do k=1,nsingle
4114             cosph1(k)=0.0d0
4115             sinph1(k)=0.0d0
4116           enddo
4117         endif
4118         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4119 #ifdef OSF
4120           phii1=phi(i+1)
4121           if (phii1.ne.phii1) phii1=150.0
4122           phii1=pinorm(phii1)
4123 #else
4124           phii1=phi(i+1)
4125 #endif
4126           ityp3=ithetyp(itype(i))
4127           do k=1,nsingle
4128             cosph2(k)=dcos(k*phii1)
4129             sinph2(k)=dsin(k*phii1)
4130           enddo
4131         else
4132           phii1=0.0d0
4133 c          ityp3=nthetyp+1
4134           ityp3=ithetyp(itype(i))
4135           do k=1,nsingle
4136             cosph2(k)=0.0d0
4137             sinph2(k)=0.0d0
4138           enddo
4139         endif
4140 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4141 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4142 c        call flush(iout)
4143         ethetai=aa0thet(ityp1,ityp2,ityp3)
4144         do k=1,ndouble
4145           do l=1,k-1
4146             ccl=cosph1(l)*cosph2(k-l)
4147             ssl=sinph1(l)*sinph2(k-l)
4148             scl=sinph1(l)*cosph2(k-l)
4149             csl=cosph1(l)*sinph2(k-l)
4150             cosph1ph2(l,k)=ccl-ssl
4151             cosph1ph2(k,l)=ccl+ssl
4152             sinph1ph2(l,k)=scl+csl
4153             sinph1ph2(k,l)=scl-csl
4154           enddo
4155         enddo
4156         if (lprn) then
4157         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4158      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4159         write (iout,*) "coskt and sinkt"
4160         do k=1,nntheterm
4161           write (iout,*) k,coskt(k),sinkt(k)
4162         enddo
4163         endif
4164         do k=1,ntheterm
4165           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4166           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4167      &      *coskt(k)
4168           if (lprn)
4169      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4170      &     " ethetai",ethetai
4171         enddo
4172         if (lprn) then
4173         write (iout,*) "cosph and sinph"
4174         do k=1,nsingle
4175           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4176         enddo
4177         write (iout,*) "cosph1ph2 and sinph2ph2"
4178         do k=2,ndouble
4179           do l=1,k-1
4180             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4181      &         sinph1ph2(l,k),sinph1ph2(k,l)
4182           enddo
4183         enddo
4184         write(iout,*) "ethetai",ethetai
4185         endif
4186         do m=1,ntheterm2
4187           do k=1,nsingle
4188             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4189      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4190      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4191      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4192             ethetai=ethetai+sinkt(m)*aux
4193             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4194             dephii=dephii+k*sinkt(m)*(
4195      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4196      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4197             dephii1=dephii1+k*sinkt(m)*(
4198      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4199      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4200             if (lprn)
4201      &      write (iout,*) "m",m," k",k," bbthet",
4202      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4203      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4204      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4205      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4206           enddo
4207         enddo
4208         if (lprn)
4209      &  write(iout,*) "ethetai",ethetai
4210         do m=1,ntheterm3
4211           do k=2,ndouble
4212             do l=1,k-1
4213               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4214      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4215      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4216      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4217               ethetai=ethetai+sinkt(m)*aux
4218               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4219               dephii=dephii+l*sinkt(m)*(
4220      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4221      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4222      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4223      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4224               dephii1=dephii1+(k-l)*sinkt(m)*(
4225      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4226      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4227      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4228      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4229               if (lprn) then
4230               write (iout,*) "m",m," k",k," l",l," ffthet",
4231      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4232      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4233      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4234      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4235               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4236      &            cosph1ph2(k,l)*sinkt(m),
4237      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4238               endif
4239             enddo
4240           enddo
4241         enddo
4242 10      continue
4243 c        lprn1=.true.
4244         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4245      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4246      &   phii1*rad2deg,ethetai
4247 c        lprn1=.false.
4248         etheta=etheta+ethetai
4249
4250         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4251         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4252         gloc(nphi+i-2,icg)=wang*dethetai
4253       enddo
4254       return
4255       end
4256 #endif
4257 #ifdef CRYST_SC
4258 c-----------------------------------------------------------------------------
4259       subroutine esc(escloc)
4260 C Calculate the local energy of a side chain and its derivatives in the
4261 C corresponding virtual-bond valence angles THETA and the spherical angles
4262 C ALPHA and OMEGA.
4263       implicit real*8 (a-h,o-z)
4264       include 'DIMENSIONS'
4265       include 'DIMENSIONS.ZSCOPT'
4266       include 'COMMON.GEO'
4267       include 'COMMON.LOCAL'
4268       include 'COMMON.VAR'
4269       include 'COMMON.INTERACT'
4270       include 'COMMON.DERIV'
4271       include 'COMMON.CHAIN'
4272       include 'COMMON.IOUNITS'
4273       include 'COMMON.NAMES'
4274       include 'COMMON.FFIELD'
4275       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4276      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4277       common /sccalc/ time11,time12,time112,theti,it,nlobit
4278       delta=0.02d0*pi
4279       escloc=0.0D0
4280 c     write (iout,'(a)') 'ESC'
4281       do i=loc_start,loc_end
4282         it=itype(i)
4283         if (it.eq.10) goto 1
4284         nlobit=nlob(it)
4285 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4286 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4287         theti=theta(i+1)-pipol
4288         x(1)=dtan(theti)
4289         x(2)=alph(i)
4290         x(3)=omeg(i)
4291 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4292
4293         if (x(2).gt.pi-delta) then
4294           xtemp(1)=x(1)
4295           xtemp(2)=pi-delta
4296           xtemp(3)=x(3)
4297           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4298           xtemp(2)=pi
4299           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4300           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4301      &        escloci,dersc(2))
4302           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4303      &        ddersc0(1),dersc(1))
4304           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4305      &        ddersc0(3),dersc(3))
4306           xtemp(2)=pi-delta
4307           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4308           xtemp(2)=pi
4309           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4310           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4311      &            dersc0(2),esclocbi,dersc02)
4312           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4313      &            dersc12,dersc01)
4314           call splinthet(x(2),0.5d0*delta,ss,ssd)
4315           dersc0(1)=dersc01
4316           dersc0(2)=dersc02
4317           dersc0(3)=0.0d0
4318           do k=1,3
4319             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4320           enddo
4321           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4322 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4323 c    &             esclocbi,ss,ssd
4324           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4325 c         escloci=esclocbi
4326 c         write (iout,*) escloci
4327         else if (x(2).lt.delta) then
4328           xtemp(1)=x(1)
4329           xtemp(2)=delta
4330           xtemp(3)=x(3)
4331           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4332           xtemp(2)=0.0d0
4333           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4334           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4335      &        escloci,dersc(2))
4336           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4337      &        ddersc0(1),dersc(1))
4338           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4339      &        ddersc0(3),dersc(3))
4340           xtemp(2)=delta
4341           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4342           xtemp(2)=0.0d0
4343           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4344           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4345      &            dersc0(2),esclocbi,dersc02)
4346           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4347      &            dersc12,dersc01)
4348           dersc0(1)=dersc01
4349           dersc0(2)=dersc02
4350           dersc0(3)=0.0d0
4351           call splinthet(x(2),0.5d0*delta,ss,ssd)
4352           do k=1,3
4353             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4354           enddo
4355           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4356 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4357 c    &             esclocbi,ss,ssd
4358           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4359 c         write (iout,*) escloci
4360         else
4361           call enesc(x,escloci,dersc,ddummy,.false.)
4362         endif
4363
4364         escloc=escloc+escloci
4365 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4366
4367         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4368      &   wscloc*dersc(1)
4369         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4370         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4371     1   continue
4372       enddo
4373       return
4374       end
4375 C---------------------------------------------------------------------------
4376       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4377       implicit real*8 (a-h,o-z)
4378       include 'DIMENSIONS'
4379       include 'COMMON.GEO'
4380       include 'COMMON.LOCAL'
4381       include 'COMMON.IOUNITS'
4382       common /sccalc/ time11,time12,time112,theti,it,nlobit
4383       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4384       double precision contr(maxlob,-1:1)
4385       logical mixed
4386 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4387         escloc_i=0.0D0
4388         do j=1,3
4389           dersc(j)=0.0D0
4390           if (mixed) ddersc(j)=0.0d0
4391         enddo
4392         x3=x(3)
4393
4394 C Because of periodicity of the dependence of the SC energy in omega we have
4395 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4396 C To avoid underflows, first compute & store the exponents.
4397
4398         do iii=-1,1
4399
4400           x(3)=x3+iii*dwapi
4401
4402           do j=1,nlobit
4403             do k=1,3
4404               z(k)=x(k)-censc(k,j,it)
4405             enddo
4406             do k=1,3
4407               Axk=0.0D0
4408               do l=1,3
4409                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4410               enddo
4411               Ax(k,j,iii)=Axk
4412             enddo
4413             expfac=0.0D0
4414             do k=1,3
4415               expfac=expfac+Ax(k,j,iii)*z(k)
4416             enddo
4417             contr(j,iii)=expfac
4418           enddo ! j
4419
4420         enddo ! iii
4421
4422         x(3)=x3
4423 C As in the case of ebend, we want to avoid underflows in exponentiation and
4424 C subsequent NaNs and INFs in energy calculation.
4425 C Find the largest exponent
4426         emin=contr(1,-1)
4427         do iii=-1,1
4428           do j=1,nlobit
4429             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4430           enddo
4431         enddo
4432         emin=0.5D0*emin
4433 cd      print *,'it=',it,' emin=',emin
4434
4435 C Compute the contribution to SC energy and derivatives
4436         do iii=-1,1
4437
4438           do j=1,nlobit
4439             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4440 cd          print *,'j=',j,' expfac=',expfac
4441             escloc_i=escloc_i+expfac
4442             do k=1,3
4443               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4444             enddo
4445             if (mixed) then
4446               do k=1,3,2
4447                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4448      &            +gaussc(k,2,j,it))*expfac
4449               enddo
4450             endif
4451           enddo
4452
4453         enddo ! iii
4454
4455         dersc(1)=dersc(1)/cos(theti)**2
4456         ddersc(1)=ddersc(1)/cos(theti)**2
4457         ddersc(3)=ddersc(3)
4458
4459         escloci=-(dlog(escloc_i)-emin)
4460         do j=1,3
4461           dersc(j)=dersc(j)/escloc_i
4462         enddo
4463         if (mixed) then
4464           do j=1,3,2
4465             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4466           enddo
4467         endif
4468       return
4469       end
4470 C------------------------------------------------------------------------------
4471       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4472       implicit real*8 (a-h,o-z)
4473       include 'DIMENSIONS'
4474       include 'COMMON.GEO'
4475       include 'COMMON.LOCAL'
4476       include 'COMMON.IOUNITS'
4477       common /sccalc/ time11,time12,time112,theti,it,nlobit
4478       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4479       double precision contr(maxlob)
4480       logical mixed
4481
4482       escloc_i=0.0D0
4483
4484       do j=1,3
4485         dersc(j)=0.0D0
4486       enddo
4487
4488       do j=1,nlobit
4489         do k=1,2
4490           z(k)=x(k)-censc(k,j,it)
4491         enddo
4492         z(3)=dwapi
4493         do k=1,3
4494           Axk=0.0D0
4495           do l=1,3
4496             Axk=Axk+gaussc(l,k,j,it)*z(l)
4497           enddo
4498           Ax(k,j)=Axk
4499         enddo
4500         expfac=0.0D0
4501         do k=1,3
4502           expfac=expfac+Ax(k,j)*z(k)
4503         enddo
4504         contr(j)=expfac
4505       enddo ! j
4506
4507 C As in the case of ebend, we want to avoid underflows in exponentiation and
4508 C subsequent NaNs and INFs in energy calculation.
4509 C Find the largest exponent
4510       emin=contr(1)
4511       do j=1,nlobit
4512         if (emin.gt.contr(j)) emin=contr(j)
4513       enddo
4514       emin=0.5D0*emin
4515
4516 C Compute the contribution to SC energy and derivatives
4517
4518       dersc12=0.0d0
4519       do j=1,nlobit
4520         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4521         escloc_i=escloc_i+expfac
4522         do k=1,2
4523           dersc(k)=dersc(k)+Ax(k,j)*expfac
4524         enddo
4525         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4526      &            +gaussc(1,2,j,it))*expfac
4527         dersc(3)=0.0d0
4528       enddo
4529
4530       dersc(1)=dersc(1)/cos(theti)**2
4531       dersc12=dersc12/cos(theti)**2
4532       escloci=-(dlog(escloc_i)-emin)
4533       do j=1,2
4534         dersc(j)=dersc(j)/escloc_i
4535       enddo
4536       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4537       return
4538       end
4539 #else
4540 c----------------------------------------------------------------------------------
4541       subroutine esc(escloc)
4542 C Calculate the local energy of a side chain and its derivatives in the
4543 C corresponding virtual-bond valence angles THETA and the spherical angles
4544 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4545 C added by Urszula Kozlowska. 07/11/2007
4546 C
4547       implicit real*8 (a-h,o-z)
4548       include 'DIMENSIONS'
4549       include 'DIMENSIONS.ZSCOPT'
4550       include 'COMMON.GEO'
4551       include 'COMMON.LOCAL'
4552       include 'COMMON.VAR'
4553       include 'COMMON.SCROT'
4554       include 'COMMON.INTERACT'
4555       include 'COMMON.DERIV'
4556       include 'COMMON.CHAIN'
4557       include 'COMMON.IOUNITS'
4558       include 'COMMON.NAMES'
4559       include 'COMMON.FFIELD'
4560       include 'COMMON.CONTROL'
4561       include 'COMMON.VECTORS'
4562       double precision x_prime(3),y_prime(3),z_prime(3)
4563      &    , sumene,dsc_i,dp2_i,x(65),
4564      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4565      &    de_dxx,de_dyy,de_dzz,de_dt
4566       double precision s1_t,s1_6_t,s2_t,s2_6_t
4567       double precision
4568      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4569      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4570      & dt_dCi(3),dt_dCi1(3)
4571       common /sccalc/ time11,time12,time112,theti,it,nlobit
4572       delta=0.02d0*pi
4573       escloc=0.0D0
4574       do i=loc_start,loc_end
4575         costtab(i+1) =dcos(theta(i+1))
4576         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4577         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4578         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4579         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4580         cosfac=dsqrt(cosfac2)
4581         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4582         sinfac=dsqrt(sinfac2)
4583         it=itype(i)
4584         if (it.eq.10) goto 1
4585 c
4586 C  Compute the axes of tghe local cartesian coordinates system; store in
4587 c   x_prime, y_prime and z_prime
4588 c
4589         do j=1,3
4590           x_prime(j) = 0.00
4591           y_prime(j) = 0.00
4592           z_prime(j) = 0.00
4593         enddo
4594 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4595 C     &   dc_norm(3,i+nres)
4596         do j = 1,3
4597           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4598           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4599         enddo
4600         do j = 1,3
4601           z_prime(j) = -uz(j,i-1)
4602         enddo
4603 c       write (2,*) "i",i
4604 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4605 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4606 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4607 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4608 c      & " xy",scalar(x_prime(1),y_prime(1)),
4609 c      & " xz",scalar(x_prime(1),z_prime(1)),
4610 c      & " yy",scalar(y_prime(1),y_prime(1)),
4611 c      & " yz",scalar(y_prime(1),z_prime(1)),
4612 c      & " zz",scalar(z_prime(1),z_prime(1))
4613 c
4614 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4615 C to local coordinate system. Store in xx, yy, zz.
4616 c
4617         xx=0.0d0
4618         yy=0.0d0
4619         zz=0.0d0
4620         do j = 1,3
4621           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4622           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4623           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4624         enddo
4625
4626         xxtab(i)=xx
4627         yytab(i)=yy
4628         zztab(i)=zz
4629 C
4630 C Compute the energy of the ith side cbain
4631 C
4632 c        write (2,*) "xx",xx," yy",yy," zz",zz
4633         it=itype(i)
4634         do j = 1,65
4635           x(j) = sc_parmin(j,it)
4636         enddo
4637 #ifdef CHECK_COORD
4638 Cc diagnostics - remove later
4639         xx1 = dcos(alph(2))
4640         yy1 = dsin(alph(2))*dcos(omeg(2))
4641         zz1 = -dsin(alph(2))*dsin(omeg(2))
4642         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4643      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4644      &    xx1,yy1,zz1
4645 C,"  --- ", xx_w,yy_w,zz_w
4646 c end diagnostics
4647 #endif
4648         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4649      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4650      &   + x(10)*yy*zz
4651         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4652      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4653      & + x(20)*yy*zz
4654         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4655      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4656      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4657      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4658      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4659      &  +x(40)*xx*yy*zz
4660         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4661      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4662      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4663      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4664      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4665      &  +x(60)*xx*yy*zz
4666         dsc_i   = 0.743d0+x(61)
4667         dp2_i   = 1.9d0+x(62)
4668         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4669      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4670         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4671      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4672         s1=(1+x(63))/(0.1d0 + dscp1)
4673         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4674         s2=(1+x(65))/(0.1d0 + dscp2)
4675         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4676         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4677      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4678 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4679 c     &   sumene4,
4680 c     &   dscp1,dscp2,sumene
4681 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4682         escloc = escloc + sumene
4683 c        write (2,*) "escloc",escloc
4684         if (.not. calc_grad) goto 1
4685
4686 #ifdef DEBUG2
4687 C
4688 C This section to check the numerical derivatives of the energy of ith side
4689 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4690 C #define DEBUG in the code to turn it on.
4691 C
4692         write (2,*) "sumene               =",sumene
4693         aincr=1.0d-7
4694         xxsave=xx
4695         xx=xx+aincr
4696         write (2,*) xx,yy,zz
4697         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4698         de_dxx_num=(sumenep-sumene)/aincr
4699         xx=xxsave
4700         write (2,*) "xx+ sumene from enesc=",sumenep
4701         yysave=yy
4702         yy=yy+aincr
4703         write (2,*) xx,yy,zz
4704         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4705         de_dyy_num=(sumenep-sumene)/aincr
4706         yy=yysave
4707         write (2,*) "yy+ sumene from enesc=",sumenep
4708         zzsave=zz
4709         zz=zz+aincr
4710         write (2,*) xx,yy,zz
4711         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4712         de_dzz_num=(sumenep-sumene)/aincr
4713         zz=zzsave
4714         write (2,*) "zz+ sumene from enesc=",sumenep
4715         costsave=cost2tab(i+1)
4716         sintsave=sint2tab(i+1)
4717         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4718         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4719         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4720         de_dt_num=(sumenep-sumene)/aincr
4721         write (2,*) " t+ sumene from enesc=",sumenep
4722         cost2tab(i+1)=costsave
4723         sint2tab(i+1)=sintsave
4724 C End of diagnostics section.
4725 #endif
4726 C
4727 C Compute the gradient of esc
4728 C
4729         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4730         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4731         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4732         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4733         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4734         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4735         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4736         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4737         pom1=(sumene3*sint2tab(i+1)+sumene1)
4738      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4739         pom2=(sumene4*cost2tab(i+1)+sumene2)
4740      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4741         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4742         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4743      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4744      &  +x(40)*yy*zz
4745         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4746         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4747      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4748      &  +x(60)*yy*zz
4749         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4750      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4751      &        +(pom1+pom2)*pom_dx
4752 #ifdef DEBUG
4753         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4754 #endif
4755 C
4756         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4757         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4758      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4759      &  +x(40)*xx*zz
4760         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4761         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4762      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4763      &  +x(59)*zz**2 +x(60)*xx*zz
4764         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4765      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4766      &        +(pom1-pom2)*pom_dy
4767 #ifdef DEBUG
4768         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4769 #endif
4770 C
4771         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4772      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4773      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4774      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4775      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4776      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4777      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4778      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4779 #ifdef DEBUG
4780         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4781 #endif
4782 C
4783         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4784      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4785      &  +pom1*pom_dt1+pom2*pom_dt2
4786 #ifdef DEBUG
4787         write(2,*), "de_dt = ", de_dt,de_dt_num
4788 #endif
4789 c
4790 C
4791        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4792        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4793        cosfac2xx=cosfac2*xx
4794        sinfac2yy=sinfac2*yy
4795        do k = 1,3
4796          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4797      &      vbld_inv(i+1)
4798          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4799      &      vbld_inv(i)
4800          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4801          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4802 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4803 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4804 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4805 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4806          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4807          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4808          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4809          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4810          dZZ_Ci1(k)=0.0d0
4811          dZZ_Ci(k)=0.0d0
4812          do j=1,3
4813            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4814            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4815          enddo
4816
4817          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4818          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4819          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4820 c
4821          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4822          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4823        enddo
4824
4825        do k=1,3
4826          dXX_Ctab(k,i)=dXX_Ci(k)
4827          dXX_C1tab(k,i)=dXX_Ci1(k)
4828          dYY_Ctab(k,i)=dYY_Ci(k)
4829          dYY_C1tab(k,i)=dYY_Ci1(k)
4830          dZZ_Ctab(k,i)=dZZ_Ci(k)
4831          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4832          dXX_XYZtab(k,i)=dXX_XYZ(k)
4833          dYY_XYZtab(k,i)=dYY_XYZ(k)
4834          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4835        enddo
4836
4837        do k = 1,3
4838 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4839 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4840 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4841 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4842 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4843 c     &    dt_dci(k)
4844 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4845 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4846          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4847      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4848          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4849      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4850          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4851      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4852        enddo
4853 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4854 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4855
4856 C to check gradient call subroutine check_grad
4857
4858     1 continue
4859       enddo
4860       return
4861       end
4862 #endif
4863 c------------------------------------------------------------------------------
4864       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4865 C
4866 C This procedure calculates two-body contact function g(rij) and its derivative:
4867 C
4868 C           eps0ij                                     !       x < -1
4869 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4870 C            0                                         !       x > 1
4871 C
4872 C where x=(rij-r0ij)/delta
4873 C
4874 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4875 C
4876       implicit none
4877       double precision rij,r0ij,eps0ij,fcont,fprimcont
4878       double precision x,x2,x4,delta
4879 c     delta=0.02D0*r0ij
4880 c      delta=0.2D0*r0ij
4881       x=(rij-r0ij)/delta
4882       if (x.lt.-1.0D0) then
4883         fcont=eps0ij
4884         fprimcont=0.0D0
4885       else if (x.le.1.0D0) then
4886         x2=x*x
4887         x4=x2*x2
4888         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4889         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4890       else
4891         fcont=0.0D0
4892         fprimcont=0.0D0
4893       endif
4894       return
4895       end
4896 c------------------------------------------------------------------------------
4897       subroutine splinthet(theti,delta,ss,ssder)
4898       implicit real*8 (a-h,o-z)
4899       include 'DIMENSIONS'
4900       include 'DIMENSIONS.ZSCOPT'
4901       include 'COMMON.VAR'
4902       include 'COMMON.GEO'
4903       thetup=pi-delta
4904       thetlow=delta
4905       if (theti.gt.pipol) then
4906         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4907       else
4908         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4909         ssder=-ssder
4910       endif
4911       return
4912       end
4913 c------------------------------------------------------------------------------
4914       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4915       implicit none
4916       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4917       double precision ksi,ksi2,ksi3,a1,a2,a3
4918       a1=fprim0*delta/(f1-f0)
4919       a2=3.0d0-2.0d0*a1
4920       a3=a1-2.0d0
4921       ksi=(x-x0)/delta
4922       ksi2=ksi*ksi
4923       ksi3=ksi2*ksi
4924       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4925       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4926       return
4927       end
4928 c------------------------------------------------------------------------------
4929       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4930       implicit none
4931       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4932       double precision ksi,ksi2,ksi3,a1,a2,a3
4933       ksi=(x-x0)/delta
4934       ksi2=ksi*ksi
4935       ksi3=ksi2*ksi
4936       a1=fprim0x*delta
4937       a2=3*(f1x-f0x)-2*fprim0x*delta
4938       a3=fprim0x*delta-2*(f1x-f0x)
4939       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4940       return
4941       end
4942 C-----------------------------------------------------------------------------
4943 #ifdef CRYST_TOR
4944 C-----------------------------------------------------------------------------
4945       subroutine etor(etors,edihcnstr,fact)
4946       implicit real*8 (a-h,o-z)
4947       include 'DIMENSIONS'
4948       include 'DIMENSIONS.ZSCOPT'
4949       include 'COMMON.VAR'
4950       include 'COMMON.GEO'
4951       include 'COMMON.LOCAL'
4952       include 'COMMON.TORSION'
4953       include 'COMMON.INTERACT'
4954       include 'COMMON.DERIV'
4955       include 'COMMON.CHAIN'
4956       include 'COMMON.NAMES'
4957       include 'COMMON.IOUNITS'
4958       include 'COMMON.FFIELD'
4959       include 'COMMON.TORCNSTR'
4960       logical lprn
4961 C Set lprn=.true. for debugging
4962       lprn=.false.
4963 c      lprn=.true.
4964       etors=0.0D0
4965       do i=iphi_start,iphi_end
4966         itori=itortyp(itype(i-2))
4967         itori1=itortyp(itype(i-1))
4968         phii=phi(i)
4969         gloci=0.0D0
4970 C Proline-Proline pair is a special case...
4971         if (itori.eq.3 .and. itori1.eq.3) then
4972           if (phii.gt.-dwapi3) then
4973             cosphi=dcos(3*phii)
4974             fac=1.0D0/(1.0D0-cosphi)
4975             etorsi=v1(1,3,3)*fac
4976             etorsi=etorsi+etorsi
4977             etors=etors+etorsi-v1(1,3,3)
4978             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4979           endif
4980           do j=1,3
4981             v1ij=v1(j+1,itori,itori1)
4982             v2ij=v2(j+1,itori,itori1)
4983             cosphi=dcos(j*phii)
4984             sinphi=dsin(j*phii)
4985             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4986             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4987           enddo
4988         else
4989           do j=1,nterm_old
4990             v1ij=v1(j,itori,itori1)
4991             v2ij=v2(j,itori,itori1)
4992             cosphi=dcos(j*phii)
4993             sinphi=dsin(j*phii)
4994             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4995             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4996           enddo
4997         endif
4998         if (lprn)
4999      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5000      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5001      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5002         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5003 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5004       enddo
5005 ! 6/20/98 - dihedral angle constraints
5006       edihcnstr=0.0d0
5007       do i=1,ndih_constr
5008         itori=idih_constr(i)
5009         phii=phi(itori)
5010         difi=phii-phi0(i)
5011         if (difi.gt.drange(i)) then
5012           difi=difi-drange(i)
5013           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5014           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5015         else if (difi.lt.-drange(i)) then
5016           difi=difi+drange(i)
5017           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5018           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5019         endif
5020 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5021 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5022       enddo
5023 !      write (iout,*) 'edihcnstr',edihcnstr
5024       return
5025       end
5026 c------------------------------------------------------------------------------
5027 #else
5028       subroutine etor(etors,edihcnstr,fact)
5029       implicit real*8 (a-h,o-z)
5030       include 'DIMENSIONS'
5031       include 'DIMENSIONS.ZSCOPT'
5032       include 'COMMON.VAR'
5033       include 'COMMON.GEO'
5034       include 'COMMON.LOCAL'
5035       include 'COMMON.TORSION'
5036       include 'COMMON.INTERACT'
5037       include 'COMMON.DERIV'
5038       include 'COMMON.CHAIN'
5039       include 'COMMON.NAMES'
5040       include 'COMMON.IOUNITS'
5041       include 'COMMON.FFIELD'
5042       include 'COMMON.TORCNSTR'
5043       logical lprn
5044 C Set lprn=.true. for debugging
5045       lprn=.false.
5046 c      lprn=.true.
5047       etors=0.0D0
5048       do i=iphi_start,iphi_end
5049         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5050         itori=itortyp(itype(i-2))
5051         itori1=itortyp(itype(i-1))
5052         phii=phi(i)
5053         gloci=0.0D0
5054 C Regular cosine and sine terms
5055         do j=1,nterm(itori,itori1)
5056           v1ij=v1(j,itori,itori1)
5057           v2ij=v2(j,itori,itori1)
5058           cosphi=dcos(j*phii)
5059           sinphi=dsin(j*phii)
5060           etors=etors+v1ij*cosphi+v2ij*sinphi
5061           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5062         enddo
5063 C Lorentz terms
5064 C                         v1
5065 C  E = SUM ----------------------------------- - v1
5066 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5067 C
5068         cosphi=dcos(0.5d0*phii)
5069         sinphi=dsin(0.5d0*phii)
5070         do j=1,nlor(itori,itori1)
5071           vl1ij=vlor1(j,itori,itori1)
5072           vl2ij=vlor2(j,itori,itori1)
5073           vl3ij=vlor3(j,itori,itori1)
5074           pom=vl2ij*cosphi+vl3ij*sinphi
5075           pom1=1.0d0/(pom*pom+1.0d0)
5076           etors=etors+vl1ij*pom1
5077           pom=-pom*pom1*pom1
5078           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5079         enddo
5080 C Subtract the constant term
5081         etors=etors-v0(itori,itori1)
5082         if (lprn)
5083      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5084      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5085      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5086         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5087 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5088  1215   continue
5089       enddo
5090 ! 6/20/98 - dihedral angle constraints
5091       edihcnstr=0.0d0
5092       do i=1,ndih_constr
5093         itori=idih_constr(i)
5094         phii=phi(itori)
5095         difi=pinorm(phii-phi0(i))
5096         edihi=0.0d0
5097         if (difi.gt.drange(i)) then
5098           difi=difi-drange(i)
5099           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5100           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5101           edihi=0.25d0*ftors*difi**4
5102         else if (difi.lt.-drange(i)) then
5103           difi=difi+drange(i)
5104           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5105           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5106           edihi=0.25d0*ftors*difi**4
5107         else
5108           difi=0.0d0
5109         endif
5110 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5111 c     &    drange(i),edihi
5112 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5113 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5114       enddo
5115 !      write (iout,*) 'edihcnstr',edihcnstr
5116       return
5117       end
5118 c----------------------------------------------------------------------------
5119       subroutine etor_d(etors_d,fact2)
5120 C 6/23/01 Compute double torsional energy
5121       implicit real*8 (a-h,o-z)
5122       include 'DIMENSIONS'
5123       include 'DIMENSIONS.ZSCOPT'
5124       include 'COMMON.VAR'
5125       include 'COMMON.GEO'
5126       include 'COMMON.LOCAL'
5127       include 'COMMON.TORSION'
5128       include 'COMMON.INTERACT'
5129       include 'COMMON.DERIV'
5130       include 'COMMON.CHAIN'
5131       include 'COMMON.NAMES'
5132       include 'COMMON.IOUNITS'
5133       include 'COMMON.FFIELD'
5134       include 'COMMON.TORCNSTR'
5135       logical lprn
5136 C Set lprn=.true. for debugging
5137       lprn=.false.
5138 c     lprn=.true.
5139       etors_d=0.0D0
5140       do i=iphi_start,iphi_end-1
5141         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5142      &     goto 1215
5143         itori=itortyp(itype(i-2))
5144         itori1=itortyp(itype(i-1))
5145         itori2=itortyp(itype(i))
5146         phii=phi(i)
5147         phii1=phi(i+1)
5148         gloci1=0.0D0
5149         gloci2=0.0D0
5150 C Regular cosine and sine terms
5151         do j=1,ntermd_1(itori,itori1,itori2)
5152           v1cij=v1c(1,j,itori,itori1,itori2)
5153           v1sij=v1s(1,j,itori,itori1,itori2)
5154           v2cij=v1c(2,j,itori,itori1,itori2)
5155           v2sij=v1s(2,j,itori,itori1,itori2)
5156           cosphi1=dcos(j*phii)
5157           sinphi1=dsin(j*phii)
5158           cosphi2=dcos(j*phii1)
5159           sinphi2=dsin(j*phii1)
5160           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5161      &     v2cij*cosphi2+v2sij*sinphi2
5162           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5163           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5164         enddo
5165         do k=2,ntermd_2(itori,itori1,itori2)
5166           do l=1,k-1
5167             v1cdij = v2c(k,l,itori,itori1,itori2)
5168             v2cdij = v2c(l,k,itori,itori1,itori2)
5169             v1sdij = v2s(k,l,itori,itori1,itori2)
5170             v2sdij = v2s(l,k,itori,itori1,itori2)
5171             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5172             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5173             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5174             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5175             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5176      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5177             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5178      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5179             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5180      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5181           enddo
5182         enddo
5183         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5184         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5185  1215   continue
5186       enddo
5187       return
5188       end
5189 #endif
5190 c------------------------------------------------------------------------------
5191       subroutine eback_sc_corr(esccor)
5192 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5193 c        conformational states; temporarily implemented as differences
5194 c        between UNRES torsional potentials (dependent on three types of
5195 c        residues) and the torsional potentials dependent on all 20 types
5196 c        of residues computed from AM1 energy surfaces of terminally-blocked
5197 c        amino-acid residues.
5198       implicit real*8 (a-h,o-z)
5199       include 'DIMENSIONS'
5200       include 'DIMENSIONS.ZSCOPT'
5201       include 'COMMON.VAR'
5202       include 'COMMON.GEO'
5203       include 'COMMON.LOCAL'
5204       include 'COMMON.TORSION'
5205       include 'COMMON.SCCOR'
5206       include 'COMMON.INTERACT'
5207       include 'COMMON.DERIV'
5208       include 'COMMON.CHAIN'
5209       include 'COMMON.NAMES'
5210       include 'COMMON.IOUNITS'
5211       include 'COMMON.FFIELD'
5212       include 'COMMON.CONTROL'
5213       logical lprn
5214 C Set lprn=.true. for debugging
5215       lprn=.false.
5216 c      lprn=.true.
5217 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5218       esccor=0.0D0
5219       do i=itau_start,itau_end
5220         esccor_ii=0.0D0
5221         isccori=isccortyp(itype(i-2))
5222         isccori1=isccortyp(itype(i-1))
5223         phii=phi(i)
5224 cccc  Added 9 May 2012
5225 cc Tauangle is torsional engle depending on the value of first digit
5226 c(see comment below)
5227 cc Omicron is flat angle depending on the value of first digit
5228 c(see comment below)
5229
5230
5231         do intertyp=1,3 !intertyp
5232 cc Added 09 May 2012 (Adasko)
5233 cc  Intertyp means interaction type of backbone mainchain correlation:
5234 c   1 = SC...Ca...Ca...Ca
5235 c   2 = Ca...Ca...Ca...SC
5236 c   3 = SC...Ca...Ca...SCi
5237         gloci=0.0D0
5238         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5239      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5240      &      (itype(i-1).eq.21)))
5241      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5242      &     .or.(itype(i-2).eq.21)))
5243      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5244      &      (itype(i-1).eq.21)))) cycle
5245         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5246         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5247      & cycle
5248         do j=1,nterm_sccor(isccori,isccori1)
5249           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5250           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5251           cosphi=dcos(j*tauangle(intertyp,i))
5252           sinphi=dsin(j*tauangle(intertyp,i))
5253           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5254           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5255         enddo
5256         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5257 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5258 c     &gloc_sc(intertyp,i-3,icg)
5259         if (lprn)
5260      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5261      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5262      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5263      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5264         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5265        enddo !intertyp
5266       enddo
5267 c        do i=1,nres
5268 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5269 c        enddo
5270       return
5271       end
5272 c------------------------------------------------------------------------------
5273       subroutine multibody(ecorr)
5274 C This subroutine calculates multi-body contributions to energy following
5275 C the idea of Skolnick et al. If side chains I and J make a contact and
5276 C at the same time side chains I+1 and J+1 make a contact, an extra
5277 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5278       implicit real*8 (a-h,o-z)
5279       include 'DIMENSIONS'
5280       include 'COMMON.IOUNITS'
5281       include 'COMMON.DERIV'
5282       include 'COMMON.INTERACT'
5283       include 'COMMON.CONTACTS'
5284       double precision gx(3),gx1(3)
5285       logical lprn
5286
5287 C Set lprn=.true. for debugging
5288       lprn=.false.
5289
5290       if (lprn) then
5291         write (iout,'(a)') 'Contact function values:'
5292         do i=nnt,nct-2
5293           write (iout,'(i2,20(1x,i2,f10.5))')
5294      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5295         enddo
5296       endif
5297       ecorr=0.0D0
5298       do i=nnt,nct
5299         do j=1,3
5300           gradcorr(j,i)=0.0D0
5301           gradxorr(j,i)=0.0D0
5302         enddo
5303       enddo
5304       do i=nnt,nct-2
5305
5306         DO ISHIFT = 3,4
5307
5308         i1=i+ishift
5309         num_conti=num_cont(i)
5310         num_conti1=num_cont(i1)
5311         do jj=1,num_conti
5312           j=jcont(jj,i)
5313           do kk=1,num_conti1
5314             j1=jcont(kk,i1)
5315             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5316 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5317 cd   &                   ' ishift=',ishift
5318 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5319 C The system gains extra energy.
5320               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5321             endif   ! j1==j+-ishift
5322           enddo     ! kk
5323         enddo       ! jj
5324
5325         ENDDO ! ISHIFT
5326
5327       enddo         ! i
5328       return
5329       end
5330 c------------------------------------------------------------------------------
5331       double precision function esccorr(i,j,k,l,jj,kk)
5332       implicit real*8 (a-h,o-z)
5333       include 'DIMENSIONS'
5334       include 'COMMON.IOUNITS'
5335       include 'COMMON.DERIV'
5336       include 'COMMON.INTERACT'
5337       include 'COMMON.CONTACTS'
5338       double precision gx(3),gx1(3)
5339       logical lprn
5340       lprn=.false.
5341       eij=facont(jj,i)
5342       ekl=facont(kk,k)
5343 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5344 C Calculate the multi-body contribution to energy.
5345 C Calculate multi-body contributions to the gradient.
5346 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5347 cd   & k,l,(gacont(m,kk,k),m=1,3)
5348       do m=1,3
5349         gx(m) =ekl*gacont(m,jj,i)
5350         gx1(m)=eij*gacont(m,kk,k)
5351         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5352         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5353         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5354         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5355       enddo
5356       do m=i,j-1
5357         do ll=1,3
5358           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5359         enddo
5360       enddo
5361       do m=k,l-1
5362         do ll=1,3
5363           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5364         enddo
5365       enddo
5366       esccorr=-eij*ekl
5367       return
5368       end
5369 c------------------------------------------------------------------------------
5370 #ifdef MPL
5371       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5372       implicit real*8 (a-h,o-z)
5373       include 'DIMENSIONS'
5374       integer dimen1,dimen2,atom,indx
5375       double precision buffer(dimen1,dimen2)
5376       double precision zapas
5377       common /contacts_hb/ zapas(3,20,maxres,7),
5378      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5379      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5380       num_kont=num_cont_hb(atom)
5381       do i=1,num_kont
5382         do k=1,7
5383           do j=1,3
5384             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5385           enddo ! j
5386         enddo ! k
5387         buffer(i,indx+22)=facont_hb(i,atom)
5388         buffer(i,indx+23)=ees0p(i,atom)
5389         buffer(i,indx+24)=ees0m(i,atom)
5390         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5391       enddo ! i
5392       buffer(1,indx+26)=dfloat(num_kont)
5393       return
5394       end
5395 c------------------------------------------------------------------------------
5396       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5397       implicit real*8 (a-h,o-z)
5398       include 'DIMENSIONS'
5399       integer dimen1,dimen2,atom,indx
5400       double precision buffer(dimen1,dimen2)
5401       double precision zapas
5402       common /contacts_hb/ zapas(3,20,maxres,7),
5403      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5404      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5405       num_kont=buffer(1,indx+26)
5406       num_kont_old=num_cont_hb(atom)
5407       num_cont_hb(atom)=num_kont+num_kont_old
5408       do i=1,num_kont
5409         ii=i+num_kont_old
5410         do k=1,7
5411           do j=1,3
5412             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5413           enddo ! j
5414         enddo ! k
5415         facont_hb(ii,atom)=buffer(i,indx+22)
5416         ees0p(ii,atom)=buffer(i,indx+23)
5417         ees0m(ii,atom)=buffer(i,indx+24)
5418         jcont_hb(ii,atom)=buffer(i,indx+25)
5419       enddo ! i
5420       return
5421       end
5422 c------------------------------------------------------------------------------
5423 #endif
5424       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5425 C This subroutine calculates multi-body contributions to hydrogen-bonding
5426       implicit real*8 (a-h,o-z)
5427       include 'DIMENSIONS'
5428       include 'DIMENSIONS.ZSCOPT'
5429       include 'COMMON.IOUNITS'
5430 #ifdef MPL
5431       include 'COMMON.INFO'
5432 #endif
5433       include 'COMMON.FFIELD'
5434       include 'COMMON.DERIV'
5435       include 'COMMON.INTERACT'
5436       include 'COMMON.CONTACTS'
5437 #ifdef MPL
5438       parameter (max_cont=maxconts)
5439       parameter (max_dim=2*(8*3+2))
5440       parameter (msglen1=max_cont*max_dim*4)
5441       parameter (msglen2=2*msglen1)
5442       integer source,CorrelType,CorrelID,Error
5443       double precision buffer(max_cont,max_dim)
5444 #endif
5445       double precision gx(3),gx1(3)
5446       logical lprn,ldone
5447
5448 C Set lprn=.true. for debugging
5449       lprn=.false.
5450 #ifdef MPL
5451       n_corr=0
5452       n_corr1=0
5453       if (fgProcs.le.1) goto 30
5454       if (lprn) then
5455         write (iout,'(a)') 'Contact function values:'
5456         do i=nnt,nct-2
5457           write (iout,'(2i3,50(1x,i2,f5.2))')
5458      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5459      &    j=1,num_cont_hb(i))
5460         enddo
5461       endif
5462 C Caution! Following code assumes that electrostatic interactions concerning
5463 C a given atom are split among at most two processors!
5464       CorrelType=477
5465       CorrelID=MyID+1
5466       ldone=.false.
5467       do i=1,max_cont
5468         do j=1,max_dim
5469           buffer(i,j)=0.0D0
5470         enddo
5471       enddo
5472       mm=mod(MyRank,2)
5473 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5474       if (mm) 20,20,10
5475    10 continue
5476 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5477       if (MyRank.gt.0) then
5478 C Send correlation contributions to the preceding processor
5479         msglen=msglen1
5480         nn=num_cont_hb(iatel_s)
5481         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5482 cd      write (iout,*) 'The BUFFER array:'
5483 cd      do i=1,nn
5484 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5485 cd      enddo
5486         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5487           msglen=msglen2
5488             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5489 C Clear the contacts of the atom passed to the neighboring processor
5490         nn=num_cont_hb(iatel_s+1)
5491 cd      do i=1,nn
5492 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5493 cd      enddo
5494             num_cont_hb(iatel_s)=0
5495         endif
5496 cd      write (iout,*) 'Processor ',MyID,MyRank,
5497 cd   & ' is sending correlation contribution to processor',MyID-1,
5498 cd   & ' msglen=',msglen
5499 cd      write (*,*) 'Processor ',MyID,MyRank,
5500 cd   & ' is sending correlation contribution to processor',MyID-1,
5501 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5502         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5503 cd      write (iout,*) 'Processor ',MyID,
5504 cd   & ' has sent correlation contribution to processor',MyID-1,
5505 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5506 cd      write (*,*) 'Processor ',MyID,
5507 cd   & ' has sent correlation contribution to processor',MyID-1,
5508 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5509         msglen=msglen1
5510       endif ! (MyRank.gt.0)
5511       if (ldone) goto 30
5512       ldone=.true.
5513    20 continue
5514 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5515       if (MyRank.lt.fgProcs-1) then
5516 C Receive correlation contributions from the next processor
5517         msglen=msglen1
5518         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5519 cd      write (iout,*) 'Processor',MyID,
5520 cd   & ' is receiving correlation contribution from processor',MyID+1,
5521 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5522 cd      write (*,*) 'Processor',MyID,
5523 cd   & ' is receiving correlation contribution from processor',MyID+1,
5524 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5525         nbytes=-1
5526         do while (nbytes.le.0)
5527           call mp_probe(MyID+1,CorrelType,nbytes)
5528         enddo
5529 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5530         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5531 cd      write (iout,*) 'Processor',MyID,
5532 cd   & ' has received correlation contribution from processor',MyID+1,
5533 cd   & ' msglen=',msglen,' nbytes=',nbytes
5534 cd      write (iout,*) 'The received BUFFER array:'
5535 cd      do i=1,max_cont
5536 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5537 cd      enddo
5538         if (msglen.eq.msglen1) then
5539           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5540         else if (msglen.eq.msglen2)  then
5541           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5542           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5543         else
5544           write (iout,*)
5545      & 'ERROR!!!! message length changed while processing correlations.'
5546           write (*,*)
5547      & 'ERROR!!!! message length changed while processing correlations.'
5548           call mp_stopall(Error)
5549         endif ! msglen.eq.msglen1
5550       endif ! MyRank.lt.fgProcs-1
5551       if (ldone) goto 30
5552       ldone=.true.
5553       goto 10
5554    30 continue
5555 #endif
5556       if (lprn) then
5557         write (iout,'(a)') 'Contact function values:'
5558         do i=nnt,nct-2
5559           write (iout,'(2i3,50(1x,i2,f5.2))')
5560      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5561      &    j=1,num_cont_hb(i))
5562         enddo
5563       endif
5564       ecorr=0.0D0
5565 C Remove the loop below after debugging !!!
5566       do i=nnt,nct
5567         do j=1,3
5568           gradcorr(j,i)=0.0D0
5569           gradxorr(j,i)=0.0D0
5570         enddo
5571       enddo
5572 C Calculate the local-electrostatic correlation terms
5573       do i=iatel_s,iatel_e+1
5574         i1=i+1
5575         num_conti=num_cont_hb(i)
5576         num_conti1=num_cont_hb(i+1)
5577         do jj=1,num_conti
5578           j=jcont_hb(jj,i)
5579           do kk=1,num_conti1
5580             j1=jcont_hb(kk,i1)
5581 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5582 c     &         ' jj=',jj,' kk=',kk
5583             if (j1.eq.j+1 .or. j1.eq.j-1) then
5584 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5585 C The system gains extra energy.
5586               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5587               n_corr=n_corr+1
5588             else if (j1.eq.j) then
5589 C Contacts I-J and I-(J+1) occur simultaneously.
5590 C The system loses extra energy.
5591 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5592             endif
5593           enddo ! kk
5594           do kk=1,num_conti
5595             j1=jcont_hb(kk,i)
5596 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5597 c    &         ' jj=',jj,' kk=',kk
5598             if (j1.eq.j+1) then
5599 C Contacts I-J and (I+1)-J occur simultaneously.
5600 C The system loses extra energy.
5601 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5602             endif ! j1==j+1
5603           enddo ! kk
5604         enddo ! jj
5605       enddo ! i
5606       return
5607       end
5608 c------------------------------------------------------------------------------
5609       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5610      &  n_corr1)
5611 C This subroutine calculates multi-body contributions to hydrogen-bonding
5612       implicit real*8 (a-h,o-z)
5613       include 'DIMENSIONS'
5614       include 'DIMENSIONS.ZSCOPT'
5615       include 'COMMON.IOUNITS'
5616 #ifdef MPL
5617       include 'COMMON.INFO'
5618 #endif
5619       include 'COMMON.FFIELD'
5620       include 'COMMON.DERIV'
5621       include 'COMMON.INTERACT'
5622       include 'COMMON.CONTACTS'
5623 #ifdef MPL
5624       parameter (max_cont=maxconts)
5625       parameter (max_dim=2*(8*3+2))
5626       parameter (msglen1=max_cont*max_dim*4)
5627       parameter (msglen2=2*msglen1)
5628       integer source,CorrelType,CorrelID,Error
5629       double precision buffer(max_cont,max_dim)
5630 #endif
5631       double precision gx(3),gx1(3)
5632       logical lprn,ldone
5633
5634 C Set lprn=.true. for debugging
5635       lprn=.false.
5636       eturn6=0.0d0
5637 #ifdef MPL
5638       n_corr=0
5639       n_corr1=0
5640       if (fgProcs.le.1) goto 30
5641       if (lprn) then
5642         write (iout,'(a)') 'Contact function values:'
5643         do i=nnt,nct-2
5644           write (iout,'(2i3,50(1x,i2,f5.2))')
5645      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5646      &    j=1,num_cont_hb(i))
5647         enddo
5648       endif
5649 C Caution! Following code assumes that electrostatic interactions concerning
5650 C a given atom are split among at most two processors!
5651       CorrelType=477
5652       CorrelID=MyID+1
5653       ldone=.false.
5654       do i=1,max_cont
5655         do j=1,max_dim
5656           buffer(i,j)=0.0D0
5657         enddo
5658       enddo
5659       mm=mod(MyRank,2)
5660 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5661       if (mm) 20,20,10
5662    10 continue
5663 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5664       if (MyRank.gt.0) then
5665 C Send correlation contributions to the preceding processor
5666         msglen=msglen1
5667         nn=num_cont_hb(iatel_s)
5668         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5669 cd      write (iout,*) 'The BUFFER array:'
5670 cd      do i=1,nn
5671 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5672 cd      enddo
5673         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5674           msglen=msglen2
5675             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5676 C Clear the contacts of the atom passed to the neighboring processor
5677         nn=num_cont_hb(iatel_s+1)
5678 cd      do i=1,nn
5679 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5680 cd      enddo
5681             num_cont_hb(iatel_s)=0
5682         endif
5683 cd      write (iout,*) 'Processor ',MyID,MyRank,
5684 cd   & ' is sending correlation contribution to processor',MyID-1,
5685 cd   & ' msglen=',msglen
5686 cd      write (*,*) 'Processor ',MyID,MyRank,
5687 cd   & ' is sending correlation contribution to processor',MyID-1,
5688 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5689         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5690 cd      write (iout,*) 'Processor ',MyID,
5691 cd   & ' has sent correlation contribution to processor',MyID-1,
5692 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5693 cd      write (*,*) 'Processor ',MyID,
5694 cd   & ' has sent correlation contribution to processor',MyID-1,
5695 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5696         msglen=msglen1
5697       endif ! (MyRank.gt.0)
5698       if (ldone) goto 30
5699       ldone=.true.
5700    20 continue
5701 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5702       if (MyRank.lt.fgProcs-1) then
5703 C Receive correlation contributions from the next processor
5704         msglen=msglen1
5705         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5706 cd      write (iout,*) 'Processor',MyID,
5707 cd   & ' is receiving correlation contribution from processor',MyID+1,
5708 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5709 cd      write (*,*) 'Processor',MyID,
5710 cd   & ' is receiving correlation contribution from processor',MyID+1,
5711 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5712         nbytes=-1
5713         do while (nbytes.le.0)
5714           call mp_probe(MyID+1,CorrelType,nbytes)
5715         enddo
5716 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5717         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5718 cd      write (iout,*) 'Processor',MyID,
5719 cd   & ' has received correlation contribution from processor',MyID+1,
5720 cd   & ' msglen=',msglen,' nbytes=',nbytes
5721 cd      write (iout,*) 'The received BUFFER array:'
5722 cd      do i=1,max_cont
5723 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5724 cd      enddo
5725         if (msglen.eq.msglen1) then
5726           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5727         else if (msglen.eq.msglen2)  then
5728           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5729           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5730         else
5731           write (iout,*)
5732      & 'ERROR!!!! message length changed while processing correlations.'
5733           write (*,*)
5734      & 'ERROR!!!! message length changed while processing correlations.'
5735           call mp_stopall(Error)
5736         endif ! msglen.eq.msglen1
5737       endif ! MyRank.lt.fgProcs-1
5738       if (ldone) goto 30
5739       ldone=.true.
5740       goto 10
5741    30 continue
5742 #endif
5743       if (lprn) then
5744         write (iout,'(a)') 'Contact function values:'
5745         do i=nnt,nct-2
5746           write (iout,'(2i3,50(1x,i2,f5.2))')
5747      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5748      &    j=1,num_cont_hb(i))
5749         enddo
5750       endif
5751       ecorr=0.0D0
5752       ecorr5=0.0d0
5753       ecorr6=0.0d0
5754 C Remove the loop below after debugging !!!
5755       do i=nnt,nct
5756         do j=1,3
5757           gradcorr(j,i)=0.0D0
5758           gradxorr(j,i)=0.0D0
5759         enddo
5760       enddo
5761 C Calculate the dipole-dipole interaction energies
5762       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5763       do i=iatel_s,iatel_e+1
5764         num_conti=num_cont_hb(i)
5765         do jj=1,num_conti
5766           j=jcont_hb(jj,i)
5767           call dipole(i,j,jj)
5768         enddo
5769       enddo
5770       endif
5771 C Calculate the local-electrostatic correlation terms
5772       do i=iatel_s,iatel_e+1
5773         i1=i+1
5774         num_conti=num_cont_hb(i)
5775         num_conti1=num_cont_hb(i+1)
5776         do jj=1,num_conti
5777           j=jcont_hb(jj,i)
5778           do kk=1,num_conti1
5779             j1=jcont_hb(kk,i1)
5780 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5781 c     &         ' jj=',jj,' kk=',kk
5782             if (j1.eq.j+1 .or. j1.eq.j-1) then
5783 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5784 C The system gains extra energy.
5785               n_corr=n_corr+1
5786               sqd1=dsqrt(d_cont(jj,i))
5787               sqd2=dsqrt(d_cont(kk,i1))
5788               sred_geom = sqd1*sqd2
5789               IF (sred_geom.lt.cutoff_corr) THEN
5790                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5791      &            ekont,fprimcont)
5792 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5793 c     &         ' jj=',jj,' kk=',kk
5794                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5795                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5796                 do l=1,3
5797                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5798                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5799                 enddo
5800                 n_corr1=n_corr1+1
5801 cd               write (iout,*) 'sred_geom=',sred_geom,
5802 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5803                 call calc_eello(i,j,i+1,j1,jj,kk)
5804                 if (wcorr4.gt.0.0d0)
5805      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5806                 if (wcorr5.gt.0.0d0)
5807      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5808 c                print *,"wcorr5",ecorr5
5809 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5810 cd                write(2,*)'ijkl',i,j,i+1,j1
5811                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5812      &               .or. wturn6.eq.0.0d0))then
5813 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5814                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5815 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5816 cd     &            'ecorr6=',ecorr6
5817 cd                write (iout,'(4e15.5)') sred_geom,
5818 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5819 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5820 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5821                 else if (wturn6.gt.0.0d0
5822      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5823 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5824                   eturn6=eturn6+eello_turn6(i,jj,kk)
5825 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5826                 endif
5827               ENDIF
5828 1111          continue
5829             else if (j1.eq.j) then
5830 C Contacts I-J and I-(J+1) occur simultaneously.
5831 C The system loses extra energy.
5832 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5833             endif
5834           enddo ! kk
5835           do kk=1,num_conti
5836             j1=jcont_hb(kk,i)
5837 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5838 c    &         ' jj=',jj,' kk=',kk
5839             if (j1.eq.j+1) then
5840 C Contacts I-J and (I+1)-J occur simultaneously.
5841 C The system loses extra energy.
5842 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5843             endif ! j1==j+1
5844           enddo ! kk
5845         enddo ! jj
5846       enddo ! i
5847       return
5848       end
5849 c------------------------------------------------------------------------------
5850       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5851       implicit real*8 (a-h,o-z)
5852       include 'DIMENSIONS'
5853       include 'COMMON.IOUNITS'
5854       include 'COMMON.DERIV'
5855       include 'COMMON.INTERACT'
5856       include 'COMMON.CONTACTS'
5857       double precision gx(3),gx1(3)
5858       logical lprn
5859       lprn=.false.
5860       eij=facont_hb(jj,i)
5861       ekl=facont_hb(kk,k)
5862       ees0pij=ees0p(jj,i)
5863       ees0pkl=ees0p(kk,k)
5864       ees0mij=ees0m(jj,i)
5865       ees0mkl=ees0m(kk,k)
5866       ekont=eij*ekl
5867       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5868 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5869 C Following 4 lines for diagnostics.
5870 cd    ees0pkl=0.0D0
5871 cd    ees0pij=1.0D0
5872 cd    ees0mkl=0.0D0
5873 cd    ees0mij=1.0D0
5874 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5875 c    &   ' and',k,l
5876 c     write (iout,*)'Contacts have occurred for peptide groups',
5877 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5878 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5879 C Calculate the multi-body contribution to energy.
5880       ecorr=ecorr+ekont*ees
5881       if (calc_grad) then
5882 C Calculate multi-body contributions to the gradient.
5883       do ll=1,3
5884         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5885         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5886      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5887      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5888         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5889      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5890      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5891         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5892         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5893      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5894      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5895         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5896      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5897      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5898       enddo
5899       do m=i+1,j-1
5900         do ll=1,3
5901           gradcorr(ll,m)=gradcorr(ll,m)+
5902      &     ees*ekl*gacont_hbr(ll,jj,i)-
5903      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5904      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5905         enddo
5906       enddo
5907       do m=k+1,l-1
5908         do ll=1,3
5909           gradcorr(ll,m)=gradcorr(ll,m)+
5910      &     ees*eij*gacont_hbr(ll,kk,k)-
5911      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5912      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5913         enddo
5914       enddo
5915       endif
5916       ehbcorr=ekont*ees
5917       return
5918       end
5919 C---------------------------------------------------------------------------
5920       subroutine dipole(i,j,jj)
5921       implicit real*8 (a-h,o-z)
5922       include 'DIMENSIONS'
5923       include 'DIMENSIONS.ZSCOPT'
5924       include 'COMMON.IOUNITS'
5925       include 'COMMON.CHAIN'
5926       include 'COMMON.FFIELD'
5927       include 'COMMON.DERIV'
5928       include 'COMMON.INTERACT'
5929       include 'COMMON.CONTACTS'
5930       include 'COMMON.TORSION'
5931       include 'COMMON.VAR'
5932       include 'COMMON.GEO'
5933       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5934      &  auxmat(2,2)
5935       iti1 = itortyp(itype(i+1))
5936       if (j.lt.nres-1) then
5937         itj1 = itortyp(itype(j+1))
5938       else
5939         itj1=ntortyp+1
5940       endif
5941       do iii=1,2
5942         dipi(iii,1)=Ub2(iii,i)
5943         dipderi(iii)=Ub2der(iii,i)
5944         dipi(iii,2)=b1(iii,iti1)
5945         dipj(iii,1)=Ub2(iii,j)
5946         dipderj(iii)=Ub2der(iii,j)
5947         dipj(iii,2)=b1(iii,itj1)
5948       enddo
5949       kkk=0
5950       do iii=1,2
5951         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5952         do jjj=1,2
5953           kkk=kkk+1
5954           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5955         enddo
5956       enddo
5957       if (.not.calc_grad) return
5958       do kkk=1,5
5959         do lll=1,3
5960           mmm=0
5961           do iii=1,2
5962             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5963      &        auxvec(1))
5964             do jjj=1,2
5965               mmm=mmm+1
5966               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5967             enddo
5968           enddo
5969         enddo
5970       enddo
5971       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5972       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5973       do iii=1,2
5974         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5975       enddo
5976       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5977       do iii=1,2
5978         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5979       enddo
5980       return
5981       end
5982 C---------------------------------------------------------------------------
5983       subroutine calc_eello(i,j,k,l,jj,kk)
5984 C
5985 C This subroutine computes matrices and vectors needed to calculate
5986 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5987 C
5988       implicit real*8 (a-h,o-z)
5989       include 'DIMENSIONS'
5990       include 'DIMENSIONS.ZSCOPT'
5991       include 'COMMON.IOUNITS'
5992       include 'COMMON.CHAIN'
5993       include 'COMMON.DERIV'
5994       include 'COMMON.INTERACT'
5995       include 'COMMON.CONTACTS'
5996       include 'COMMON.TORSION'
5997       include 'COMMON.VAR'
5998       include 'COMMON.GEO'
5999       include 'COMMON.FFIELD'
6000       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6001      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6002       logical lprn
6003       common /kutas/ lprn
6004 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6005 cd     & ' jj=',jj,' kk=',kk
6006 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6007       do iii=1,2
6008         do jjj=1,2
6009           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6010           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6011         enddo
6012       enddo
6013       call transpose2(aa1(1,1),aa1t(1,1))
6014       call transpose2(aa2(1,1),aa2t(1,1))
6015       do kkk=1,5
6016         do lll=1,3
6017           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6018      &      aa1tder(1,1,lll,kkk))
6019           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6020      &      aa2tder(1,1,lll,kkk))
6021         enddo
6022       enddo
6023       if (l.eq.j+1) then
6024 C parallel orientation of the two CA-CA-CA frames.
6025         if (i.gt.1) then
6026           iti=itortyp(itype(i))
6027         else
6028           iti=ntortyp+1
6029         endif
6030         itk1=itortyp(itype(k+1))
6031         itj=itortyp(itype(j))
6032         if (l.lt.nres-1) then
6033           itl1=itortyp(itype(l+1))
6034         else
6035           itl1=ntortyp+1
6036         endif
6037 C A1 kernel(j+1) A2T
6038 cd        do iii=1,2
6039 cd          write (iout,'(3f10.5,5x,3f10.5)')
6040 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6041 cd        enddo
6042         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6043      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6044      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6045 C Following matrices are needed only for 6-th order cumulants
6046         IF (wcorr6.gt.0.0d0) THEN
6047         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6048      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6049      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6050         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6051      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6052      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6053      &   ADtEAderx(1,1,1,1,1,1))
6054         lprn=.false.
6055         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6056      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6057      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6058      &   ADtEA1derx(1,1,1,1,1,1))
6059         ENDIF
6060 C End 6-th order cumulants
6061 cd        lprn=.false.
6062 cd        if (lprn) then
6063 cd        write (2,*) 'In calc_eello6'
6064 cd        do iii=1,2
6065 cd          write (2,*) 'iii=',iii
6066 cd          do kkk=1,5
6067 cd            write (2,*) 'kkk=',kkk
6068 cd            do jjj=1,2
6069 cd              write (2,'(3(2f10.5),5x)')
6070 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6071 cd            enddo
6072 cd          enddo
6073 cd        enddo
6074 cd        endif
6075         call transpose2(EUgder(1,1,k),auxmat(1,1))
6076         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6077         call transpose2(EUg(1,1,k),auxmat(1,1))
6078         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6079         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6080         do iii=1,2
6081           do kkk=1,5
6082             do lll=1,3
6083               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6084      &          EAEAderx(1,1,lll,kkk,iii,1))
6085             enddo
6086           enddo
6087         enddo
6088 C A1T kernel(i+1) A2
6089         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6090      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6091      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6092 C Following matrices are needed only for 6-th order cumulants
6093         IF (wcorr6.gt.0.0d0) THEN
6094         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6095      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6096      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6097         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6098      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6099      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6100      &   ADtEAderx(1,1,1,1,1,2))
6101         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6102      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6103      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6104      &   ADtEA1derx(1,1,1,1,1,2))
6105         ENDIF
6106 C End 6-th order cumulants
6107         call transpose2(EUgder(1,1,l),auxmat(1,1))
6108         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6109         call transpose2(EUg(1,1,l),auxmat(1,1))
6110         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6111         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6112         do iii=1,2
6113           do kkk=1,5
6114             do lll=1,3
6115               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6116      &          EAEAderx(1,1,lll,kkk,iii,2))
6117             enddo
6118           enddo
6119         enddo
6120 C AEAb1 and AEAb2
6121 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6122 C They are needed only when the fifth- or the sixth-order cumulants are
6123 C indluded.
6124         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6125         call transpose2(AEA(1,1,1),auxmat(1,1))
6126         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6127         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6128         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6129         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6130         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6131         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6132         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6133         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6134         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6135         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6136         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6137         call transpose2(AEA(1,1,2),auxmat(1,1))
6138         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6139         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6140         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6141         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6142         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6143         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6144         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6145         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6146         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6147         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6148         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6149 C Calculate the Cartesian derivatives of the vectors.
6150         do iii=1,2
6151           do kkk=1,5
6152             do lll=1,3
6153               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6154               call matvec2(auxmat(1,1),b1(1,iti),
6155      &          AEAb1derx(1,lll,kkk,iii,1,1))
6156               call matvec2(auxmat(1,1),Ub2(1,i),
6157      &          AEAb2derx(1,lll,kkk,iii,1,1))
6158               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6159      &          AEAb1derx(1,lll,kkk,iii,2,1))
6160               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6161      &          AEAb2derx(1,lll,kkk,iii,2,1))
6162               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6163               call matvec2(auxmat(1,1),b1(1,itj),
6164      &          AEAb1derx(1,lll,kkk,iii,1,2))
6165               call matvec2(auxmat(1,1),Ub2(1,j),
6166      &          AEAb2derx(1,lll,kkk,iii,1,2))
6167               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6168      &          AEAb1derx(1,lll,kkk,iii,2,2))
6169               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6170      &          AEAb2derx(1,lll,kkk,iii,2,2))
6171             enddo
6172           enddo
6173         enddo
6174         ENDIF
6175 C End vectors
6176       else
6177 C Antiparallel orientation of the two CA-CA-CA frames.
6178         if (i.gt.1) then
6179           iti=itortyp(itype(i))
6180         else
6181           iti=ntortyp+1
6182         endif
6183         itk1=itortyp(itype(k+1))
6184         itl=itortyp(itype(l))
6185         itj=itortyp(itype(j))
6186         if (j.lt.nres-1) then
6187           itj1=itortyp(itype(j+1))
6188         else
6189           itj1=ntortyp+1
6190         endif
6191 C A2 kernel(j-1)T A1T
6192         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6193      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6194      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6195 C Following matrices are needed only for 6-th order cumulants
6196         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6197      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6198         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6199      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6200      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6201         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6202      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6203      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6204      &   ADtEAderx(1,1,1,1,1,1))
6205         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6206      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6207      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6208      &   ADtEA1derx(1,1,1,1,1,1))
6209         ENDIF
6210 C End 6-th order cumulants
6211         call transpose2(EUgder(1,1,k),auxmat(1,1))
6212         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6213         call transpose2(EUg(1,1,k),auxmat(1,1))
6214         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6215         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
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      &          EAEAderx(1,1,lll,kkk,iii,1))
6221             enddo
6222           enddo
6223         enddo
6224 C A2T kernel(i+1)T A1
6225         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6226      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6227      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6228 C Following matrices are needed only for 6-th order cumulants
6229         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6230      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6231         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6232      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6233      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6234         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6235      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6236      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6237      &   ADtEAderx(1,1,1,1,1,2))
6238         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6239      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6240      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6241      &   ADtEA1derx(1,1,1,1,1,2))
6242         ENDIF
6243 C End 6-th order cumulants
6244         call transpose2(EUgder(1,1,j),auxmat(1,1))
6245         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6246         call transpose2(EUg(1,1,j),auxmat(1,1))
6247         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6248         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6249         do iii=1,2
6250           do kkk=1,5
6251             do lll=1,3
6252               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6253      &          EAEAderx(1,1,lll,kkk,iii,2))
6254             enddo
6255           enddo
6256         enddo
6257 C AEAb1 and AEAb2
6258 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6259 C They are needed only when the fifth- or the sixth-order cumulants are
6260 C indluded.
6261         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6262      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6263         call transpose2(AEA(1,1,1),auxmat(1,1))
6264         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6265         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6266         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6267         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6268         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6269         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6270         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6271         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6272         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6273         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6274         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6275         call transpose2(AEA(1,1,2),auxmat(1,1))
6276         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6277         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6278         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6279         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6280         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6281         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6282         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6283         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6284         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6285         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6286         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6287 C Calculate the Cartesian derivatives of the vectors.
6288         do iii=1,2
6289           do kkk=1,5
6290             do lll=1,3
6291               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6292               call matvec2(auxmat(1,1),b1(1,iti),
6293      &          AEAb1derx(1,lll,kkk,iii,1,1))
6294               call matvec2(auxmat(1,1),Ub2(1,i),
6295      &          AEAb2derx(1,lll,kkk,iii,1,1))
6296               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6297      &          AEAb1derx(1,lll,kkk,iii,2,1))
6298               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6299      &          AEAb2derx(1,lll,kkk,iii,2,1))
6300               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6301               call matvec2(auxmat(1,1),b1(1,itl),
6302      &          AEAb1derx(1,lll,kkk,iii,1,2))
6303               call matvec2(auxmat(1,1),Ub2(1,l),
6304      &          AEAb2derx(1,lll,kkk,iii,1,2))
6305               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6306      &          AEAb1derx(1,lll,kkk,iii,2,2))
6307               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6308      &          AEAb2derx(1,lll,kkk,iii,2,2))
6309             enddo
6310           enddo
6311         enddo
6312         ENDIF
6313 C End vectors
6314       endif
6315       return
6316       end
6317 C---------------------------------------------------------------------------
6318       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6319      &  KK,KKderg,AKA,AKAderg,AKAderx)
6320       implicit none
6321       integer nderg
6322       logical transp
6323       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6324      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6325      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6326       integer iii,kkk,lll
6327       integer jjj,mmm
6328       logical lprn
6329       common /kutas/ lprn
6330       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6331       do iii=1,nderg
6332         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6333      &    AKAderg(1,1,iii))
6334       enddo
6335 cd      if (lprn) write (2,*) 'In kernel'
6336       do kkk=1,5
6337 cd        if (lprn) write (2,*) 'kkk=',kkk
6338         do lll=1,3
6339           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6340      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6341 cd          if (lprn) then
6342 cd            write (2,*) 'lll=',lll
6343 cd            write (2,*) 'iii=1'
6344 cd            do jjj=1,2
6345 cd              write (2,'(3(2f10.5),5x)')
6346 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6347 cd            enddo
6348 cd          endif
6349           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6350      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6351 cd          if (lprn) then
6352 cd            write (2,*) 'lll=',lll
6353 cd            write (2,*) 'iii=2'
6354 cd            do jjj=1,2
6355 cd              write (2,'(3(2f10.5),5x)')
6356 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6357 cd            enddo
6358 cd          endif
6359         enddo
6360       enddo
6361       return
6362       end
6363 C---------------------------------------------------------------------------
6364       double precision function eello4(i,j,k,l,jj,kk)
6365       implicit real*8 (a-h,o-z)
6366       include 'DIMENSIONS'
6367       include 'DIMENSIONS.ZSCOPT'
6368       include 'COMMON.IOUNITS'
6369       include 'COMMON.CHAIN'
6370       include 'COMMON.DERIV'
6371       include 'COMMON.INTERACT'
6372       include 'COMMON.CONTACTS'
6373       include 'COMMON.TORSION'
6374       include 'COMMON.VAR'
6375       include 'COMMON.GEO'
6376       double precision pizda(2,2),ggg1(3),ggg2(3)
6377 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6378 cd        eello4=0.0d0
6379 cd        return
6380 cd      endif
6381 cd      print *,'eello4:',i,j,k,l,jj,kk
6382 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6383 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6384 cold      eij=facont_hb(jj,i)
6385 cold      ekl=facont_hb(kk,k)
6386 cold      ekont=eij*ekl
6387       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6388       if (calc_grad) then
6389 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6390       gcorr_loc(k-1)=gcorr_loc(k-1)
6391      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6392       if (l.eq.j+1) then
6393         gcorr_loc(l-1)=gcorr_loc(l-1)
6394      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6395       else
6396         gcorr_loc(j-1)=gcorr_loc(j-1)
6397      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6398       endif
6399       do iii=1,2
6400         do kkk=1,5
6401           do lll=1,3
6402             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6403      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6404 cd            derx(lll,kkk,iii)=0.0d0
6405           enddo
6406         enddo
6407       enddo
6408 cd      gcorr_loc(l-1)=0.0d0
6409 cd      gcorr_loc(j-1)=0.0d0
6410 cd      gcorr_loc(k-1)=0.0d0
6411 cd      eel4=1.0d0
6412 cd      write (iout,*)'Contacts have occurred for peptide groups',
6413 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6414 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6415       if (j.lt.nres-1) then
6416         j1=j+1
6417         j2=j-1
6418       else
6419         j1=j-1
6420         j2=j-2
6421       endif
6422       if (l.lt.nres-1) then
6423         l1=l+1
6424         l2=l-1
6425       else
6426         l1=l-1
6427         l2=l-2
6428       endif
6429       do ll=1,3
6430 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6431         ggg1(ll)=eel4*g_contij(ll,1)
6432         ggg2(ll)=eel4*g_contij(ll,2)
6433         ghalf=0.5d0*ggg1(ll)
6434 cd        ghalf=0.0d0
6435         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6436         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6437         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6438         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6439 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6440         ghalf=0.5d0*ggg2(ll)
6441 cd        ghalf=0.0d0
6442         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6443         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6444         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6445         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6446       enddo
6447 cd      goto 1112
6448       do m=i+1,j-1
6449         do ll=1,3
6450 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6451           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6452         enddo
6453       enddo
6454       do m=k+1,l-1
6455         do ll=1,3
6456 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6457           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6458         enddo
6459       enddo
6460 1112  continue
6461       do m=i+2,j2
6462         do ll=1,3
6463           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6464         enddo
6465       enddo
6466       do m=k+2,l2
6467         do ll=1,3
6468           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6469         enddo
6470       enddo
6471 cd      do iii=1,nres-3
6472 cd        write (2,*) iii,gcorr_loc(iii)
6473 cd      enddo
6474       endif
6475       eello4=ekont*eel4
6476 cd      write (2,*) 'ekont',ekont
6477 cd      write (iout,*) 'eello4',ekont*eel4
6478       return
6479       end
6480 C---------------------------------------------------------------------------
6481       double precision function eello5(i,j,k,l,jj,kk)
6482       implicit real*8 (a-h,o-z)
6483       include 'DIMENSIONS'
6484       include 'DIMENSIONS.ZSCOPT'
6485       include 'COMMON.IOUNITS'
6486       include 'COMMON.CHAIN'
6487       include 'COMMON.DERIV'
6488       include 'COMMON.INTERACT'
6489       include 'COMMON.CONTACTS'
6490       include 'COMMON.TORSION'
6491       include 'COMMON.VAR'
6492       include 'COMMON.GEO'
6493       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6494       double precision ggg1(3),ggg2(3)
6495 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6496 C                                                                              C
6497 C                            Parallel chains                                   C
6498 C                                                                              C
6499 C          o             o                   o             o                   C
6500 C         /l\           / \             \   / \           / \   /              C
6501 C        /   \         /   \             \ /   \         /   \ /               C
6502 C       j| o |l1       | o |              o| o |         | o |o                C
6503 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6504 C      \i/   \         /   \ /             /   \         /   \                 C
6505 C       o    k1             o                                                  C
6506 C         (I)          (II)                (III)          (IV)                 C
6507 C                                                                              C
6508 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6509 C                                                                              C
6510 C                            Antiparallel chains                               C
6511 C                                                                              C
6512 C          o             o                   o             o                   C
6513 C         /j\           / \             \   / \           / \   /              C
6514 C        /   \         /   \             \ /   \         /   \ /               C
6515 C      j1| o |l        | o |              o| o |         | o |o                C
6516 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6517 C      \i/   \         /   \ /             /   \         /   \                 C
6518 C       o     k1            o                                                  C
6519 C         (I)          (II)                (III)          (IV)                 C
6520 C                                                                              C
6521 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6522 C                                                                              C
6523 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6524 C                                                                              C
6525 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6526 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6527 cd        eello5=0.0d0
6528 cd        return
6529 cd      endif
6530 cd      write (iout,*)
6531 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6532 cd     &   ' and',k,l
6533       itk=itortyp(itype(k))
6534       itl=itortyp(itype(l))
6535       itj=itortyp(itype(j))
6536       eello5_1=0.0d0
6537       eello5_2=0.0d0
6538       eello5_3=0.0d0
6539       eello5_4=0.0d0
6540 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6541 cd     &   eel5_3_num,eel5_4_num)
6542       do iii=1,2
6543         do kkk=1,5
6544           do lll=1,3
6545             derx(lll,kkk,iii)=0.0d0
6546           enddo
6547         enddo
6548       enddo
6549 cd      eij=facont_hb(jj,i)
6550 cd      ekl=facont_hb(kk,k)
6551 cd      ekont=eij*ekl
6552 cd      write (iout,*)'Contacts have occurred for peptide groups',
6553 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6554 cd      goto 1111
6555 C Contribution from the graph I.
6556 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6557 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6558       call transpose2(EUg(1,1,k),auxmat(1,1))
6559       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6560       vv(1)=pizda(1,1)-pizda(2,2)
6561       vv(2)=pizda(1,2)+pizda(2,1)
6562       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6563      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6564       if (calc_grad) then
6565 C Explicit gradient in virtual-dihedral angles.
6566       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6567      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6568      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6569       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6570       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6571       vv(1)=pizda(1,1)-pizda(2,2)
6572       vv(2)=pizda(1,2)+pizda(2,1)
6573       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6574      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6575      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6576       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6577       vv(1)=pizda(1,1)-pizda(2,2)
6578       vv(2)=pizda(1,2)+pizda(2,1)
6579       if (l.eq.j+1) then
6580         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6581      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6582      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6583       else
6584         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6585      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6587       endif
6588 C Cartesian gradient
6589       do iii=1,2
6590         do kkk=1,5
6591           do lll=1,3
6592             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6593      &        pizda(1,1))
6594             vv(1)=pizda(1,1)-pizda(2,2)
6595             vv(2)=pizda(1,2)+pizda(2,1)
6596             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6597      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6598      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6599           enddo
6600         enddo
6601       enddo
6602 c      goto 1112
6603       endif
6604 c1111  continue
6605 C Contribution from graph II
6606       call transpose2(EE(1,1,itk),auxmat(1,1))
6607       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6608       vv(1)=pizda(1,1)+pizda(2,2)
6609       vv(2)=pizda(2,1)-pizda(1,2)
6610       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6611      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6612       if (calc_grad) then
6613 C Explicit gradient in virtual-dihedral angles.
6614       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6615      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6616       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6617       vv(1)=pizda(1,1)+pizda(2,2)
6618       vv(2)=pizda(2,1)-pizda(1,2)
6619       if (l.eq.j+1) then
6620         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6621      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6622      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6623       else
6624         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6625      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6626      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6627       endif
6628 C Cartesian gradient
6629       do iii=1,2
6630         do kkk=1,5
6631           do lll=1,3
6632             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6633      &        pizda(1,1))
6634             vv(1)=pizda(1,1)+pizda(2,2)
6635             vv(2)=pizda(2,1)-pizda(1,2)
6636             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6637      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6638      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6639           enddo
6640         enddo
6641       enddo
6642 cd      goto 1112
6643       endif
6644 cd1111  continue
6645       if (l.eq.j+1) then
6646 cd        goto 1110
6647 C Parallel orientation
6648 C Contribution from graph III
6649         call transpose2(EUg(1,1,l),auxmat(1,1))
6650         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6651         vv(1)=pizda(1,1)-pizda(2,2)
6652         vv(2)=pizda(1,2)+pizda(2,1)
6653         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6654      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6655         if (calc_grad) then
6656 C Explicit gradient in virtual-dihedral angles.
6657         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6658      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6659      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6660         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6661         vv(1)=pizda(1,1)-pizda(2,2)
6662         vv(2)=pizda(1,2)+pizda(2,1)
6663         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6664      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6665      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6666         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6667         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6668         vv(1)=pizda(1,1)-pizda(2,2)
6669         vv(2)=pizda(1,2)+pizda(2,1)
6670         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6671      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6672      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6673 C Cartesian gradient
6674         do iii=1,2
6675           do kkk=1,5
6676             do lll=1,3
6677               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6678      &          pizda(1,1))
6679               vv(1)=pizda(1,1)-pizda(2,2)
6680               vv(2)=pizda(1,2)+pizda(2,1)
6681               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6682      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6683      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6684             enddo
6685           enddo
6686         enddo
6687 cd        goto 1112
6688         endif
6689 C Contribution from graph IV
6690 cd1110    continue
6691         call transpose2(EE(1,1,itl),auxmat(1,1))
6692         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6693         vv(1)=pizda(1,1)+pizda(2,2)
6694         vv(2)=pizda(2,1)-pizda(1,2)
6695         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6696      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6697         if (calc_grad) then
6698 C Explicit gradient in virtual-dihedral angles.
6699         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6700      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6701         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6702         vv(1)=pizda(1,1)+pizda(2,2)
6703         vv(2)=pizda(2,1)-pizda(1,2)
6704         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6705      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6706      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6707 C Cartesian gradient
6708         do iii=1,2
6709           do kkk=1,5
6710             do lll=1,3
6711               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6712      &          pizda(1,1))
6713               vv(1)=pizda(1,1)+pizda(2,2)
6714               vv(2)=pizda(2,1)-pizda(1,2)
6715               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6716      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6717      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6718             enddo
6719           enddo
6720         enddo
6721         endif
6722       else
6723 C Antiparallel orientation
6724 C Contribution from graph III
6725 c        goto 1110
6726         call transpose2(EUg(1,1,j),auxmat(1,1))
6727         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6728         vv(1)=pizda(1,1)-pizda(2,2)
6729         vv(2)=pizda(1,2)+pizda(2,1)
6730         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6731      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6732         if (calc_grad) then
6733 C Explicit gradient in virtual-dihedral angles.
6734         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6735      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6736      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6737         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6738         vv(1)=pizda(1,1)-pizda(2,2)
6739         vv(2)=pizda(1,2)+pizda(2,1)
6740         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6741      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6742      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6743         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6744         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6745         vv(1)=pizda(1,1)-pizda(2,2)
6746         vv(2)=pizda(1,2)+pizda(2,1)
6747         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6748      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6749      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6750 C Cartesian gradient
6751         do iii=1,2
6752           do kkk=1,5
6753             do lll=1,3
6754               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6755      &          pizda(1,1))
6756               vv(1)=pizda(1,1)-pizda(2,2)
6757               vv(2)=pizda(1,2)+pizda(2,1)
6758               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6759      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6760      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6761             enddo
6762           enddo
6763         enddo
6764 cd        goto 1112
6765         endif
6766 C Contribution from graph IV
6767 1110    continue
6768         call transpose2(EE(1,1,itj),auxmat(1,1))
6769         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6770         vv(1)=pizda(1,1)+pizda(2,2)
6771         vv(2)=pizda(2,1)-pizda(1,2)
6772         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6773      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6774         if (calc_grad) then
6775 C Explicit gradient in virtual-dihedral angles.
6776         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6777      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6778         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6779         vv(1)=pizda(1,1)+pizda(2,2)
6780         vv(2)=pizda(2,1)-pizda(1,2)
6781         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6782      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6783      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6784 C Cartesian gradient
6785         do iii=1,2
6786           do kkk=1,5
6787             do lll=1,3
6788               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6789      &          pizda(1,1))
6790               vv(1)=pizda(1,1)+pizda(2,2)
6791               vv(2)=pizda(2,1)-pizda(1,2)
6792               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6793      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6794      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6795             enddo
6796           enddo
6797         enddo
6798       endif
6799       endif
6800 1112  continue
6801       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6802 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6803 cd        write (2,*) 'ijkl',i,j,k,l
6804 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6805 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6806 cd      endif
6807 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6808 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6809 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6810 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6811       if (calc_grad) then
6812       if (j.lt.nres-1) then
6813         j1=j+1
6814         j2=j-1
6815       else
6816         j1=j-1
6817         j2=j-2
6818       endif
6819       if (l.lt.nres-1) then
6820         l1=l+1
6821         l2=l-1
6822       else
6823         l1=l-1
6824         l2=l-2
6825       endif
6826 cd      eij=1.0d0
6827 cd      ekl=1.0d0
6828 cd      ekont=1.0d0
6829 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6830       do ll=1,3
6831         ggg1(ll)=eel5*g_contij(ll,1)
6832         ggg2(ll)=eel5*g_contij(ll,2)
6833 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6834         ghalf=0.5d0*ggg1(ll)
6835 cd        ghalf=0.0d0
6836         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6837         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6838         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6839         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6840 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6841         ghalf=0.5d0*ggg2(ll)
6842 cd        ghalf=0.0d0
6843         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6844         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6845         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6846         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6847       enddo
6848 cd      goto 1112
6849       do m=i+1,j-1
6850         do ll=1,3
6851 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6852           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6853         enddo
6854       enddo
6855       do m=k+1,l-1
6856         do ll=1,3
6857 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6858           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6859         enddo
6860       enddo
6861 c1112  continue
6862       do m=i+2,j2
6863         do ll=1,3
6864           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6865         enddo
6866       enddo
6867       do m=k+2,l2
6868         do ll=1,3
6869           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6870         enddo
6871       enddo
6872 cd      do iii=1,nres-3
6873 cd        write (2,*) iii,g_corr5_loc(iii)
6874 cd      enddo
6875       endif
6876       eello5=ekont*eel5
6877 cd      write (2,*) 'ekont',ekont
6878 cd      write (iout,*) 'eello5',ekont*eel5
6879       return
6880       end
6881 c--------------------------------------------------------------------------
6882       double precision function eello6(i,j,k,l,jj,kk)
6883       implicit real*8 (a-h,o-z)
6884       include 'DIMENSIONS'
6885       include 'DIMENSIONS.ZSCOPT'
6886       include 'COMMON.IOUNITS'
6887       include 'COMMON.CHAIN'
6888       include 'COMMON.DERIV'
6889       include 'COMMON.INTERACT'
6890       include 'COMMON.CONTACTS'
6891       include 'COMMON.TORSION'
6892       include 'COMMON.VAR'
6893       include 'COMMON.GEO'
6894       include 'COMMON.FFIELD'
6895       double precision ggg1(3),ggg2(3)
6896 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6897 cd        eello6=0.0d0
6898 cd        return
6899 cd      endif
6900 cd      write (iout,*)
6901 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6902 cd     &   ' and',k,l
6903       eello6_1=0.0d0
6904       eello6_2=0.0d0
6905       eello6_3=0.0d0
6906       eello6_4=0.0d0
6907       eello6_5=0.0d0
6908       eello6_6=0.0d0
6909 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6910 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6911       do iii=1,2
6912         do kkk=1,5
6913           do lll=1,3
6914             derx(lll,kkk,iii)=0.0d0
6915           enddo
6916         enddo
6917       enddo
6918 cd      eij=facont_hb(jj,i)
6919 cd      ekl=facont_hb(kk,k)
6920 cd      ekont=eij*ekl
6921 cd      eij=1.0d0
6922 cd      ekl=1.0d0
6923 cd      ekont=1.0d0
6924       if (l.eq.j+1) then
6925         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6926         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6927         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6928         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6929         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6930         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6931       else
6932         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6933         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6934         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6935         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6936         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6937           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6938         else
6939           eello6_5=0.0d0
6940         endif
6941         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6942       endif
6943 C If turn contributions are considered, they will be handled separately.
6944       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6945 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6946 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6947 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6948 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6949 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6950 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6951 cd      goto 1112
6952       if (calc_grad) then
6953       if (j.lt.nres-1) then
6954         j1=j+1
6955         j2=j-1
6956       else
6957         j1=j-1
6958         j2=j-2
6959       endif
6960       if (l.lt.nres-1) then
6961         l1=l+1
6962         l2=l-1
6963       else
6964         l1=l-1
6965         l2=l-2
6966       endif
6967       do ll=1,3
6968         ggg1(ll)=eel6*g_contij(ll,1)
6969         ggg2(ll)=eel6*g_contij(ll,2)
6970 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6971         ghalf=0.5d0*ggg1(ll)
6972 cd        ghalf=0.0d0
6973         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6974         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6975         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6976         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6977         ghalf=0.5d0*ggg2(ll)
6978 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6979 cd        ghalf=0.0d0
6980         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6981         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6982         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6983         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6984       enddo
6985 cd      goto 1112
6986       do m=i+1,j-1
6987         do ll=1,3
6988 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6989           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6990         enddo
6991       enddo
6992       do m=k+1,l-1
6993         do ll=1,3
6994 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6995           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6996         enddo
6997       enddo
6998 1112  continue
6999       do m=i+2,j2
7000         do ll=1,3
7001           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7002         enddo
7003       enddo
7004       do m=k+2,l2
7005         do ll=1,3
7006           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7007         enddo
7008       enddo
7009 cd      do iii=1,nres-3
7010 cd        write (2,*) iii,g_corr6_loc(iii)
7011 cd      enddo
7012       endif
7013       eello6=ekont*eel6
7014 cd      write (2,*) 'ekont',ekont
7015 cd      write (iout,*) 'eello6',ekont*eel6
7016       return
7017       end
7018 c--------------------------------------------------------------------------
7019       double precision function eello6_graph1(i,j,k,l,imat,swap)
7020       implicit real*8 (a-h,o-z)
7021       include 'DIMENSIONS'
7022       include 'DIMENSIONS.ZSCOPT'
7023       include 'COMMON.IOUNITS'
7024       include 'COMMON.CHAIN'
7025       include 'COMMON.DERIV'
7026       include 'COMMON.INTERACT'
7027       include 'COMMON.CONTACTS'
7028       include 'COMMON.TORSION'
7029       include 'COMMON.VAR'
7030       include 'COMMON.GEO'
7031       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7032       logical swap
7033       logical lprn
7034       common /kutas/ lprn
7035 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7036 C                                                                              C
7037 C      Parallel       Antiparallel                                             C
7038 C                                                                              C
7039 C          o             o                                                     C
7040 C         /l\           /j\                                                    C
7041 C        /   \         /   \                                                   C
7042 C       /| o |         | o |\                                                  C
7043 C     \ j|/k\|  /   \  |/k\|l /                                                C
7044 C      \ /   \ /     \ /   \ /                                                 C
7045 C       o     o       o     o                                                  C
7046 C       i             i                                                        C
7047 C                                                                              C
7048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7049       itk=itortyp(itype(k))
7050       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7051       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7052       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7053       call transpose2(EUgC(1,1,k),auxmat(1,1))
7054       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7055       vv1(1)=pizda1(1,1)-pizda1(2,2)
7056       vv1(2)=pizda1(1,2)+pizda1(2,1)
7057       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7058       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7059       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7060       s5=scalar2(vv(1),Dtobr2(1,i))
7061 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7062       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7063       if (.not. calc_grad) return
7064       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7065      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7066      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7067      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7068      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7069      & +scalar2(vv(1),Dtobr2der(1,i)))
7070       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7071       vv1(1)=pizda1(1,1)-pizda1(2,2)
7072       vv1(2)=pizda1(1,2)+pizda1(2,1)
7073       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7074       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7075       if (l.eq.j+1) then
7076         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7077      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7078      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7079      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7080      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7081       else
7082         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7083      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7084      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7085      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7086      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7087       endif
7088       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7089       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7090       vv1(1)=pizda1(1,1)-pizda1(2,2)
7091       vv1(2)=pizda1(1,2)+pizda1(2,1)
7092       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7093      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7094      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7095      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7096       do iii=1,2
7097         if (swap) then
7098           ind=3-iii
7099         else
7100           ind=iii
7101         endif
7102         do kkk=1,5
7103           do lll=1,3
7104             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7105             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7106             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7107             call transpose2(EUgC(1,1,k),auxmat(1,1))
7108             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7109      &        pizda1(1,1))
7110             vv1(1)=pizda1(1,1)-pizda1(2,2)
7111             vv1(2)=pizda1(1,2)+pizda1(2,1)
7112             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7113             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7114      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7115             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7116      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7117             s5=scalar2(vv(1),Dtobr2(1,i))
7118             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7119           enddo
7120         enddo
7121       enddo
7122       return
7123       end
7124 c----------------------------------------------------------------------------
7125       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7126       implicit real*8 (a-h,o-z)
7127       include 'DIMENSIONS'
7128       include 'DIMENSIONS.ZSCOPT'
7129       include 'COMMON.IOUNITS'
7130       include 'COMMON.CHAIN'
7131       include 'COMMON.DERIV'
7132       include 'COMMON.INTERACT'
7133       include 'COMMON.CONTACTS'
7134       include 'COMMON.TORSION'
7135       include 'COMMON.VAR'
7136       include 'COMMON.GEO'
7137       logical swap
7138       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7139      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7140       logical lprn
7141       common /kutas/ lprn
7142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7143 C                                                                              C
7144 C      Parallel       Antiparallel                                             C
7145 C                                                                              C
7146 C          o             o                                                     C
7147 C     \   /l\           /j\   /                                                C
7148 C      \ /   \         /   \ /                                                 C
7149 C       o| o |         | o |o                                                  C
7150 C     \ j|/k\|      \  |/k\|l                                                  C
7151 C      \ /   \       \ /   \                                                   C
7152 C       o             o                                                        C
7153 C       i             i                                                        C
7154 C                                                                              C
7155 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7156 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7157 C AL 7/4/01 s1 would occur in the sixth-order moment,
7158 C           but not in a cluster cumulant
7159 #ifdef MOMENT
7160       s1=dip(1,jj,i)*dip(1,kk,k)
7161 #endif
7162       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7163       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7164       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7165       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7166       call transpose2(EUg(1,1,k),auxmat(1,1))
7167       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7168       vv(1)=pizda(1,1)-pizda(2,2)
7169       vv(2)=pizda(1,2)+pizda(2,1)
7170       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7171 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7172 #ifdef MOMENT
7173       eello6_graph2=-(s1+s2+s3+s4)
7174 #else
7175       eello6_graph2=-(s2+s3+s4)
7176 #endif
7177 c      eello6_graph2=-s3
7178       if (.not. calc_grad) return
7179 C Derivatives in gamma(i-1)
7180       if (i.gt.1) then
7181 #ifdef MOMENT
7182         s1=dipderg(1,jj,i)*dip(1,kk,k)
7183 #endif
7184         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7185         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7186         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7187         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7188 #ifdef MOMENT
7189         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7190 #else
7191         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7192 #endif
7193 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7194       endif
7195 C Derivatives in gamma(k-1)
7196 #ifdef MOMENT
7197       s1=dip(1,jj,i)*dipderg(1,kk,k)
7198 #endif
7199       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7200       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7201       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7202       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7203       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7204       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7205       vv(1)=pizda(1,1)-pizda(2,2)
7206       vv(2)=pizda(1,2)+pizda(2,1)
7207       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7208 #ifdef MOMENT
7209       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7210 #else
7211       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7212 #endif
7213 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7214 C Derivatives in gamma(j-1) or gamma(l-1)
7215       if (j.gt.1) then
7216 #ifdef MOMENT
7217         s1=dipderg(3,jj,i)*dip(1,kk,k)
7218 #endif
7219         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7220         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7221         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7222         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7223         vv(1)=pizda(1,1)-pizda(2,2)
7224         vv(2)=pizda(1,2)+pizda(2,1)
7225         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7226 #ifdef MOMENT
7227         if (swap) then
7228           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7229         else
7230           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7231         endif
7232 #endif
7233         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7234 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7235       endif
7236 C Derivatives in gamma(l-1) or gamma(j-1)
7237       if (l.gt.1) then
7238 #ifdef MOMENT
7239         s1=dip(1,jj,i)*dipderg(3,kk,k)
7240 #endif
7241         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7242         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7243         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7244         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7245         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7246         vv(1)=pizda(1,1)-pizda(2,2)
7247         vv(2)=pizda(1,2)+pizda(2,1)
7248         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7249 #ifdef MOMENT
7250         if (swap) then
7251           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7252         else
7253           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7254         endif
7255 #endif
7256         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7257 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7258       endif
7259 C Cartesian derivatives.
7260       if (lprn) then
7261         write (2,*) 'In eello6_graph2'
7262         do iii=1,2
7263           write (2,*) 'iii=',iii
7264           do kkk=1,5
7265             write (2,*) 'kkk=',kkk
7266             do jjj=1,2
7267               write (2,'(3(2f10.5),5x)')
7268      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7269             enddo
7270           enddo
7271         enddo
7272       endif
7273       do iii=1,2
7274         do kkk=1,5
7275           do lll=1,3
7276 #ifdef MOMENT
7277             if (iii.eq.1) then
7278               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7279             else
7280               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7281             endif
7282 #endif
7283             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7284      &        auxvec(1))
7285             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7286             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7287      &        auxvec(1))
7288             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7289             call transpose2(EUg(1,1,k),auxmat(1,1))
7290             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7291      &        pizda(1,1))
7292             vv(1)=pizda(1,1)-pizda(2,2)
7293             vv(2)=pizda(1,2)+pizda(2,1)
7294             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7295 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7296 #ifdef MOMENT
7297             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7298 #else
7299             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7300 #endif
7301             if (swap) then
7302               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7303             else
7304               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7305             endif
7306           enddo
7307         enddo
7308       enddo
7309       return
7310       end
7311 c----------------------------------------------------------------------------
7312       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7313       implicit real*8 (a-h,o-z)
7314       include 'DIMENSIONS'
7315       include 'DIMENSIONS.ZSCOPT'
7316       include 'COMMON.IOUNITS'
7317       include 'COMMON.CHAIN'
7318       include 'COMMON.DERIV'
7319       include 'COMMON.INTERACT'
7320       include 'COMMON.CONTACTS'
7321       include 'COMMON.TORSION'
7322       include 'COMMON.VAR'
7323       include 'COMMON.GEO'
7324       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7325       logical swap
7326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7327 C                                                                              C
7328 C      Parallel       Antiparallel                                             C
7329 C                                                                              C
7330 C          o             o                                                     C
7331 C         /l\   /   \   /j\                                                    C
7332 C        /   \ /     \ /   \                                                   C
7333 C       /| o |o       o| o |\                                                  C
7334 C       j|/k\|  /      |/k\|l /                                                C
7335 C        /   \ /       /   \ /                                                 C
7336 C       /     o       /     o                                                  C
7337 C       i             i                                                        C
7338 C                                                                              C
7339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7340 C
7341 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7342 C           energy moment and not to the cluster cumulant.
7343       iti=itortyp(itype(i))
7344       if (j.lt.nres-1) then
7345         itj1=itortyp(itype(j+1))
7346       else
7347         itj1=ntortyp+1
7348       endif
7349       itk=itortyp(itype(k))
7350       itk1=itortyp(itype(k+1))
7351       if (l.lt.nres-1) then
7352         itl1=itortyp(itype(l+1))
7353       else
7354         itl1=ntortyp+1
7355       endif
7356 #ifdef MOMENT
7357       s1=dip(4,jj,i)*dip(4,kk,k)
7358 #endif
7359       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7360       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7361       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7362       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7363       call transpose2(EE(1,1,itk),auxmat(1,1))
7364       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7365       vv(1)=pizda(1,1)+pizda(2,2)
7366       vv(2)=pizda(2,1)-pizda(1,2)
7367       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7368 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7369 #ifdef MOMENT
7370       eello6_graph3=-(s1+s2+s3+s4)
7371 #else
7372       eello6_graph3=-(s2+s3+s4)
7373 #endif
7374 c      eello6_graph3=-s4
7375       if (.not. calc_grad) return
7376 C Derivatives in gamma(k-1)
7377       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7378       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7379       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7380       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7381 C Derivatives in gamma(l-1)
7382       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7383       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7384       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7385       vv(1)=pizda(1,1)+pizda(2,2)
7386       vv(2)=pizda(2,1)-pizda(1,2)
7387       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7388       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7389 C Cartesian derivatives.
7390       do iii=1,2
7391         do kkk=1,5
7392           do lll=1,3
7393 #ifdef MOMENT
7394             if (iii.eq.1) then
7395               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7396             else
7397               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7398             endif
7399 #endif
7400             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7401      &        auxvec(1))
7402             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7403             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7404      &        auxvec(1))
7405             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7406             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7407      &        pizda(1,1))
7408             vv(1)=pizda(1,1)+pizda(2,2)
7409             vv(2)=pizda(2,1)-pizda(1,2)
7410             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7411 #ifdef MOMENT
7412             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7413 #else
7414             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7415 #endif
7416             if (swap) then
7417               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7418             else
7419               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7420             endif
7421 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7422           enddo
7423         enddo
7424       enddo
7425       return
7426       end
7427 c----------------------------------------------------------------------------
7428       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7429       implicit real*8 (a-h,o-z)
7430       include 'DIMENSIONS'
7431       include 'DIMENSIONS.ZSCOPT'
7432       include 'COMMON.IOUNITS'
7433       include 'COMMON.CHAIN'
7434       include 'COMMON.DERIV'
7435       include 'COMMON.INTERACT'
7436       include 'COMMON.CONTACTS'
7437       include 'COMMON.TORSION'
7438       include 'COMMON.VAR'
7439       include 'COMMON.GEO'
7440       include 'COMMON.FFIELD'
7441       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7442      & auxvec1(2),auxmat1(2,2)
7443       logical swap
7444 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7445 C                                                                              C
7446 C      Parallel       Antiparallel                                             C
7447 C                                                                              C
7448 C          o             o                                                     C
7449 C         /l\   /   \   /j\                                                    C
7450 C        /   \ /     \ /   \                                                   C
7451 C       /| o |o       o| o |\                                                  C
7452 C     \ j|/k\|      \  |/k\|l                                                  C
7453 C      \ /   \       \ /   \                                                   C
7454 C       o     \       o     \                                                  C
7455 C       i             i                                                        C
7456 C                                                                              C
7457 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7458 C
7459 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7460 C           energy moment and not to the cluster cumulant.
7461 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7462       iti=itortyp(itype(i))
7463       itj=itortyp(itype(j))
7464       if (j.lt.nres-1) then
7465         itj1=itortyp(itype(j+1))
7466       else
7467         itj1=ntortyp+1
7468       endif
7469       itk=itortyp(itype(k))
7470       if (k.lt.nres-1) then
7471         itk1=itortyp(itype(k+1))
7472       else
7473         itk1=ntortyp+1
7474       endif
7475       itl=itortyp(itype(l))
7476       if (l.lt.nres-1) then
7477         itl1=itortyp(itype(l+1))
7478       else
7479         itl1=ntortyp+1
7480       endif
7481 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7482 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7483 cd     & ' itl',itl,' itl1',itl1
7484 #ifdef MOMENT
7485       if (imat.eq.1) then
7486         s1=dip(3,jj,i)*dip(3,kk,k)
7487       else
7488         s1=dip(2,jj,j)*dip(2,kk,l)
7489       endif
7490 #endif
7491       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7492       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7493       if (j.eq.l+1) then
7494         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7495         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7496       else
7497         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7498         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7499       endif
7500       call transpose2(EUg(1,1,k),auxmat(1,1))
7501       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7502       vv(1)=pizda(1,1)-pizda(2,2)
7503       vv(2)=pizda(2,1)+pizda(1,2)
7504       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7505 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7506 #ifdef MOMENT
7507       eello6_graph4=-(s1+s2+s3+s4)
7508 #else
7509       eello6_graph4=-(s2+s3+s4)
7510 #endif
7511       if (.not. calc_grad) return
7512 C Derivatives in gamma(i-1)
7513       if (i.gt.1) then
7514 #ifdef MOMENT
7515         if (imat.eq.1) then
7516           s1=dipderg(2,jj,i)*dip(3,kk,k)
7517         else
7518           s1=dipderg(4,jj,j)*dip(2,kk,l)
7519         endif
7520 #endif
7521         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7522         if (j.eq.l+1) then
7523           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7524           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7525         else
7526           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7527           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7528         endif
7529         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7530         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7531 cd          write (2,*) 'turn6 derivatives'
7532 #ifdef MOMENT
7533           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7534 #else
7535           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7536 #endif
7537         else
7538 #ifdef MOMENT
7539           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7540 #else
7541           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7542 #endif
7543         endif
7544       endif
7545 C Derivatives in gamma(k-1)
7546 #ifdef MOMENT
7547       if (imat.eq.1) then
7548         s1=dip(3,jj,i)*dipderg(2,kk,k)
7549       else
7550         s1=dip(2,jj,j)*dipderg(4,kk,l)
7551       endif
7552 #endif
7553       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7554       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7555       if (j.eq.l+1) then
7556         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7557         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7558       else
7559         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7560         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7561       endif
7562       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7563       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7564       vv(1)=pizda(1,1)-pizda(2,2)
7565       vv(2)=pizda(2,1)+pizda(1,2)
7566       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7567       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7568 #ifdef MOMENT
7569         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7570 #else
7571         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7572 #endif
7573       else
7574 #ifdef MOMENT
7575         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7576 #else
7577         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7578 #endif
7579       endif
7580 C Derivatives in gamma(j-1) or gamma(l-1)
7581       if (l.eq.j+1 .and. l.gt.1) then
7582         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7583         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7584         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7585         vv(1)=pizda(1,1)-pizda(2,2)
7586         vv(2)=pizda(2,1)+pizda(1,2)
7587         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7588         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7589       else if (j.gt.1) then
7590         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7591         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7592         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7593         vv(1)=pizda(1,1)-pizda(2,2)
7594         vv(2)=pizda(2,1)+pizda(1,2)
7595         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7596         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7597           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7598         else
7599           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7600         endif
7601       endif
7602 C Cartesian derivatives.
7603       do iii=1,2
7604         do kkk=1,5
7605           do lll=1,3
7606 #ifdef MOMENT
7607             if (iii.eq.1) then
7608               if (imat.eq.1) then
7609                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7610               else
7611                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7612               endif
7613             else
7614               if (imat.eq.1) then
7615                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7616               else
7617                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7618               endif
7619             endif
7620 #endif
7621             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7622      &        auxvec(1))
7623             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7624             if (j.eq.l+1) then
7625               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7626      &          b1(1,itj1),auxvec(1))
7627               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7628             else
7629               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7630      &          b1(1,itl1),auxvec(1))
7631               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7632             endif
7633             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7634      &        pizda(1,1))
7635             vv(1)=pizda(1,1)-pizda(2,2)
7636             vv(2)=pizda(2,1)+pizda(1,2)
7637             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7638             if (swap) then
7639               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7640 #ifdef MOMENT
7641                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7642      &             -(s1+s2+s4)
7643 #else
7644                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7645      &             -(s2+s4)
7646 #endif
7647                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7648               else
7649 #ifdef MOMENT
7650                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7651 #else
7652                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7653 #endif
7654                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7655               endif
7656             else
7657 #ifdef MOMENT
7658               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7659 #else
7660               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7661 #endif
7662               if (l.eq.j+1) then
7663                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7664               else
7665                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7666               endif
7667             endif
7668           enddo
7669         enddo
7670       enddo
7671       return
7672       end
7673 c----------------------------------------------------------------------------
7674       double precision function eello_turn6(i,jj,kk)
7675       implicit real*8 (a-h,o-z)
7676       include 'DIMENSIONS'
7677       include 'DIMENSIONS.ZSCOPT'
7678       include 'COMMON.IOUNITS'
7679       include 'COMMON.CHAIN'
7680       include 'COMMON.DERIV'
7681       include 'COMMON.INTERACT'
7682       include 'COMMON.CONTACTS'
7683       include 'COMMON.TORSION'
7684       include 'COMMON.VAR'
7685       include 'COMMON.GEO'
7686       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7687      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7688      &  ggg1(3),ggg2(3)
7689       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7690      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7691 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7692 C           the respective energy moment and not to the cluster cumulant.
7693       eello_turn6=0.0d0
7694       j=i+4
7695       k=i+1
7696       l=i+3
7697       iti=itortyp(itype(i))
7698       itk=itortyp(itype(k))
7699       itk1=itortyp(itype(k+1))
7700       itl=itortyp(itype(l))
7701       itj=itortyp(itype(j))
7702 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7703 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7704 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7705 cd        eello6=0.0d0
7706 cd        return
7707 cd      endif
7708 cd      write (iout,*)
7709 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7710 cd     &   ' and',k,l
7711 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7712       do iii=1,2
7713         do kkk=1,5
7714           do lll=1,3
7715             derx_turn(lll,kkk,iii)=0.0d0
7716           enddo
7717         enddo
7718       enddo
7719 cd      eij=1.0d0
7720 cd      ekl=1.0d0
7721 cd      ekont=1.0d0
7722       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7723 cd      eello6_5=0.0d0
7724 cd      write (2,*) 'eello6_5',eello6_5
7725 #ifdef MOMENT
7726       call transpose2(AEA(1,1,1),auxmat(1,1))
7727       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7728       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7729       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7730 #else
7731       s1 = 0.0d0
7732 #endif
7733       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7734       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7735       s2 = scalar2(b1(1,itk),vtemp1(1))
7736 #ifdef MOMENT
7737       call transpose2(AEA(1,1,2),atemp(1,1))
7738       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7739       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7740       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7741 #else
7742       s8=0.0d0
7743 #endif
7744       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7745       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7746       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7747 #ifdef MOMENT
7748       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7749       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7750       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7751       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7752       ss13 = scalar2(b1(1,itk),vtemp4(1))
7753       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7754 #else
7755       s13=0.0d0
7756 #endif
7757 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7758 c      s1=0.0d0
7759 c      s2=0.0d0
7760 c      s8=0.0d0
7761 c      s12=0.0d0
7762 c      s13=0.0d0
7763       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7764       if (calc_grad) then
7765 C Derivatives in gamma(i+2)
7766 #ifdef MOMENT
7767       call transpose2(AEA(1,1,1),auxmatd(1,1))
7768       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7769       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7770       call transpose2(AEAderg(1,1,2),atempd(1,1))
7771       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7772       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7773 #else
7774       s8d=0.0d0
7775 #endif
7776       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7777       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7778       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7779 c      s1d=0.0d0
7780 c      s2d=0.0d0
7781 c      s8d=0.0d0
7782 c      s12d=0.0d0
7783 c      s13d=0.0d0
7784       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7785 C Derivatives in gamma(i+3)
7786 #ifdef MOMENT
7787       call transpose2(AEA(1,1,1),auxmatd(1,1))
7788       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7789       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7790       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7791 #else
7792       s1d=0.0d0
7793 #endif
7794       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7795       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7796       s2d = scalar2(b1(1,itk),vtemp1d(1))
7797 #ifdef MOMENT
7798       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7799       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7800 #endif
7801       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7802 #ifdef MOMENT
7803       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7804       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7805       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7806 #else
7807       s13d=0.0d0
7808 #endif
7809 c      s1d=0.0d0
7810 c      s2d=0.0d0
7811 c      s8d=0.0d0
7812 c      s12d=0.0d0
7813 c      s13d=0.0d0
7814 #ifdef MOMENT
7815       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7816      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7817 #else
7818       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7819      &               -0.5d0*ekont*(s2d+s12d)
7820 #endif
7821 C Derivatives in gamma(i+4)
7822       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7823       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7824       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7825 #ifdef MOMENT
7826       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7827       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7828       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7829 #else
7830       s13d = 0.0d0
7831 #endif
7832 c      s1d=0.0d0
7833 c      s2d=0.0d0
7834 c      s8d=0.0d0
7835 C      s12d=0.0d0
7836 c      s13d=0.0d0
7837 #ifdef MOMENT
7838       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7839 #else
7840       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7841 #endif
7842 C Derivatives in gamma(i+5)
7843 #ifdef MOMENT
7844       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7845       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7846       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7847 #else
7848       s1d = 0.0d0
7849 #endif
7850       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7851       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7852       s2d = scalar2(b1(1,itk),vtemp1d(1))
7853 #ifdef MOMENT
7854       call transpose2(AEA(1,1,2),atempd(1,1))
7855       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7856       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7857 #else
7858       s8d = 0.0d0
7859 #endif
7860       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7861       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7862 #ifdef MOMENT
7863       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7864       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7865       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7866 #else
7867       s13d = 0.0d0
7868 #endif
7869 c      s1d=0.0d0
7870 c      s2d=0.0d0
7871 c      s8d=0.0d0
7872 c      s12d=0.0d0
7873 c      s13d=0.0d0
7874 #ifdef MOMENT
7875       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7876      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7877 #else
7878       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7879      &               -0.5d0*ekont*(s2d+s12d)
7880 #endif
7881 C Cartesian derivatives
7882       do iii=1,2
7883         do kkk=1,5
7884           do lll=1,3
7885 #ifdef MOMENT
7886             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7887             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7888             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7889 #else
7890             s1d = 0.0d0
7891 #endif
7892             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7893             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7894      &          vtemp1d(1))
7895             s2d = scalar2(b1(1,itk),vtemp1d(1))
7896 #ifdef MOMENT
7897             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7898             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7899             s8d = -(atempd(1,1)+atempd(2,2))*
7900      &           scalar2(cc(1,1,itl),vtemp2(1))
7901 #else
7902             s8d = 0.0d0
7903 #endif
7904             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7905      &           auxmatd(1,1))
7906             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7907             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7908 c      s1d=0.0d0
7909 c      s2d=0.0d0
7910 c      s8d=0.0d0
7911 c      s12d=0.0d0
7912 c      s13d=0.0d0
7913 #ifdef MOMENT
7914             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7915      &        - 0.5d0*(s1d+s2d)
7916 #else
7917             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7918      &        - 0.5d0*s2d
7919 #endif
7920 #ifdef MOMENT
7921             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7922      &        - 0.5d0*(s8d+s12d)
7923 #else
7924             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7925      &        - 0.5d0*s12d
7926 #endif
7927           enddo
7928         enddo
7929       enddo
7930 #ifdef MOMENT
7931       do kkk=1,5
7932         do lll=1,3
7933           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7934      &      achuj_tempd(1,1))
7935           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7936           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7937           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7938           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7939           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7940      &      vtemp4d(1))
7941           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7942           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7943           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7944         enddo
7945       enddo
7946 #endif
7947 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7948 cd     &  16*eel_turn6_num
7949 cd      goto 1112
7950       if (j.lt.nres-1) then
7951         j1=j+1
7952         j2=j-1
7953       else
7954         j1=j-1
7955         j2=j-2
7956       endif
7957       if (l.lt.nres-1) then
7958         l1=l+1
7959         l2=l-1
7960       else
7961         l1=l-1
7962         l2=l-2
7963       endif
7964       do ll=1,3
7965         ggg1(ll)=eel_turn6*g_contij(ll,1)
7966         ggg2(ll)=eel_turn6*g_contij(ll,2)
7967         ghalf=0.5d0*ggg1(ll)
7968 cd        ghalf=0.0d0
7969         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7970      &    +ekont*derx_turn(ll,2,1)
7971         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7972         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7973      &    +ekont*derx_turn(ll,4,1)
7974         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7975         ghalf=0.5d0*ggg2(ll)
7976 cd        ghalf=0.0d0
7977         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7978      &    +ekont*derx_turn(ll,2,2)
7979         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7980         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7981      &    +ekont*derx_turn(ll,4,2)
7982         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7983       enddo
7984 cd      goto 1112
7985       do m=i+1,j-1
7986         do ll=1,3
7987           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7988         enddo
7989       enddo
7990       do m=k+1,l-1
7991         do ll=1,3
7992           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7993         enddo
7994       enddo
7995 1112  continue
7996       do m=i+2,j2
7997         do ll=1,3
7998           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7999         enddo
8000       enddo
8001       do m=k+2,l2
8002         do ll=1,3
8003           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8004         enddo
8005       enddo
8006 cd      do iii=1,nres-3
8007 cd        write (2,*) iii,g_corr6_loc(iii)
8008 cd      enddo
8009       endif
8010       eello_turn6=ekont*eel_turn6
8011 cd      write (2,*) 'ekont',ekont
8012 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8013       return
8014       end
8015 crc-------------------------------------------------
8016       SUBROUTINE MATVEC2(A1,V1,V2)
8017       implicit real*8 (a-h,o-z)
8018       include 'DIMENSIONS'
8019       DIMENSION A1(2,2),V1(2),V2(2)
8020 c      DO 1 I=1,2
8021 c        VI=0.0
8022 c        DO 3 K=1,2
8023 c    3     VI=VI+A1(I,K)*V1(K)
8024 c        Vaux(I)=VI
8025 c    1 CONTINUE
8026
8027       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8028       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8029
8030       v2(1)=vaux1
8031       v2(2)=vaux2
8032       END
8033 C---------------------------------------
8034       SUBROUTINE MATMAT2(A1,A2,A3)
8035       implicit real*8 (a-h,o-z)
8036       include 'DIMENSIONS'
8037       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8038 c      DIMENSION AI3(2,2)
8039 c        DO  J=1,2
8040 c          A3IJ=0.0
8041 c          DO K=1,2
8042 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8043 c          enddo
8044 c          A3(I,J)=A3IJ
8045 c       enddo
8046 c      enddo
8047
8048       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8049       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8050       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8051       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8052
8053       A3(1,1)=AI3_11
8054       A3(2,1)=AI3_21
8055       A3(1,2)=AI3_12
8056       A3(2,2)=AI3_22
8057       END
8058
8059 c-------------------------------------------------------------------------
8060       double precision function scalar2(u,v)
8061       implicit none
8062       double precision u(2),v(2)
8063       double precision sc
8064       integer i
8065       scalar2=u(1)*v(1)+u(2)*v(2)
8066       return
8067       end
8068
8069 C-----------------------------------------------------------------------------
8070
8071       subroutine transpose2(a,at)
8072       implicit none
8073       double precision a(2,2),at(2,2)
8074       at(1,1)=a(1,1)
8075       at(1,2)=a(2,1)
8076       at(2,1)=a(1,2)
8077       at(2,2)=a(2,2)
8078       return
8079       end
8080 c--------------------------------------------------------------------------
8081       subroutine transpose(n,a,at)
8082       implicit none
8083       integer n,i,j
8084       double precision a(n,n),at(n,n)
8085       do i=1,n
8086         do j=1,n
8087           at(j,i)=a(i,j)
8088         enddo
8089       enddo
8090       return
8091       end
8092 C---------------------------------------------------------------------------
8093       subroutine prodmat3(a1,a2,kk,transp,prod)
8094       implicit none
8095       integer i,j
8096       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8097       logical transp
8098 crc      double precision auxmat(2,2),prod_(2,2)
8099
8100       if (transp) then
8101 crc        call transpose2(kk(1,1),auxmat(1,1))
8102 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8103 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8104
8105            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8106      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8107            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8108      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8109            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8110      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8111            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8112      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8113
8114       else
8115 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8116 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8117
8118            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8119      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8120            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8121      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8122            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8123      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8124            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8125      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8126
8127       endif
8128 c      call transpose2(a2(1,1),a2t(1,1))
8129
8130 crc      print *,transp
8131 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8132 crc      print *,((prod(i,j),i=1,2),j=1,2)
8133
8134       return
8135       end
8136 C-----------------------------------------------------------------------------
8137       double precision function scalar(u,v)
8138       implicit none
8139       double precision u(3),v(3)
8140       double precision sc
8141       integer i
8142       sc=0.0d0
8143       do i=1,3
8144         sc=sc+u(i)*v(i)
8145       enddo
8146       scalar=sc
8147       return
8148       end
8149