source/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       endif
 104       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 105          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 106       endif
 107
 108
 109 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 110       if (constr_homology.ge.1) then
 111         call e_modeller(ehomology_constr)
 112       else
 113         ehomology_constr=0.0d0
 114       endif
 115
 116 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 117
 118 C     BARTEK for dfa test!
 119       if (wdfa_dist.gt.0) call edfad(edfadis)
 120 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 121       if (wdfa_tor.gt.0) call edfat(edfator)
 122 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 123       if (wdfa_nei.gt.0) call edfan(edfanei)
 124 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 125       if (wdfa_beta.gt.0) call edfab(edfabet)
 126 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 127
 128 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 129 #ifdef SPLITELE
 130       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 131      & +wvdwpp*evdw1
 132      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 133      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 134      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 135      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 136      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 137      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 138      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 139      & +wdfa_beta*edfabet
 140 #else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 142      & +welec*fact(1)*(ees+evdw1)
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 149      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 150      & +wdfa_beta*edfabet
 151 #endif
 152       energia(0)=etot
 153       energia(1)=evdw
 154 #ifdef SCP14
 155       energia(2)=evdw2-evdw2_14
 156       energia(17)=evdw2_14
 157 #else
 158       energia(2)=evdw2
 159       energia(17)=0.0d0
 160 #endif
 161 #ifdef SPLITELE
 162       energia(3)=ees
 163       energia(16)=evdw1
 164 #else
 165       energia(3)=ees+evdw1
 166       energia(16)=0.0d0
 167 #endif
 168       energia(4)=ecorr
 169       energia(5)=ecorr5
 170       energia(6)=ecorr6
 171       energia(7)=eel_loc
 172       energia(8)=eello_turn3
 173       energia(9)=eello_turn4
 174       energia(10)=eturn6
 175       energia(11)=ebe
 176       energia(12)=escloc
 177       energia(13)=etors
 178       energia(14)=etors_d
 179       energia(15)=ehpb
 180       energia(18)=estr
 181       energia(19)=esccor
 182       energia(20)=edihcnstr
 183       energia(21)=evdw_t
 184       energia(22)=ehomology_constr
 185       energia(23)=edfadis
 186       energia(24)=edfator
 187       energia(25)=edfanei
 188       energia(26)=edfabet
 189 c      if (dyn_ss) call dyn_set_nss
 190 c detecting NaNQ
 191 #ifdef ISNAN
 192 #ifdef AIX
 193       if (isnan(etot).ne.0) energia(0)=1.0d+99
 194 #else
 195       if (isnan(etot)) energia(0)=1.0d+99
 196 #endif
 197 #else
 198       i=0
 199 #ifdef WINPGI
 200       idumm=proc_proc(etot,i)
 201 #else
 202       call proc_proc(etot,i)
 203 #endif
 204       if(i.eq.1)energia(0)=1.0d+99
 205 #endif
 206 #ifdef MPL
 207 c     endif
 208 #endif
 209       if (calc_grad) then
 210 C
 211 C Sum up the components of the Cartesian gradient.
 212 C
 213 #ifdef SPLITELE
 214       do i=1,nct
 215         do j=1,3
 216           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 217      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 218      &                wbond*gradb(j,i)+
 219      &                wstrain*ghpbc(j,i)+
 220      &                wcorr*fact(3)*gradcorr(j,i)+
 221      &                wel_loc*fact(2)*gel_loc(j,i)+
 222      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 223      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 224      &                wcorr5*fact(4)*gradcorr5(j,i)+
 225      &                wcorr6*fact(5)*gradcorr6(j,i)+
 226      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 227      &                wsccor*fact(2)*gsccorc(j,i)+
 228      &                wdfa_dist*gdfad(j,i)+
 229      &                wdfa_tor*gdfat(j,i)+
 230      &                wdfa_nei*gdfan(j,i)+
 231      &                wdfa_beta*gdfab(j,i)
 232           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 233      &                  wbond*gradbx(j,i)+
 234      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 235      &                  wsccor*fact(2)*gsccorx(j,i)
 236         enddo
 237 #else
 238       do i=1,nct
 239         do j=1,3
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wcorr*fact(3)*gradcorr(j,i)+
 244      &                wel_loc*fact(2)*gel_loc(j,i)+
 245      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 246      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 247      &                wcorr5*fact(4)*gradcorr5(j,i)+
 248      &                wcorr6*fact(5)*gradcorr6(j,i)+
 249      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 250      &                wsccor*fact(2)*gsccorc(j,i)+
 251      &                wdfa_dist*gdfad(j,i)+
 252      &                wdfa_tor*gdfat(j,i)+
 253      &                wdfa_nei*gdfan(j,i)+
 254      &                wdfa_beta*gdfab(j,i)
 255           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 256      &                  wbond*gradbx(j,i)+
 257      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 258      &                  wsccor*fact(1)*gsccorx(j,i)
 259         enddo
 260 #endif
 261       enddo
 262
 263
 264       do i=1,nres-3
 265         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 266      &   +wcorr5*fact(4)*g_corr5_loc(i)
 267      &   +wcorr6*fact(5)*g_corr6_loc(i)
 268      &   +wturn4*fact(3)*gel_loc_turn4(i)
 269      &   +wturn3*fact(2)*gel_loc_turn3(i)
 270      &   +wturn6*fact(5)*gel_loc_turn6(i)
 271      &   +wel_loc*fact(2)*gel_loc_loc(i)
 272      &   +wsccor*fact(1)*gsccor_loc(i)
 273       enddo
 274       endif
 275       return
 276       end
 277 C------------------------------------------------------------------------
 278       subroutine enerprint(energia,fact)
 279       implicit real*8 (a-h,o-z)
 280       include 'DIMENSIONS'
 281       include 'DIMENSIONS.ZSCOPT'
 282       include 'COMMON.IOUNITS'
 283       include 'COMMON.FFIELD'
 284       include 'COMMON.SBRIDGE'
 285       double precision energia(0:max_ene),fact(6)
 286       etot=energia(0)
 287       evdw=energia(1)+fact(6)*energia(21)
 288 #ifdef SCP14
 289       evdw2=energia(2)+energia(17)
 290 #else
 291       evdw2=energia(2)
 292 #endif
 293       ees=energia(3)
 294 #ifdef SPLITELE
 295       evdw1=energia(16)
 296 #endif
 297       ecorr=energia(4)
 298       ecorr5=energia(5)
 299       ecorr6=energia(6)
 300       eel_loc=energia(7)
 301       eello_turn3=energia(8)
 302       eello_turn4=energia(9)
 303       eello_turn6=energia(10)
 304       ebe=energia(11)
 305       escloc=energia(12)
 306       etors=energia(13)
 307       etors_d=energia(14)
 308       ehpb=energia(15)
 309       esccor=energia(19)
 310       edihcnstr=energia(20)
 311       estr=energia(18)
 312       ehomology_constr=energia(22)
 313       edfadis=energia(23)
 314       edfator=energia(24)
 315       edfanei=energia(25)
 316       edfabet=energia(26)
 317 #ifdef SPLITELE
 318       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 319      &  wvdwpp,
 320      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 321      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 322      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 323      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 324      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 325      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 326      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 327      &  wdfa_beta,etot
 328    10 format (/'Virtual-chain energies:'//
 329      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 330      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 331      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 332      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 333      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 334      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 335      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 336      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 337      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 338      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 339      & ' (SS bridges & dist. cnstr.)'/
 340      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 343      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 344      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 345      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 346      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 347      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 348      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 349      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 350      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 351      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 352      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 353      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 354      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 355      & 'ETOT=  ',1pE16.6,' (total)')
 356 #else
 357       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 358      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 359      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 360      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 361      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 362      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 363      &  edihcnstr,ehomology_constr,ebr*nss,
 364      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 365      &  wdfa_beta,etot
 366    10 format (/'Virtual-chain energies:'//
 367      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 368      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 369      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 370      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 371      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 372      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 373      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 374      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 375      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 376      & ' (SS bridges & dist. cnstr.)'/
 377      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 380      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 381      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 382      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 383      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 384      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 385      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 386      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 387      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 388      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 389      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 390      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 391      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 392      & 'ETOT=  ',1pE16.6,' (total)')
 393 #endif
 394       return
 395       end
 396 C-----------------------------------------------------------------------
 397       subroutine elj(evdw,evdw_t)
 398 C
 399 C This subroutine calculates the interaction energy of nonbonded side chains
 400 C assuming the LJ potential of interaction.
 401 C
 402       implicit real*8 (a-h,o-z)
 403       include 'DIMENSIONS'
 404       include 'DIMENSIONS.ZSCOPT'
 405       include "DIMENSIONS.COMPAR"
 406       parameter (accur=1.0d-10)
 407       include 'COMMON.GEO'
 408       include 'COMMON.VAR'
 409       include 'COMMON.LOCAL'
 410       include 'COMMON.CHAIN'
 411       include 'COMMON.DERIV'
 412       include 'COMMON.INTERACT'
 413       include 'COMMON.TORSION'
 414       include 'COMMON.ENEPS'
 415       include 'COMMON.SBRIDGE'
 416       include 'COMMON.NAMES'
 417       include 'COMMON.IOUNITS'
 418       include 'COMMON.CONTACTS'
 419       dimension gg(3)
 420       integer icant
 421       external icant
 422 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 423       do i=1,210
 424         do j=1,2
 425           eneps_temp(j,i)=0.0d0
 426         enddo
 427       enddo
 428       evdw=0.0D0
 429       evdw_t=0.0d0
 430       do i=iatsc_s,iatsc_e
 431         itypi=itype(i)
 432         itypi1=itype(i+1)
 433         xi=c(1,nres+i)
 434         yi=c(2,nres+i)
 435         zi=c(3,nres+i)
 436 C Change 12/1/95
 437         num_conti=0
 438 C
 439 C Calculate SC interaction energy.
 440 C
 441         do iint=1,nint_gr(i)
 442 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 443 cd   &                  'iend=',iend(i,iint)
 444           do j=istart(i,iint),iend(i,iint)
 445             itypj=itype(j)
 446             xj=c(1,nres+j)-xi
 447             yj=c(2,nres+j)-yi
 448             zj=c(3,nres+j)-zi
 449 C Change 12/1/95 to calculate four-body interactions
 450             rij=xj*xj+yj*yj+zj*zj
 451             rrij=1.0D0/rij
 452 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 453             eps0ij=eps(itypi,itypj)
 454             fac=rrij**expon2
 455             e1=fac*fac*aa(itypi,itypj)
 456             e2=fac*bb(itypi,itypj)
 457             evdwij=e1+e2
 458             ij=icant(itypi,itypj)
 459             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 460             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 461 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 462 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 463 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 464 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 465 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 466 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 467             if (bb(itypi,itypj).gt.0.0d0) then
 468               evdw=evdw+evdwij
 469             else
 470               evdw_t=evdw_t+evdwij
 471             endif
 472             if (calc_grad) then
 473 C
 474 C Calculate the components of the gradient in DC and X
 475 C
 476             fac=-rrij*(e1+evdwij)
 477             gg(1)=xj*fac
 478             gg(2)=yj*fac
 479             gg(3)=zj*fac
 480             do k=1,3
 481               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 482               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 483             enddo
 484             do k=i,j-1
 485               do l=1,3
 486                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 487               enddo
 488             enddo
 489             endif
 490 C
 491 C 12/1/95, revised on 5/20/97
 492 C
 493 C Calculate the contact function. The ith column of the array JCONT will
 494 C contain the numbers of atoms that make contacts with the atom I (of numbers
 495 C greater than I). The arrays FACONT and GACONT will contain the values of
 496 C the contact function and its derivative.
 497 C
 498 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 499 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 500 C Uncomment next line, if the correlation interactions are contact function only
 501             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 502               rij=dsqrt(rij)
 503               sigij=sigma(itypi,itypj)
 504               r0ij=rs0(itypi,itypj)
 505 C
 506 C Check whether the SC's are not too far to make a contact.
 507 C
 508               rcut=1.5d0*r0ij
 509               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 510 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 511 C
 512               if (fcont.gt.0.0D0) then
 513 C If the SC-SC distance if close to sigma, apply spline.
 514 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 515 cAdam &             fcont1,fprimcont1)
 516 cAdam           fcont1=1.0d0-fcont1
 517 cAdam           if (fcont1.gt.0.0d0) then
 518 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 519 cAdam             fcont=fcont*fcont1
 520 cAdam           endif
 521 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 522 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 523 cga             do k=1,3
 524 cga               gg(k)=gg(k)*eps0ij
 525 cga             enddo
 526 cga             eps0ij=-evdwij*eps0ij
 527 C Uncomment for AL's type of SC correlation interactions.
 528 cadam           eps0ij=-evdwij
 529                 num_conti=num_conti+1
 530                 jcont(num_conti,i)=j
 531                 facont(num_conti,i)=fcont*eps0ij
 532                 fprimcont=eps0ij*fprimcont/rij
 533                 fcont=expon*fcont
 534 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 535 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 536 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 537 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 538                 gacont(1,num_conti,i)=-fprimcont*xj
 539                 gacont(2,num_conti,i)=-fprimcont*yj
 540                 gacont(3,num_conti,i)=-fprimcont*zj
 541 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 542 cd              write (iout,'(2i3,3f10.5)')
 543 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 544               endif
 545             endif
 546           enddo      ! j
 547         enddo        ! iint
 548 C Change 12/1/95
 549         num_cont(i)=num_conti
 550       enddo          ! i
 551       if (calc_grad) then
 552       do i=1,nct
 553         do j=1,3
 554           gvdwc(j,i)=expon*gvdwc(j,i)
 555           gvdwx(j,i)=expon*gvdwx(j,i)
 556         enddo
 557       enddo
 558       endif
 559 C******************************************************************************
 560 C
 561 C                              N O T E !!!
 562 C
 563 C To save time, the factor of EXPON has been extracted from ALL components
 564 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 565 C use!
 566 C
 567 C******************************************************************************
 568       return
 569       end
 570 C-----------------------------------------------------------------------------
 571       subroutine eljk(evdw,evdw_t)
 572 C
 573 C This subroutine calculates the interaction energy of nonbonded side chains
 574 C assuming the LJK potential of interaction.
 575 C
 576       implicit real*8 (a-h,o-z)
 577       include 'DIMENSIONS'
 578       include 'DIMENSIONS.ZSCOPT'
 579       include "DIMENSIONS.COMPAR"
 580       include 'COMMON.GEO'
 581       include 'COMMON.VAR'
 582       include 'COMMON.LOCAL'
 583       include 'COMMON.CHAIN'
 584       include 'COMMON.DERIV'
 585       include 'COMMON.INTERACT'
 586       include 'COMMON.ENEPS'
 587       include 'COMMON.IOUNITS'
 588       include 'COMMON.NAMES'
 589       dimension gg(3)
 590       logical scheck
 591       integer icant
 592       external icant
 593 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 594       do i=1,210
 595         do j=1,2
 596           eneps_temp(j,i)=0.0d0
 597         enddo
 598       enddo
 599       evdw=0.0D0
 600       evdw_t=0.0d0
 601       do i=iatsc_s,iatsc_e
 602         itypi=itype(i)
 603         itypi1=itype(i+1)
 604         xi=c(1,nres+i)
 605         yi=c(2,nres+i)
 606         zi=c(3,nres+i)
 607 C
 608 C Calculate SC interaction energy.
 609 C
 610         do iint=1,nint_gr(i)
 611           do j=istart(i,iint),iend(i,iint)
 612             itypj=itype(j)
 613             xj=c(1,nres+j)-xi
 614             yj=c(2,nres+j)-yi
 615             zj=c(3,nres+j)-zi
 616             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 617             fac_augm=rrij**expon
 618             e_augm=augm(itypi,itypj)*fac_augm
 619             r_inv_ij=dsqrt(rrij)
 620             rij=1.0D0/r_inv_ij
 621             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 622             fac=r_shift_inv**expon
 623             e1=fac*fac*aa(itypi,itypj)
 624             e2=fac*bb(itypi,itypj)
 625             evdwij=e_augm+e1+e2
 626             ij=icant(itypi,itypj)
 627             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 628      &        /dabs(eps(itypi,itypj))
 629             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 630 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 631 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 632 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 633 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 634 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 635 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 636 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 637             if (bb(itypi,itypj).gt.0.0d0) then
 638               evdw=evdw+evdwij
 639             else
 640               evdw_t=evdw_t+evdwij
 641             endif
 642             if (calc_grad) then
 643 C
 644 C Calculate the components of the gradient in DC and X
 645 C
 646             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 647             gg(1)=xj*fac
 648             gg(2)=yj*fac
 649             gg(3)=zj*fac
 650             do k=1,3
 651               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 652               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 653             enddo
 654             do k=i,j-1
 655               do l=1,3
 656                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 657               enddo
 658             enddo
 659             endif
 660           enddo      ! j
 661         enddo        ! iint
 662       enddo          ! i
 663       if (calc_grad) then
 664       do i=1,nct
 665         do j=1,3
 666           gvdwc(j,i)=expon*gvdwc(j,i)
 667           gvdwx(j,i)=expon*gvdwx(j,i)
 668         enddo
 669       enddo
 670       endif
 671       return
 672       end
 673 C-----------------------------------------------------------------------------
 674       subroutine ebp(evdw,evdw_t)
 675 C
 676 C This subroutine calculates the interaction energy of nonbonded side chains
 677 C assuming the Berne-Pechukas potential of interaction.
 678 C
 679       implicit real*8 (a-h,o-z)
 680       include 'DIMENSIONS'
 681       include 'DIMENSIONS.ZSCOPT'
 682       include "DIMENSIONS.COMPAR"
 683       include 'COMMON.GEO'
 684       include 'COMMON.VAR'
 685       include 'COMMON.LOCAL'
 686       include 'COMMON.CHAIN'
 687       include 'COMMON.DERIV'
 688       include 'COMMON.NAMES'
 689       include 'COMMON.INTERACT'
 690       include 'COMMON.ENEPS'
 691       include 'COMMON.IOUNITS'
 692       include 'COMMON.CALC'
 693       common /srutu/ icall
 694 c     double precision rrsave(maxdim)
 695       logical lprn
 696       integer icant
 697       external icant
 698       do i=1,210
 699         do j=1,2
 700           eneps_temp(j,i)=0.0d0
 701         enddo
 702       enddo
 703       evdw=0.0D0
 704       evdw_t=0.0d0
 705 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 706 c     if (icall.eq.0) then
 707 c       lprn=.true.
 708 c     else
 709         lprn=.false.
 710 c     endif
 711       ind=0
 712       do i=iatsc_s,iatsc_e
 713         itypi=itype(i)
 714         itypi1=itype(i+1)
 715         xi=c(1,nres+i)
 716         yi=c(2,nres+i)
 717         zi=c(3,nres+i)
 718         dxi=dc_norm(1,nres+i)
 719         dyi=dc_norm(2,nres+i)
 720         dzi=dc_norm(3,nres+i)
 721         dsci_inv=vbld_inv(i+nres)
 722 C
 723 C Calculate SC interaction energy.
 724 C
 725         do iint=1,nint_gr(i)
 726           do j=istart(i,iint),iend(i,iint)
 727             ind=ind+1
 728             itypj=itype(j)
 729             dscj_inv=vbld_inv(j+nres)
 730             chi1=chi(itypi,itypj)
 731             chi2=chi(itypj,itypi)
 732             chi12=chi1*chi2
 733             chip1=chip(itypi)
 734             chip2=chip(itypj)
 735             chip12=chip1*chip2
 736             alf1=alp(itypi)
 737             alf2=alp(itypj)
 738             alf12=0.5D0*(alf1+alf2)
 739 C For diagnostics only!!!
 740 c           chi1=0.0D0
 741 c           chi2=0.0D0
 742 c           chi12=0.0D0
 743 c           chip1=0.0D0
 744 c           chip2=0.0D0
 745 c           chip12=0.0D0
 746 c           alf1=0.0D0
 747 c           alf2=0.0D0
 748 c           alf12=0.0D0
 749             xj=c(1,nres+j)-xi
 750             yj=c(2,nres+j)-yi
 751             zj=c(3,nres+j)-zi
 752             dxj=dc_norm(1,nres+j)
 753             dyj=dc_norm(2,nres+j)
 754             dzj=dc_norm(3,nres+j)
 755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 756 cd          if (icall.eq.0) then
 757 cd            rrsave(ind)=rrij
 758 cd          else
 759 cd            rrij=rrsave(ind)
 760 cd          endif
 761             rij=dsqrt(rrij)
 762 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 763             call sc_angular
 764 C Calculate whole angle-dependent part of epsilon and contributions
 765 C to its derivatives
 766             fac=(rrij*sigsq)**expon2
 767             e1=fac*fac*aa(itypi,itypj)
 768             e2=fac*bb(itypi,itypj)
 769             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 770             eps2der=evdwij*eps3rt
 771             eps3der=evdwij*eps2rt
 772             evdwij=evdwij*eps2rt*eps3rt
 773             ij=icant(itypi,itypj)
 774             aux=eps1*eps2rt**2*eps3rt**2
 775             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 776      &        /dabs(eps(itypi,itypj))
 777             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 778             if (bb(itypi,itypj).gt.0.0d0) then
 779               evdw=evdw+evdwij
 780             else
 781               evdw_t=evdw_t+evdwij
 782             endif
 783             if (calc_grad) then
 784             if (lprn) then
 785             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 786             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 787 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 788 cd     &        restyp(itypi),i,restyp(itypj),j,
 789 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 790 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 791 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 792 cd     &        evdwij
 793             endif
 794 C Calculate gradient components.
 795             e1=e1*eps1*eps2rt**2*eps3rt**2
 796             fac=-expon*(e1+evdwij)
 797             sigder=fac/sigsq
 798             fac=rrij*fac
 799 C Calculate radial part of the gradient
 800             gg(1)=xj*fac
 801             gg(2)=yj*fac
 802             gg(3)=zj*fac
 803 C Calculate the angular part of the gradient and sum add the contributions
 804 C to the appropriate components of the Cartesian gradient.
 805             call sc_grad
 806             endif
 807           enddo      ! j
 808         enddo        ! iint
 809       enddo          ! i
 810 c     stop
 811       return
 812       end
 813 C-----------------------------------------------------------------------------
 814       subroutine egb(evdw,evdw_t)
 815 C
 816 C This subroutine calculates the interaction energy of nonbonded side chains
 817 C assuming the Gay-Berne potential of interaction.
 818 C
 819       implicit real*8 (a-h,o-z)
 820       include 'DIMENSIONS'
 821       include 'DIMENSIONS.ZSCOPT'
 822       include "DIMENSIONS.COMPAR"
 823       include 'COMMON.GEO'
 824       include 'COMMON.VAR'
 825       include 'COMMON.LOCAL'
 826       include 'COMMON.CHAIN'
 827       include 'COMMON.DERIV'
 828       include 'COMMON.NAMES'
 829       include 'COMMON.INTERACT'
 830       include 'COMMON.ENEPS'
 831       include 'COMMON.IOUNITS'
 832       include 'COMMON.CALC'
 833       include 'COMMON.SBRIDGE'
 834       logical lprn
 835       common /srutu/icall
 836       integer icant
 837       external icant
 838       do i=1,210
 839         do j=1,2
 840           eneps_temp(j,i)=0.0d0
 841         enddo
 842       enddo
 843 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 844       evdw=0.0D0
 845       evdw_t=0.0d0
 846       lprn=.false.
 847 c      if (icall.gt.0) lprn=.true.
 848       ind=0
 849       do i=iatsc_s,iatsc_e
 850         itypi=itype(i)
 851         itypi1=itype(i+1)
 852         xi=c(1,nres+i)
 853         yi=c(2,nres+i)
 854         zi=c(3,nres+i)
 855         dxi=dc_norm(1,nres+i)
 856         dyi=dc_norm(2,nres+i)
 857         dzi=dc_norm(3,nres+i)
 858         dsci_inv=vbld_inv(i+nres)
 859 C
 860 C Calculate SC interaction energy.
 861 C
 862         do iint=1,nint_gr(i)
 863           do j=istart(i,iint),iend(i,iint)
 864 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 865 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 866 C formation no electrostatic interactions should be calculated. If it
 867 C would be allowed NaN would appear
 868             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 869 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 870 C residue can or cannot form disulfide bond. There is still bug allowing
 871 C Cys...Cys...Cys bond formation
 872               call dyn_ssbond_ene(i,j,evdwij)
 873 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 874 C function in ssMD.F
 875               evdw=evdw+evdwij
 876 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 877 c     &                        'evdw',i,j,evdwij,' ss'
 878             ELSE
 879             ind=ind+1
 880             itypj=itype(j)
 881             dscj_inv=vbld_inv(j+nres)
 882             sig0ij=sigma(itypi,itypj)
 883             chi1=chi(itypi,itypj)
 884             chi2=chi(itypj,itypi)
 885             chi12=chi1*chi2
 886             chip1=chip(itypi)
 887             chip2=chip(itypj)
 888             chip12=chip1*chip2
 889             alf1=alp(itypi)
 890             alf2=alp(itypj)
 891             alf12=0.5D0*(alf1+alf2)
 892 C For diagnostics only!!!
 893 c           chi1=0.0D0
 894 c           chi2=0.0D0
 895 c           chi12=0.0D0
 896 c           chip1=0.0D0
 897 c           chip2=0.0D0
 898 c           chip12=0.0D0
 899 c           alf1=0.0D0
 900 c           alf2=0.0D0
 901 c           alf12=0.0D0
 902             xj=c(1,nres+j)-xi
 903             yj=c(2,nres+j)-yi
 904             zj=c(3,nres+j)-zi
 905             dxj=dc_norm(1,nres+j)
 906             dyj=dc_norm(2,nres+j)
 907             dzj=dc_norm(3,nres+j)
 908 c            write (iout,*) i,j,xj,yj,zj
 909             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 910             rij=dsqrt(rrij)
 911 C Calculate angle-dependent terms of energy and contributions to their
 912 C derivatives.
 913             call sc_angular
 914             sigsq=1.0D0/sigsq
 915             sig=sig0ij*dsqrt(sigsq)
 916             rij_shift=1.0D0/rij-sig+sig0ij
 917 C I hate to put IF's in the loops, but here don't have another choice!!!!
 918             if (rij_shift.le.0.0D0) then
 919               evdw=1.0D20
 920               return
 921             endif
 922             sigder=-sig*sigsq
 923 c---------------------------------------------------------------
 924             rij_shift=1.0D0/rij_shift
 925             fac=rij_shift**expon
 926             e1=fac*fac*aa(itypi,itypj)
 927             e2=fac*bb(itypi,itypj)
 928             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 929             eps2der=evdwij*eps3rt
 930             eps3der=evdwij*eps2rt
 931             evdwij=evdwij*eps2rt*eps3rt
 932             if (bb(itypi,itypj).gt.0) then
 933               evdw=evdw+evdwij
 934             else
 935               evdw_t=evdw_t+evdwij
 936             endif
 937             ij=icant(itypi,itypj)
 938             aux=eps1*eps2rt**2*eps3rt**2
 939             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 940      &        /dabs(eps(itypi,itypj))
 941             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 942 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 943 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 944 c     &         aux*e2/eps(itypi,itypj)
 945 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 946             if (lprn) then
 947             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 948             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 949             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 950      &        restyp(itypi),i,restyp(itypj),j,
 951      &        epsi,sigm,chi1,chi2,chip1,chip2,
 952      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 953      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 954      &        evdwij
 955             endif
 956             if (calc_grad) then
 957 C Calculate gradient components.
 958             e1=e1*eps1*eps2rt**2*eps3rt**2
 959             fac=-expon*(e1+evdwij)*rij_shift
 960             sigder=fac*sigder
 961             fac=rij*fac
 962 C Calculate the radial part of the gradient
 963             gg(1)=xj*fac
 964             gg(2)=yj*fac
 965             gg(3)=zj*fac
 966 C Calculate angular part of the gradient.
 967             call sc_grad
 968             endif
 969             ENDIF    ! dyn_ss
 970           enddo      ! j
 971         enddo        ! iint
 972       enddo          ! i
 973       return
 974       end
 975 C-----------------------------------------------------------------------------
 976       subroutine egbv(evdw,evdw_t)
 977 C
 978 C This subroutine calculates the interaction energy of nonbonded side chains
 979 C assuming the Gay-Berne-Vorobjev potential of interaction.
 980 C
 981       implicit real*8 (a-h,o-z)
 982       include 'DIMENSIONS'
 983       include 'DIMENSIONS.ZSCOPT'
 984       include "DIMENSIONS.COMPAR"
 985       include 'COMMON.GEO'
 986       include 'COMMON.VAR'
 987       include 'COMMON.LOCAL'
 988       include 'COMMON.CHAIN'
 989       include 'COMMON.DERIV'
 990       include 'COMMON.NAMES'
 991       include 'COMMON.INTERACT'
 992       include 'COMMON.ENEPS'
 993       include 'COMMON.IOUNITS'
 994       include 'COMMON.CALC'
 995       common /srutu/ icall
 996       logical lprn
 997       integer icant
 998       external icant
 999       do i=1,210
1000         do j=1,2
1001           eneps_temp(j,i)=0.0d0
1002         enddo
1003       enddo
1004       evdw=0.0D0
1005       evdw_t=0.0d0
1006 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1007       evdw=0.0D0
1008       lprn=.false.
1009 c      if (icall.gt.0) lprn=.true.
1010       ind=0
1011       do i=iatsc_s,iatsc_e
1012         itypi=itype(i)
1013         itypi1=itype(i+1)
1014         xi=c(1,nres+i)
1015         yi=c(2,nres+i)
1016         zi=c(3,nres+i)
1017         dxi=dc_norm(1,nres+i)
1018         dyi=dc_norm(2,nres+i)
1019         dzi=dc_norm(3,nres+i)
1020         dsci_inv=vbld_inv(i+nres)
1021 C
1022 C Calculate SC interaction energy.
1023 C
1024         do iint=1,nint_gr(i)
1025           do j=istart(i,iint),iend(i,iint)
1026             ind=ind+1
1027             itypj=itype(j)
1028             dscj_inv=vbld_inv(j+nres)
1029             sig0ij=sigma(itypi,itypj)
1030             r0ij=r0(itypi,itypj)
1031             chi1=chi(itypi,itypj)
1032             chi2=chi(itypj,itypi)
1033             chi12=chi1*chi2
1034             chip1=chip(itypi)
1035             chip2=chip(itypj)
1036             chip12=chip1*chip2
1037             alf1=alp(itypi)
1038             alf2=alp(itypj)
1039             alf12=0.5D0*(alf1+alf2)
1040 C For diagnostics only!!!
1041 c           chi1=0.0D0
1042 c           chi2=0.0D0
1043 c           chi12=0.0D0
1044 c           chip1=0.0D0
1045 c           chip2=0.0D0
1046 c           chip12=0.0D0
1047 c           alf1=0.0D0
1048 c           alf2=0.0D0
1049 c           alf12=0.0D0
1050             xj=c(1,nres+j)-xi
1051             yj=c(2,nres+j)-yi
1052             zj=c(3,nres+j)-zi
1053             dxj=dc_norm(1,nres+j)
1054             dyj=dc_norm(2,nres+j)
1055             dzj=dc_norm(3,nres+j)
1056             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1057             rij=dsqrt(rrij)
1058 C Calculate angle-dependent terms of energy and contributions to their
1059 C derivatives.
1060             call sc_angular
1061             sigsq=1.0D0/sigsq
1062             sig=sig0ij*dsqrt(sigsq)
1063             rij_shift=1.0D0/rij-sig+r0ij
1064 C I hate to put IF's in the loops, but here don't have another choice!!!!
1065             if (rij_shift.le.0.0D0) then
1066               evdw=1.0D20
1067               return
1068             endif
1069             sigder=-sig*sigsq
1070 c---------------------------------------------------------------
1071             rij_shift=1.0D0/rij_shift
1072             fac=rij_shift**expon
1073             e1=fac*fac*aa(itypi,itypj)
1074             e2=fac*bb(itypi,itypj)
1075             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1076             eps2der=evdwij*eps3rt
1077             eps3der=evdwij*eps2rt
1078             fac_augm=rrij**expon
1079             e_augm=augm(itypi,itypj)*fac_augm
1080             evdwij=evdwij*eps2rt*eps3rt
1081             if (bb(itypi,itypj).gt.0.0d0) then
1082               evdw=evdw+evdwij+e_augm
1083             else
1084               evdw_t=evdw_t+evdwij+e_augm
1085             endif
1086             ij=icant(itypi,itypj)
1087             aux=eps1*eps2rt**2*eps3rt**2
1088             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1089      &        /dabs(eps(itypi,itypj))
1090             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1091 c            eneps_temp(ij)=eneps_temp(ij)
1092 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1093 c            if (lprn) then
1094 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1097 c     &        restyp(itypi),i,restyp(itypj),j,
1098 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1099 c     &        chi1,chi2,chip1,chip2,
1100 c     &        eps1,eps2rt**2,eps3rt**2,
1101 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1102 c     &        evdwij+e_augm
1103 c            endif
1104             if (calc_grad) then
1105 C Calculate gradient components.
1106             e1=e1*eps1*eps2rt**2*eps3rt**2
1107             fac=-expon*(e1+evdwij)*rij_shift
1108             sigder=fac*sigder
1109             fac=rij*fac-2*expon*rrij*e_augm
1110 C Calculate the radial part of the gradient
1111             gg(1)=xj*fac
1112             gg(2)=yj*fac
1113             gg(3)=zj*fac
1114 C Calculate angular part of the gradient.
1115             call sc_grad
1116             endif
1117           enddo      ! j
1118         enddo        ! iint
1119       enddo          ! i
1120       return
1121       end
1122 C-----------------------------------------------------------------------------
1123       subroutine sc_angular
1124 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1125 C om12. Called by ebp, egb, and egbv.
1126       implicit none
1127       include 'COMMON.CALC'
1128       erij(1)=xj*rij
1129       erij(2)=yj*rij
1130       erij(3)=zj*rij
1131       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1132       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1133       om12=dxi*dxj+dyi*dyj+dzi*dzj
1134       chiom12=chi12*om12
1135 C Calculate eps1(om12) and its derivative in om12
1136       faceps1=1.0D0-om12*chiom12
1137       faceps1_inv=1.0D0/faceps1
1138       eps1=dsqrt(faceps1_inv)
1139 C Following variable is eps1*deps1/dom12
1140       eps1_om12=faceps1_inv*chiom12
1141 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1142 C and om12.
1143       om1om2=om1*om2
1144       chiom1=chi1*om1
1145       chiom2=chi2*om2
1146       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1147       sigsq=1.0D0-facsig*faceps1_inv
1148       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1149       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1150       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1151 C Calculate eps2 and its derivatives in om1, om2, and om12.
1152       chipom1=chip1*om1
1153       chipom2=chip2*om2
1154       chipom12=chip12*om12
1155       facp=1.0D0-om12*chipom12
1156       facp_inv=1.0D0/facp
1157       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1158 C Following variable is the square root of eps2
1159       eps2rt=1.0D0-facp1*facp_inv
1160 C Following three variables are the derivatives of the square root of eps
1161 C in om1, om2, and om12.
1162       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1163       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1164       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1165 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1166       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1167 C Calculate whole angle-dependent part of epsilon and contributions
1168 C to its derivatives
1169       return
1170       end
1171 C----------------------------------------------------------------------------
1172       subroutine sc_grad
1173       implicit real*8 (a-h,o-z)
1174       include 'DIMENSIONS'
1175       include 'DIMENSIONS.ZSCOPT'
1176       include 'COMMON.CHAIN'
1177       include 'COMMON.DERIV'
1178       include 'COMMON.CALC'
1179       double precision dcosom1(3),dcosom2(3)
1180       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1181       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1182       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1183      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1184       do k=1,3
1185         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1186         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1187       enddo
1188       do k=1,3
1189         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1190       enddo
1191       do k=1,3
1192         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1194      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1195         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1197      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1198       enddo
1199 C
1200 C Calculate the components of the gradient in DC and X
1201 C
1202       do k=i,j-1
1203         do l=1,3
1204           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1205         enddo
1206       enddo
1207       return
1208       end
1209 c------------------------------------------------------------------------------
1210       subroutine vec_and_deriv
1211       implicit real*8 (a-h,o-z)
1212       include 'DIMENSIONS'
1213       include 'DIMENSIONS.ZSCOPT'
1214       include 'COMMON.IOUNITS'
1215       include 'COMMON.GEO'
1216       include 'COMMON.VAR'
1217       include 'COMMON.LOCAL'
1218       include 'COMMON.CHAIN'
1219       include 'COMMON.VECTORS'
1220       include 'COMMON.DERIV'
1221       include 'COMMON.INTERACT'
1222       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1223 C Compute the local reference systems. For reference system (i), the
1224 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1225 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1226       do i=1,nres-1
1227 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1228           if (i.eq.nres-1) then
1229 C Case of the last full residue
1230 C Compute the Z-axis
1231             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1232             costh=dcos(pi-theta(nres))
1233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1234             do k=1,3
1235               uz(k,i)=fac*uz(k,i)
1236             enddo
1237             if (calc_grad) then
1238 C Compute the derivatives of uz
1239             uzder(1,1,1)= 0.0d0
1240             uzder(2,1,1)=-dc_norm(3,i-1)
1241             uzder(3,1,1)= dc_norm(2,i-1)
1242             uzder(1,2,1)= dc_norm(3,i-1)
1243             uzder(2,2,1)= 0.0d0
1244             uzder(3,2,1)=-dc_norm(1,i-1)
1245             uzder(1,3,1)=-dc_norm(2,i-1)
1246             uzder(2,3,1)= dc_norm(1,i-1)
1247             uzder(3,3,1)= 0.0d0
1248             uzder(1,1,2)= 0.0d0
1249             uzder(2,1,2)= dc_norm(3,i)
1250             uzder(3,1,2)=-dc_norm(2,i)
1251             uzder(1,2,2)=-dc_norm(3,i)
1252             uzder(2,2,2)= 0.0d0
1253             uzder(3,2,2)= dc_norm(1,i)
1254             uzder(1,3,2)= dc_norm(2,i)
1255             uzder(2,3,2)=-dc_norm(1,i)
1256             uzder(3,3,2)= 0.0d0
1257             endif
1258 C Compute the Y-axis
1259             facy=fac
1260             do k=1,3
1261               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1262             enddo
1263             if (calc_grad) then
1264 C Compute the derivatives of uy
1265             do j=1,3
1266               do k=1,3
1267                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1268      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1269                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1270               enddo
1271               uyder(j,j,1)=uyder(j,j,1)-costh
1272               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1273             enddo
1274             do j=1,2
1275               do k=1,3
1276                 do l=1,3
1277                   uygrad(l,k,j,i)=uyder(l,k,j)
1278                   uzgrad(l,k,j,i)=uzder(l,k,j)
1279                 enddo
1280               enddo
1281             enddo
1282             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1283             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1284             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1285             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1286             endif
1287           else
1288 C Other residues
1289 C Compute the Z-axis
1290             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1291             costh=dcos(pi-theta(i+2))
1292             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1293             do k=1,3
1294               uz(k,i)=fac*uz(k,i)
1295             enddo
1296             if (calc_grad) then
1297 C Compute the derivatives of uz
1298             uzder(1,1,1)= 0.0d0
1299             uzder(2,1,1)=-dc_norm(3,i+1)
1300             uzder(3,1,1)= dc_norm(2,i+1)
1301             uzder(1,2,1)= dc_norm(3,i+1)
1302             uzder(2,2,1)= 0.0d0
1303             uzder(3,2,1)=-dc_norm(1,i+1)
1304             uzder(1,3,1)=-dc_norm(2,i+1)
1305             uzder(2,3,1)= dc_norm(1,i+1)
1306             uzder(3,3,1)= 0.0d0
1307             uzder(1,1,2)= 0.0d0
1308             uzder(2,1,2)= dc_norm(3,i)
1309             uzder(3,1,2)=-dc_norm(2,i)
1310             uzder(1,2,2)=-dc_norm(3,i)
1311             uzder(2,2,2)= 0.0d0
1312             uzder(3,2,2)= dc_norm(1,i)
1313             uzder(1,3,2)= dc_norm(2,i)
1314             uzder(2,3,2)=-dc_norm(1,i)
1315             uzder(3,3,2)= 0.0d0
1316             endif
1317 C Compute the Y-axis
1318             facy=fac
1319             do k=1,3
1320               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1321             enddo
1322             if (calc_grad) then
1323 C Compute the derivatives of uy
1324             do j=1,3
1325               do k=1,3
1326                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1327      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1328                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1329               enddo
1330               uyder(j,j,1)=uyder(j,j,1)-costh
1331               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1332             enddo
1333             do j=1,2
1334               do k=1,3
1335                 do l=1,3
1336                   uygrad(l,k,j,i)=uyder(l,k,j)
1337                   uzgrad(l,k,j,i)=uzder(l,k,j)
1338                 enddo
1339               enddo
1340             enddo
1341             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1342             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1343             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1344             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1345           endif
1346           endif
1347       enddo
1348       if (calc_grad) then
1349       do i=1,nres-1
1350         vbld_inv_temp(1)=vbld_inv(i+1)
1351         if (i.lt.nres-1) then
1352           vbld_inv_temp(2)=vbld_inv(i+2)
1353         else
1354           vbld_inv_temp(2)=vbld_inv(i)
1355         endif
1356         do j=1,2
1357           do k=1,3
1358             do l=1,3
1359               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1360               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1361             enddo
1362           enddo
1363         enddo
1364       enddo
1365       endif
1366       return
1367       end
1368 C-----------------------------------------------------------------------------
1369       subroutine vec_and_deriv_test
1370       implicit real*8 (a-h,o-z)
1371       include 'DIMENSIONS'
1372       include 'DIMENSIONS.ZSCOPT'
1373       include 'COMMON.IOUNITS'
1374       include 'COMMON.GEO'
1375       include 'COMMON.VAR'
1376       include 'COMMON.LOCAL'
1377       include 'COMMON.CHAIN'
1378       include 'COMMON.VECTORS'
1379       dimension uyder(3,3,2),uzder(3,3,2)
1380 C Compute the local reference systems. For reference system (i), the
1381 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1382 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1383       do i=1,nres-1
1384           if (i.eq.nres-1) then
1385 C Case of the last full residue
1386 C Compute the Z-axis
1387             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1388             costh=dcos(pi-theta(nres))
1389             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1390 c            write (iout,*) 'fac',fac,
1391 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i-1)
1399             uzder(3,1,1)= dc_norm(2,i-1)
1400             uzder(1,2,1)= dc_norm(3,i-1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i-1)
1403             uzder(1,3,1)=-dc_norm(2,i-1)
1404             uzder(2,3,1)= dc_norm(1,i-1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             do k=1,3
1417               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1418             enddo
1419             facy=fac
1420             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1421      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1422      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1423             do k=1,3
1424 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1425               uy(k,i)=
1426 c     &        facy*(
1427      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1428      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1429 c     &        )
1430             enddo
1431 c            write (iout,*) 'facy',facy,
1432 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1434             do k=1,3
1435               uy(k,i)=facy*uy(k,i)
1436             enddo
1437 C Compute the derivatives of uy
1438             do j=1,3
1439               do k=1,3
1440                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1441      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1442                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1443               enddo
1444 c              uyder(j,j,1)=uyder(j,j,1)-costh
1445 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1446               uyder(j,j,1)=uyder(j,j,1)
1447      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1448               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1449      &          +uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463           else
1464 C Other residues
1465 C Compute the Z-axis
1466             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1467             costh=dcos(pi-theta(i+2))
1468             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1469             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1470             do k=1,3
1471               uz(k,i)=fac*uz(k,i)
1472             enddo
1473 C Compute the derivatives of uz
1474             uzder(1,1,1)= 0.0d0
1475             uzder(2,1,1)=-dc_norm(3,i+1)
1476             uzder(3,1,1)= dc_norm(2,i+1)
1477             uzder(1,2,1)= dc_norm(3,i+1)
1478             uzder(2,2,1)= 0.0d0
1479             uzder(3,2,1)=-dc_norm(1,i+1)
1480             uzder(1,3,1)=-dc_norm(2,i+1)
1481             uzder(2,3,1)= dc_norm(1,i+1)
1482             uzder(3,3,1)= 0.0d0
1483             uzder(1,1,2)= 0.0d0
1484             uzder(2,1,2)= dc_norm(3,i)
1485             uzder(3,1,2)=-dc_norm(2,i)
1486             uzder(1,2,2)=-dc_norm(3,i)
1487             uzder(2,2,2)= 0.0d0
1488             uzder(3,2,2)= dc_norm(1,i)
1489             uzder(1,3,2)= dc_norm(2,i)
1490             uzder(2,3,2)=-dc_norm(1,i)
1491             uzder(3,3,2)= 0.0d0
1492 C Compute the Y-axis
1493             facy=fac
1494             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1495      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1496      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1497             do k=1,3
1498 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1499               uy(k,i)=
1500 c     &        facy*(
1501      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1502      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1503 c     &        )
1504             enddo
1505 c            write (iout,*) 'facy',facy,
1506 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1508             do k=1,3
1509               uy(k,i)=facy*uy(k,i)
1510             enddo
1511 C Compute the derivatives of uy
1512             do j=1,3
1513               do k=1,3
1514                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1515      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1516                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1517               enddo
1518 c              uyder(j,j,1)=uyder(j,j,1)-costh
1519 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1520               uyder(j,j,1)=uyder(j,j,1)
1521      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1522               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1523      &          +uyder(j,j,2)
1524             enddo
1525             do j=1,2
1526               do k=1,3
1527                 do l=1,3
1528                   uygrad(l,k,j,i)=uyder(l,k,j)
1529                   uzgrad(l,k,j,i)=uzder(l,k,j)
1530                 enddo
1531               enddo
1532             enddo
1533             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1534             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1535             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1536             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1537           endif
1538       enddo
1539       do i=1,nres-1
1540         do j=1,2
1541           do k=1,3
1542             do l=1,3
1543               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1544               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1545             enddo
1546           enddo
1547         enddo
1548       enddo
1549       return
1550       end
1551 C-----------------------------------------------------------------------------
1552       subroutine check_vecgrad
1553       implicit real*8 (a-h,o-z)
1554       include 'DIMENSIONS'
1555       include 'DIMENSIONS.ZSCOPT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.GEO'
1558       include 'COMMON.VAR'
1559       include 'COMMON.LOCAL'
1560       include 'COMMON.CHAIN'
1561       include 'COMMON.VECTORS'
1562       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1563       dimension uyt(3,maxres),uzt(3,maxres)
1564       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1565       double precision delta /1.0d-7/
1566       call vec_and_deriv
1567 cd      do i=1,nres
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1570 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1571 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1572 cd     &     (dc_norm(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1574 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1575 cd          write(iout,'(a)')
1576 cd      enddo
1577       do i=1,nres
1578         do j=1,2
1579           do k=1,3
1580             do l=1,3
1581               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1582               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1583             enddo
1584           enddo
1585         enddo
1586       enddo
1587       call vec_and_deriv
1588       do i=1,nres
1589         do j=1,3
1590           uyt(j,i)=uy(j,i)
1591           uzt(j,i)=uz(j,i)
1592         enddo
1593       enddo
1594       do i=1,nres
1595 cd        write (iout,*) 'i=',i
1596         do k=1,3
1597           erij(k)=dc_norm(k,i)
1598         enddo
1599         do j=1,3
1600           do k=1,3
1601             dc_norm(k,i)=erij(k)
1602           enddo
1603           dc_norm(j,i)=dc_norm(j,i)+delta
1604 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1605 c          do k=1,3
1606 c            dc_norm(k,i)=dc_norm(k,i)/fac
1607 c          enddo
1608 c          write (iout,*) (dc_norm(k,i),k=1,3)
1609 c          write (iout,*) (erij(k),k=1,3)
1610           call vec_and_deriv
1611           do k=1,3
1612             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1613             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1614             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1615             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1616           enddo
1617 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1618 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1619 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1620         enddo
1621         do k=1,3
1622           dc_norm(k,i)=erij(k)
1623         enddo
1624 cd        do k=1,3
1625 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1626 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1627 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1628 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1629 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1630 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1631 cd          write (iout,'(a)')
1632 cd        enddo
1633       enddo
1634       return
1635       end
1636 C--------------------------------------------------------------------------
1637       subroutine set_matrices
1638       implicit real*8 (a-h,o-z)
1639       include 'DIMENSIONS'
1640       include 'DIMENSIONS.ZSCOPT'
1641       include 'COMMON.IOUNITS'
1642       include 'COMMON.GEO'
1643       include 'COMMON.VAR'
1644       include 'COMMON.LOCAL'
1645       include 'COMMON.CHAIN'
1646       include 'COMMON.DERIV'
1647       include 'COMMON.INTERACT'
1648       include 'COMMON.CONTACTS'
1649       include 'COMMON.TORSION'
1650       include 'COMMON.VECTORS'
1651       include 'COMMON.FFIELD'
1652       double precision auxvec(2),auxmat(2,2)
1653 C
1654 C Compute the virtual-bond-torsional-angle dependent quantities needed
1655 C to calculate the el-loc multibody terms of various order.
1656 C
1657       do i=3,nres+1
1658         if (i .lt. nres+1) then
1659           sin1=dsin(phi(i))
1660           cos1=dcos(phi(i))
1661           sintab(i-2)=sin1
1662           costab(i-2)=cos1
1663           obrot(1,i-2)=cos1
1664           obrot(2,i-2)=sin1
1665           sin2=dsin(2*phi(i))
1666           cos2=dcos(2*phi(i))
1667           sintab2(i-2)=sin2
1668           costab2(i-2)=cos2
1669           obrot2(1,i-2)=cos2
1670           obrot2(2,i-2)=sin2
1671           Ug(1,1,i-2)=-cos1
1672           Ug(1,2,i-2)=-sin1
1673           Ug(2,1,i-2)=-sin1
1674           Ug(2,2,i-2)= cos1
1675           Ug2(1,1,i-2)=-cos2
1676           Ug2(1,2,i-2)=-sin2
1677           Ug2(2,1,i-2)=-sin2
1678           Ug2(2,2,i-2)= cos2
1679         else
1680           costab(i-2)=1.0d0
1681           sintab(i-2)=0.0d0
1682           obrot(1,i-2)=1.0d0
1683           obrot(2,i-2)=0.0d0
1684           obrot2(1,i-2)=0.0d0
1685           obrot2(2,i-2)=0.0d0
1686           Ug(1,1,i-2)=1.0d0
1687           Ug(1,2,i-2)=0.0d0
1688           Ug(2,1,i-2)=0.0d0
1689           Ug(2,2,i-2)=1.0d0
1690           Ug2(1,1,i-2)=0.0d0
1691           Ug2(1,2,i-2)=0.0d0
1692           Ug2(2,1,i-2)=0.0d0
1693           Ug2(2,2,i-2)=0.0d0
1694         endif
1695         if (i .gt. 3 .and. i .lt. nres+1) then
1696           obrot_der(1,i-2)=-sin1
1697           obrot_der(2,i-2)= cos1
1698           Ugder(1,1,i-2)= sin1
1699           Ugder(1,2,i-2)=-cos1
1700           Ugder(2,1,i-2)=-cos1
1701           Ugder(2,2,i-2)=-sin1
1702           dwacos2=cos2+cos2
1703           dwasin2=sin2+sin2
1704           obrot2_der(1,i-2)=-dwasin2
1705           obrot2_der(2,i-2)= dwacos2
1706           Ug2der(1,1,i-2)= dwasin2
1707           Ug2der(1,2,i-2)=-dwacos2
1708           Ug2der(2,1,i-2)=-dwacos2
1709           Ug2der(2,2,i-2)=-dwasin2
1710         else
1711           obrot_der(1,i-2)=0.0d0
1712           obrot_der(2,i-2)=0.0d0
1713           Ugder(1,1,i-2)=0.0d0
1714           Ugder(1,2,i-2)=0.0d0
1715           Ugder(2,1,i-2)=0.0d0
1716           Ugder(2,2,i-2)=0.0d0
1717           obrot2_der(1,i-2)=0.0d0
1718           obrot2_der(2,i-2)=0.0d0
1719           Ug2der(1,1,i-2)=0.0d0
1720           Ug2der(1,2,i-2)=0.0d0
1721           Ug2der(2,1,i-2)=0.0d0
1722           Ug2der(2,2,i-2)=0.0d0
1723         endif
1724         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1725           iti = itortyp(itype(i-2))
1726         else
1727           iti=ntortyp+1
1728         endif
1729         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1730           iti1 = itortyp(itype(i-1))
1731         else
1732           iti1=ntortyp+1
1733         endif
1734 cd        write (iout,*) '*******i',i,' iti1',iti
1735 cd        write (iout,*) 'b1',b1(:,iti)
1736 cd        write (iout,*) 'b2',b2(:,iti)
1737 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1738         if (i .gt. iatel_s+2) then
1739           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1740           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1741           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1742           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1743           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1744           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1745           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1746         else
1747           do k=1,2
1748             Ub2(k,i-2)=0.0d0
1749             Ctobr(k,i-2)=0.0d0
1750             Dtobr2(k,i-2)=0.0d0
1751             do l=1,2
1752               EUg(l,k,i-2)=0.0d0
1753               CUg(l,k,i-2)=0.0d0
1754               DUg(l,k,i-2)=0.0d0
1755               DtUg2(l,k,i-2)=0.0d0
1756             enddo
1757           enddo
1758         endif
1759         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1760         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1761         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1762         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1763         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1764         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1765         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1766         do k=1,2
1767           muder(k,i-2)=Ub2der(k,i-2)
1768         enddo
1769         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1770           iti1 = itortyp(itype(i-1))
1771         else
1772           iti1=ntortyp+1
1773         endif
1774         do k=1,2
1775           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1776         enddo
1777 C Vectors and matrices dependent on a single virtual-bond dihedral.
1778         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1779         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1780         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1782         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1783         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1784         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1785         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1786         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1787 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1788 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1789       enddo
1790 C Matrices dependent on two consecutive virtual-bond dihedrals.
1791 C The order of matrices is from left to right.
1792       do i=2,nres-1
1793         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1794         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1795         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1796         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1797         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1798         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1799         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1800         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1801       enddo
1802 cd      do i=1,nres
1803 cd        iti = itortyp(itype(i))
1804 cd        write (iout,*) i
1805 cd        do j=1,2
1806 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1807 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1808 cd        enddo
1809 cd      enddo
1810       return
1811       end
1812 C--------------------------------------------------------------------------
1813       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1814 C
1815 C This subroutine calculates the average interaction energy and its gradient
1816 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1817 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1818 C The potential depends both on the distance of peptide-group centers and on
1819 C the orientation of the CA-CA virtual bonds.
1820 C
1821       implicit real*8 (a-h,o-z)
1822       include 'DIMENSIONS'
1823       include 'DIMENSIONS.ZSCOPT'
1824       include 'DIMENSIONS.FREE'
1825       include 'COMMON.CONTROL'
1826       include 'COMMON.IOUNITS'
1827       include 'COMMON.GEO'
1828       include 'COMMON.VAR'
1829       include 'COMMON.LOCAL'
1830       include 'COMMON.CHAIN'
1831       include 'COMMON.DERIV'
1832       include 'COMMON.INTERACT'
1833       include 'COMMON.CONTACTS'
1834       include 'COMMON.TORSION'
1835       include 'COMMON.VECTORS'
1836       include 'COMMON.FFIELD'
1837       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1838      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1839       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1840      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1841       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1842 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1843       double precision scal_el /0.5d0/
1844 C 12/13/98
1845 C 13-go grudnia roku pamietnego...
1846       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1847      &                   0.0d0,1.0d0,0.0d0,
1848      &                   0.0d0,0.0d0,1.0d0/
1849 cd      write(iout,*) 'In EELEC'
1850 cd      do i=1,nloctyp
1851 cd        write(iout,*) 'Type',i
1852 cd        write(iout,*) 'B1',B1(:,i)
1853 cd        write(iout,*) 'B2',B2(:,i)
1854 cd        write(iout,*) 'CC',CC(:,:,i)
1855 cd        write(iout,*) 'DD',DD(:,:,i)
1856 cd        write(iout,*) 'EE',EE(:,:,i)
1857 cd      enddo
1858 cd      call check_vecgrad
1859 cd      stop
1860       if (icheckgrad.eq.1) then
1861         do i=1,nres-1
1862           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1863           do k=1,3
1864             dc_norm(k,i)=dc(k,i)*fac
1865           enddo
1866 c          write (iout,*) 'i',i,' fac',fac
1867         enddo
1868       endif
1869       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1870      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1871      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1872 cd      if (wel_loc.gt.0.0d0) then
1873         if (icheckgrad.eq.1) then
1874         call vec_and_deriv_test
1875         else
1876         call vec_and_deriv
1877         endif
1878         call set_matrices
1879       endif
1880 cd      do i=1,nres-1
1881 cd        write (iout,*) 'i=',i
1882 cd        do k=1,3
1883 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1884 cd        enddo
1885 cd        do k=1,3
1886 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1887 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1888 cd        enddo
1889 cd      enddo
1890       num_conti_hb=0
1891       ees=0.0D0
1892       evdw1=0.0D0
1893       eel_loc=0.0d0
1894       eello_turn3=0.0d0
1895       eello_turn4=0.0d0
1896       ind=0
1897       do i=1,nres
1898         num_cont_hb(i)=0
1899       enddo
1900 cd      print '(a)','Enter EELEC'
1901 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1902       do i=1,nres
1903         gel_loc_loc(i)=0.0d0
1904         gcorr_loc(i)=0.0d0
1905       enddo
1906       do i=iatel_s,iatel_e
1907         if (itel(i).eq.0) goto 1215
1908         dxi=dc(1,i)
1909         dyi=dc(2,i)
1910         dzi=dc(3,i)
1911         dx_normi=dc_norm(1,i)
1912         dy_normi=dc_norm(2,i)
1913         dz_normi=dc_norm(3,i)
1914         xmedi=c(1,i)+0.5d0*dxi
1915         ymedi=c(2,i)+0.5d0*dyi
1916         zmedi=c(3,i)+0.5d0*dzi
1917         num_conti=0
1918 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1919         do j=ielstart(i),ielend(i)
1920           if (itel(j).eq.0) goto 1216
1921           ind=ind+1
1922           iteli=itel(i)
1923           itelj=itel(j)
1924           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1925           aaa=app(iteli,itelj)
1926           bbb=bpp(iteli,itelj)
1927 C Diagnostics only!!!
1928 c         aaa=0.0D0
1929 c         bbb=0.0D0
1930 c         ael6i=0.0D0
1931 c         ael3i=0.0D0
1932 C End diagnostics
1933           ael6i=ael6(iteli,itelj)
1934           ael3i=ael3(iteli,itelj)
1935           dxj=dc(1,j)
1936           dyj=dc(2,j)
1937           dzj=dc(3,j)
1938           dx_normj=dc_norm(1,j)
1939           dy_normj=dc_norm(2,j)
1940           dz_normj=dc_norm(3,j)
1941           xj=c(1,j)+0.5D0*dxj-xmedi
1942           yj=c(2,j)+0.5D0*dyj-ymedi
1943           zj=c(3,j)+0.5D0*dzj-zmedi
1944           rij=xj*xj+yj*yj+zj*zj
1945           rrmij=1.0D0/rij
1946           rij=dsqrt(rij)
1947           rmij=1.0D0/rij
1948           r3ij=rrmij*rmij
1949           r6ij=r3ij*r3ij
1950           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1951           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1952           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1953           fac=cosa-3.0D0*cosb*cosg
1954           ev1=aaa*r6ij*r6ij
1955 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1956           if (j.eq.i+2) ev1=scal_el*ev1
1957           ev2=bbb*r6ij
1958           fac3=ael6i*r6ij
1959           fac4=ael3i*r3ij
1960           evdwij=ev1+ev2
1961           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1962           el2=fac4*fac
1963           eesij=el1+el2
1964 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1965 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1966           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1967           ees=ees+eesij
1968           evdw1=evdw1+evdwij
1969 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1970 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1971 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1972 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1973 C
1974 C Calculate contributions to the Cartesian gradient.
1975 C
1976 #ifdef SPLITELE
1977           facvdw=-6*rrmij*(ev1+evdwij)
1978           facel=-3*rrmij*(el1+eesij)
1979           fac1=fac
1980           erij(1)=xj*rmij
1981           erij(2)=yj*rmij
1982           erij(3)=zj*rmij
1983           if (calc_grad) then
1984 *
1985 * Radial derivatives. First process both termini of the fragment (i,j)
1986 *
1987           ggg(1)=facel*xj
1988           ggg(2)=facel*yj
1989           ggg(3)=facel*zj
1990           do k=1,3
1991             ghalf=0.5D0*ggg(k)
1992             gelc(k,i)=gelc(k,i)+ghalf
1993             gelc(k,j)=gelc(k,j)+ghalf
1994           enddo
1995 *
1996 * Loop over residues i+1 thru j-1.
1997 *
1998           do k=i+1,j-1
1999             do l=1,3
2000               gelc(l,k)=gelc(l,k)+ggg(l)
2001             enddo
2002           enddo
2003           ggg(1)=facvdw*xj
2004           ggg(2)=facvdw*yj
2005           ggg(3)=facvdw*zj
2006           do k=1,3
2007             ghalf=0.5D0*ggg(k)
2008             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2009             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2010           enddo
2011 *
2012 * Loop over residues i+1 thru j-1.
2013 *
2014           do k=i+1,j-1
2015             do l=1,3
2016               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2017             enddo
2018           enddo
2019 #else
2020           facvdw=ev1+evdwij
2021           facel=el1+eesij
2022           fac1=fac
2023           fac=-3*rrmij*(facvdw+facvdw+facel)
2024           erij(1)=xj*rmij
2025           erij(2)=yj*rmij
2026           erij(3)=zj*rmij
2027           if (calc_grad) then
2028 *
2029 * Radial derivatives. First process both termini of the fragment (i,j)
2030 *
2031           ggg(1)=fac*xj
2032           ggg(2)=fac*yj
2033           ggg(3)=fac*zj
2034           do k=1,3
2035             ghalf=0.5D0*ggg(k)
2036             gelc(k,i)=gelc(k,i)+ghalf
2037             gelc(k,j)=gelc(k,j)+ghalf
2038           enddo
2039 *
2040 * Loop over residues i+1 thru j-1.
2041 *
2042           do k=i+1,j-1
2043             do l=1,3
2044               gelc(l,k)=gelc(l,k)+ggg(l)
2045             enddo
2046           enddo
2047 #endif
2048 *
2049 * Angular part
2050 *
2051           ecosa=2.0D0*fac3*fac1+fac4
2052           fac4=-3.0D0*fac4
2053           fac3=-6.0D0*fac3
2054           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2055           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2056           do k=1,3
2057             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2058             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2059           enddo
2060 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2061 cd   &          (dcosg(k),k=1,3)
2062           do k=1,3
2063             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2064           enddo
2065           do k=1,3
2066             ghalf=0.5D0*ggg(k)
2067             gelc(k,i)=gelc(k,i)+ghalf
2068      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2069      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2070             gelc(k,j)=gelc(k,j)+ghalf
2071      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2072      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2073           enddo
2074           do k=i+1,j-1
2075             do l=1,3
2076               gelc(l,k)=gelc(l,k)+ggg(l)
2077             enddo
2078           enddo
2079           endif
2080
2081           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2082      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2083      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2084 C
2085 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2086 C   energy of a peptide unit is assumed in the form of a second-order
2087 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2088 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2089 C   are computed for EVERY pair of non-contiguous peptide groups.
2090 C
2091           if (j.lt.nres-1) then
2092             j1=j+1
2093             j2=j-1
2094           else
2095             j1=j-1
2096             j2=j-2
2097           endif
2098           kkk=0
2099           do k=1,2
2100             do l=1,2
2101               kkk=kkk+1
2102               muij(kkk)=mu(k,i)*mu(l,j)
2103             enddo
2104           enddo
2105 cd         write (iout,*) 'EELEC: i',i,' j',j
2106 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2107 cd          write(iout,*) 'muij',muij
2108           ury=scalar(uy(1,i),erij)
2109           urz=scalar(uz(1,i),erij)
2110           vry=scalar(uy(1,j),erij)
2111           vrz=scalar(uz(1,j),erij)
2112           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2113           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2114           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2115           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2116 C For diagnostics only
2117 cd          a22=1.0d0
2118 cd          a23=1.0d0
2119 cd          a32=1.0d0
2120 cd          a33=1.0d0
2121           fac=dsqrt(-ael6i)*r3ij
2122 cd          write (2,*) 'fac=',fac
2123 C For diagnostics only
2124 cd          fac=1.0d0
2125           a22=a22*fac
2126           a23=a23*fac
2127           a32=a32*fac
2128           a33=a33*fac
2129 cd          write (iout,'(4i5,4f10.5)')
2130 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2131 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2132 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2133 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2134 cd          write (iout,'(4f10.5)')
2135 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2136 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2137 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2138 cd           write (iout,'(2i3,9f10.5/)') i,j,
2139 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2140           if (calc_grad) then
2141 C Derivatives of the elements of A in virtual-bond vectors
2142           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2143 cd          do k=1,3
2144 cd            do l=1,3
2145 cd              erder(k,l)=0.0d0
2146 cd            enddo
2147 cd          enddo
2148           do k=1,3
2149             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2150             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2151             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2152             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2153             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2154             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2155             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2156             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2157             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2158             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2159             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2160             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2161           enddo
2162 cd          do k=1,3
2163 cd            do l=1,3
2164 cd              uryg(k,l)=0.0d0
2165 cd              urzg(k,l)=0.0d0
2166 cd              vryg(k,l)=0.0d0
2167 cd              vrzg(k,l)=0.0d0
2168 cd            enddo
2169 cd          enddo
2170 C Compute radial contributions to the gradient
2171           facr=-3.0d0*rrmij
2172           a22der=a22*facr
2173           a23der=a23*facr
2174           a32der=a32*facr
2175           a33der=a33*facr
2176 cd          a22der=0.0d0
2177 cd          a23der=0.0d0
2178 cd          a32der=0.0d0
2179 cd          a33der=0.0d0
2180           agg(1,1)=a22der*xj
2181           agg(2,1)=a22der*yj
2182           agg(3,1)=a22der*zj
2183           agg(1,2)=a23der*xj
2184           agg(2,2)=a23der*yj
2185           agg(3,2)=a23der*zj
2186           agg(1,3)=a32der*xj
2187           agg(2,3)=a32der*yj
2188           agg(3,3)=a32der*zj
2189           agg(1,4)=a33der*xj
2190           agg(2,4)=a33der*yj
2191           agg(3,4)=a33der*zj
2192 C Add the contributions coming from er
2193           fac3=-3.0d0*fac
2194           do k=1,3
2195             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2196             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2197             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2198             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2199           enddo
2200           do k=1,3
2201 C Derivatives in DC(i)
2202             ghalf1=0.5d0*agg(k,1)
2203             ghalf2=0.5d0*agg(k,2)
2204             ghalf3=0.5d0*agg(k,3)
2205             ghalf4=0.5d0*agg(k,4)
2206             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2207      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2208             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2209      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2210             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2211      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2212             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2213      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2214 C Derivatives in DC(i+1)
2215             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2216      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2217             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2218      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2219             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2220      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2221             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2222      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2223 C Derivatives in DC(j)
2224             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2226             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2227      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2228             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2230             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2231      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2232 C Derivatives in DC(j+1) or DC(nres-1)
2233             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vryg(k,3)*ury)
2235             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2236      &      -3.0d0*vrzg(k,3)*ury)
2237             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vryg(k,3)*urz)
2239             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2240      &      -3.0d0*vrzg(k,3)*urz)
2241 cd            aggi(k,1)=ghalf1
2242 cd            aggi(k,2)=ghalf2
2243 cd            aggi(k,3)=ghalf3
2244 cd            aggi(k,4)=ghalf4
2245 C Derivatives in DC(i+1)
2246 cd            aggi1(k,1)=agg(k,1)
2247 cd            aggi1(k,2)=agg(k,2)
2248 cd            aggi1(k,3)=agg(k,3)
2249 cd            aggi1(k,4)=agg(k,4)
2250 C Derivatives in DC(j)
2251 cd            aggj(k,1)=ghalf1
2252 cd            aggj(k,2)=ghalf2
2253 cd            aggj(k,3)=ghalf3
2254 cd            aggj(k,4)=ghalf4
2255 C Derivatives in DC(j+1)
2256 cd            aggj1(k,1)=0.0d0
2257 cd            aggj1(k,2)=0.0d0
2258 cd            aggj1(k,3)=0.0d0
2259 cd            aggj1(k,4)=0.0d0
2260             if (j.eq.nres-1 .and. i.lt.j-2) then
2261               do l=1,4
2262                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2263 cd                aggj1(k,l)=agg(k,l)
2264               enddo
2265             endif
2266           enddo
2267           endif
2268 c          goto 11111
2269 C Check the loc-el terms by numerical integration
2270           acipa(1,1)=a22
2271           acipa(1,2)=a23
2272           acipa(2,1)=a32
2273           acipa(2,2)=a33
2274           a22=-a22
2275           a23=-a23
2276           do l=1,2
2277             do k=1,3
2278               agg(k,l)=-agg(k,l)
2279               aggi(k,l)=-aggi(k,l)
2280               aggi1(k,l)=-aggi1(k,l)
2281               aggj(k,l)=-aggj(k,l)
2282               aggj1(k,l)=-aggj1(k,l)
2283             enddo
2284           enddo
2285           if (j.lt.nres-1) then
2286             a22=-a22
2287             a32=-a32
2288             do l=1,3,2
2289               do k=1,3
2290                 agg(k,l)=-agg(k,l)
2291                 aggi(k,l)=-aggi(k,l)
2292                 aggi1(k,l)=-aggi1(k,l)
2293                 aggj(k,l)=-aggj(k,l)
2294                 aggj1(k,l)=-aggj1(k,l)
2295               enddo
2296             enddo
2297           else
2298             a22=-a22
2299             a23=-a23
2300             a32=-a32
2301             a33=-a33
2302             do l=1,4
2303               do k=1,3
2304                 agg(k,l)=-agg(k,l)
2305                 aggi(k,l)=-aggi(k,l)
2306                 aggi1(k,l)=-aggi1(k,l)
2307                 aggj(k,l)=-aggj(k,l)
2308                 aggj1(k,l)=-aggj1(k,l)
2309               enddo
2310             enddo
2311           endif
2312           ENDIF ! WCORR
2313 11111     continue
2314           IF (wel_loc.gt.0.0d0) THEN
2315 C Contribution to the local-electrostatic energy coming from the i-j pair
2316           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2317      &     +a33*muij(4)
2318 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2319 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2320           eel_loc=eel_loc+eel_loc_ij
2321 C Partial derivatives in virtual-bond dihedral angles gamma
2322           if (calc_grad) then
2323           if (i.gt.1)
2324      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2325      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2326      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2327           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2328      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2329      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2330 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2331 cd          write(iout,*) 'agg  ',agg
2332 cd          write(iout,*) 'aggi ',aggi
2333 cd          write(iout,*) 'aggi1',aggi1
2334 cd          write(iout,*) 'aggj ',aggj
2335 cd          write(iout,*) 'aggj1',aggj1
2336
2337 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2338           do l=1,3
2339             ggg(l)=agg(l,1)*muij(1)+
2340      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2341           enddo
2342           do k=i+2,j2
2343             do l=1,3
2344               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2345             enddo
2346           enddo
2347 C Remaining derivatives of eello
2348           do l=1,3
2349             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2350      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2351             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2352      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2353             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2354      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2355             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2356      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2357           enddo
2358           endif
2359           ENDIF
2360           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2361 C Contributions from turns
2362             a_temp(1,1)=a22
2363             a_temp(1,2)=a23
2364             a_temp(2,1)=a32
2365             a_temp(2,2)=a33
2366             call eturn34(i,j,eello_turn3,eello_turn4)
2367           endif
2368 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2369           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2370 C
2371 C Calculate the contact function. The ith column of the array JCONT will
2372 C contain the numbers of atoms that make contacts with the atom I (of numbers
2373 C greater than I). The arrays FACONT and GACONT will contain the values of
2374 C the contact function and its derivative.
2375 c           r0ij=1.02D0*rpp(iteli,itelj)
2376 c           r0ij=1.11D0*rpp(iteli,itelj)
2377             r0ij=2.20D0*rpp(iteli,itelj)
2378 c           r0ij=1.55D0*rpp(iteli,itelj)
2379             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2380             if (fcont.gt.0.0D0) then
2381               num_conti=num_conti+1
2382               if (num_conti.gt.maxconts) then
2383                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2384      &                         ' will skip next contacts for this conf.'
2385               else
2386                 jcont_hb(num_conti,i)=j
2387                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2388      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2389 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2390 C  terms.
2391                 d_cont(num_conti,i)=rij
2392 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2393 C     --- Electrostatic-interaction matrix ---
2394                 a_chuj(1,1,num_conti,i)=a22
2395                 a_chuj(1,2,num_conti,i)=a23
2396                 a_chuj(2,1,num_conti,i)=a32
2397                 a_chuj(2,2,num_conti,i)=a33
2398 C     --- Gradient of rij
2399                 do kkk=1,3
2400                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2401                 enddo
2402 c             if (i.eq.1) then
2403 c                a_chuj(1,1,num_conti,i)=-0.61d0
2404 c                a_chuj(1,2,num_conti,i)= 0.4d0
2405 c                a_chuj(2,1,num_conti,i)= 0.65d0
2406 c                a_chuj(2,2,num_conti,i)= 0.50d0
2407 c             else if (i.eq.2) then
2408 c                a_chuj(1,1,num_conti,i)= 0.0d0
2409 c                a_chuj(1,2,num_conti,i)= 0.0d0
2410 c                a_chuj(2,1,num_conti,i)= 0.0d0
2411 c                a_chuj(2,2,num_conti,i)= 0.0d0
2412 c             endif
2413 C     --- and its gradients
2414 cd                write (iout,*) 'i',i,' j',j
2415 cd                do kkk=1,3
2416 cd                write (iout,*) 'iii 1 kkk',kkk
2417 cd                write (iout,*) agg(kkk,:)
2418 cd                enddo
2419 cd                do kkk=1,3
2420 cd                write (iout,*) 'iii 2 kkk',kkk
2421 cd                write (iout,*) aggi(kkk,:)
2422 cd                enddo
2423 cd                do kkk=1,3
2424 cd                write (iout,*) 'iii 3 kkk',kkk
2425 cd                write (iout,*) aggi1(kkk,:)
2426 cd                enddo
2427 cd                do kkk=1,3
2428 cd                write (iout,*) 'iii 4 kkk',kkk
2429 cd                write (iout,*) aggj(kkk,:)
2430 cd                enddo
2431 cd                do kkk=1,3
2432 cd                write (iout,*) 'iii 5 kkk',kkk
2433 cd                write (iout,*) aggj1(kkk,:)
2434 cd                enddo
2435                 kkll=0
2436                 do k=1,2
2437                   do l=1,2
2438                     kkll=kkll+1
2439                     do m=1,3
2440                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2441                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2442                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2443                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2444                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2445 c                      do mm=1,5
2446 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2447 c                      enddo
2448                     enddo
2449                   enddo
2450                 enddo
2451                 ENDIF
2452                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2453 C Calculate contact energies
2454                 cosa4=4.0D0*cosa
2455                 wij=cosa-3.0D0*cosb*cosg
2456                 cosbg1=cosb+cosg
2457                 cosbg2=cosb-cosg
2458 c               fac3=dsqrt(-ael6i)/r0ij**3
2459                 fac3=dsqrt(-ael6i)*r3ij
2460                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2461                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2462 c               ees0mij=0.0D0
2463                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2464                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2465 C Diagnostics. Comment out or remove after debugging!
2466 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2467 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2468 c               ees0m(num_conti,i)=0.0D0
2469 C End diagnostics.
2470 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2471 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2472                 facont_hb(num_conti,i)=fcont
2473                 if (calc_grad) then
2474 C Angular derivatives of the contact function
2475                 ees0pij1=fac3/ees0pij
2476                 ees0mij1=fac3/ees0mij
2477                 fac3p=-3.0D0*fac3*rrmij
2478                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2479                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2480 c               ees0mij1=0.0D0
2481                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2482                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2483                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2484                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2485                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2486                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2487                 ecosap=ecosa1+ecosa2
2488                 ecosbp=ecosb1+ecosb2
2489                 ecosgp=ecosg1+ecosg2
2490                 ecosam=ecosa1-ecosa2
2491                 ecosbm=ecosb1-ecosb2
2492                 ecosgm=ecosg1-ecosg2
2493 C Diagnostics
2494 c               ecosap=ecosa1
2495 c               ecosbp=ecosb1
2496 c               ecosgp=ecosg1
2497 c               ecosam=0.0D0
2498 c               ecosbm=0.0D0
2499 c               ecosgm=0.0D0
2500 C End diagnostics
2501                 fprimcont=fprimcont/rij
2502 cd              facont_hb(num_conti,i)=1.0D0
2503 C Following line is for diagnostics.
2504 cd              fprimcont=0.0D0
2505                 do k=1,3
2506                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2507                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2508                 enddo
2509                 do k=1,3
2510                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2511                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2512                 enddo
2513                 gggp(1)=gggp(1)+ees0pijp*xj
2514                 gggp(2)=gggp(2)+ees0pijp*yj
2515                 gggp(3)=gggp(3)+ees0pijp*zj
2516                 gggm(1)=gggm(1)+ees0mijp*xj
2517                 gggm(2)=gggm(2)+ees0mijp*yj
2518                 gggm(3)=gggm(3)+ees0mijp*zj
2519 C Derivatives due to the contact function
2520                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2521                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2522                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2523                 do k=1,3
2524                   ghalfp=0.5D0*gggp(k)
2525                   ghalfm=0.5D0*gggm(k)
2526                   gacontp_hb1(k,num_conti,i)=ghalfp
2527      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2528      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2529                   gacontp_hb2(k,num_conti,i)=ghalfp
2530      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2531      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2532                   gacontp_hb3(k,num_conti,i)=gggp(k)
2533                   gacontm_hb1(k,num_conti,i)=ghalfm
2534      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2535      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2536                   gacontm_hb2(k,num_conti,i)=ghalfm
2537      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2538      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2539                   gacontm_hb3(k,num_conti,i)=gggm(k)
2540                 enddo
2541                 endif
2542 C Diagnostics. Comment out or remove after debugging!
2543 cdiag           do k=1,3
2544 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2545 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2546 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2548 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2549 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2550 cdiag           enddo
2551               ENDIF ! wcorr
2552               endif  ! num_conti.le.maxconts
2553             endif  ! fcont.gt.0
2554           endif    ! j.gt.i+1
2555  1216     continue
2556         enddo ! j
2557         num_cont_hb(i)=num_conti
2558  1215   continue
2559       enddo   ! i
2560 cd      do i=1,nres
2561 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2562 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2563 cd      enddo
2564 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2565 ccc      eel_loc=eel_loc+eello_turn3
2566       return
2567       end
2568 C-----------------------------------------------------------------------------
2569       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2570 C Third- and fourth-order contributions from turns
2571       implicit real*8 (a-h,o-z)
2572       include 'DIMENSIONS'
2573       include 'DIMENSIONS.ZSCOPT'
2574       include 'COMMON.IOUNITS'
2575       include 'COMMON.GEO'
2576       include 'COMMON.VAR'
2577       include 'COMMON.LOCAL'
2578       include 'COMMON.CHAIN'
2579       include 'COMMON.DERIV'
2580       include 'COMMON.INTERACT'
2581       include 'COMMON.CONTACTS'
2582       include 'COMMON.TORSION'
2583       include 'COMMON.VECTORS'
2584       include 'COMMON.FFIELD'
2585       dimension ggg(3)
2586       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2587      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2588      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2589       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2590      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2591       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2592       if (j.eq.i+2) then
2593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2594 C
2595 C               Third-order contributions
2596 C
2597 C                 (i+2)o----(i+3)
2598 C                      | |
2599 C                      | |
2600 C                 (i+1)o----i
2601 C
2602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2603 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2604         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2605         call transpose2(auxmat(1,1),auxmat1(1,1))
2606         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2607         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2608 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2609 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2610 cd     &    ' eello_turn3_num',4*eello_turn3_num
2611         if (calc_grad) then
2612 C Derivatives in gamma(i)
2613         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2614         call transpose2(auxmat2(1,1),pizda(1,1))
2615         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2616         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2617 C Derivatives in gamma(i+1)
2618         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2619         call transpose2(auxmat2(1,1),pizda(1,1))
2620         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2621         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2622      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2623 C Cartesian derivatives
2624         do l=1,3
2625           a_temp(1,1)=aggi(l,1)
2626           a_temp(1,2)=aggi(l,2)
2627           a_temp(2,1)=aggi(l,3)
2628           a_temp(2,2)=aggi(l,4)
2629           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2630           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2631      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2632           a_temp(1,1)=aggi1(l,1)
2633           a_temp(1,2)=aggi1(l,2)
2634           a_temp(2,1)=aggi1(l,3)
2635           a_temp(2,2)=aggi1(l,4)
2636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2637           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2639           a_temp(1,1)=aggj(l,1)
2640           a_temp(1,2)=aggj(l,2)
2641           a_temp(2,1)=aggj(l,3)
2642           a_temp(2,2)=aggj(l,4)
2643           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2644           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2645      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2646           a_temp(1,1)=aggj1(l,1)
2647           a_temp(1,2)=aggj1(l,2)
2648           a_temp(2,1)=aggj1(l,3)
2649           a_temp(2,2)=aggj1(l,4)
2650           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2651           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2652      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2653         enddo
2654         endif
2655       else if (j.eq.i+3) then
2656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2657 C
2658 C               Fourth-order contributions
2659 C
2660 C                 (i+3)o----(i+4)
2661 C                     /  |
2662 C               (i+2)o   |
2663 C                     \  |
2664 C                 (i+1)o----i
2665 C
2666 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2667 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2668         iti1=itortyp(itype(i+1))
2669         iti2=itortyp(itype(i+2))
2670         iti3=itortyp(itype(i+3))
2671         call transpose2(EUg(1,1,i+1),e1t(1,1))
2672         call transpose2(Eug(1,1,i+2),e2t(1,1))
2673         call transpose2(Eug(1,1,i+3),e3t(1,1))
2674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2676         s1=scalar2(b1(1,iti2),auxvec(1))
2677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2679         s2=scalar2(b1(1,iti1),auxvec(1))
2680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2683         eello_turn4=eello_turn4-(s1+s2+s3)
2684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2685 cd     &    ' eello_turn4_num',8*eello_turn4_num
2686 C Derivatives in gamma(i)
2687         if (calc_grad) then
2688         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2689         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2690         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2691         s1=scalar2(b1(1,iti2),auxvec(1))
2692         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2693         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2694         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2695 C Derivatives in gamma(i+1)
2696         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2697         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2698         s2=scalar2(b1(1,iti1),auxvec(1))
2699         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2700         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2702         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2703 C Derivatives in gamma(i+2)
2704         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2705         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2706         s1=scalar2(b1(1,iti2),auxvec(1))
2707         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2708         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2709         s2=scalar2(b1(1,iti1),auxvec(1))
2710         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2711         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2712         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2713         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2714 C Cartesian derivatives
2715 C Derivatives of this turn contributions in DC(i+2)
2716         if (j.lt.nres-1) then
2717           do l=1,3
2718             a_temp(1,1)=agg(l,1)
2719             a_temp(1,2)=agg(l,2)
2720             a_temp(2,1)=agg(l,3)
2721             a_temp(2,2)=agg(l,4)
2722             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2723             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2724             s1=scalar2(b1(1,iti2),auxvec(1))
2725             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2726             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2727             s2=scalar2(b1(1,iti1),auxvec(1))
2728             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2729             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2730             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2731             ggg(l)=-(s1+s2+s3)
2732             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2733           enddo
2734         endif
2735 C Remaining derivatives of this turn contribution
2736         do l=1,3
2737           a_temp(1,1)=aggi(l,1)
2738           a_temp(1,2)=aggi(l,2)
2739           a_temp(2,1)=aggi(l,3)
2740           a_temp(2,2)=aggi(l,4)
2741           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2742           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2743           s1=scalar2(b1(1,iti2),auxvec(1))
2744           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2745           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2746           s2=scalar2(b1(1,iti1),auxvec(1))
2747           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2748           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2749           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2750           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2751           a_temp(1,1)=aggi1(l,1)
2752           a_temp(1,2)=aggi1(l,2)
2753           a_temp(2,1)=aggi1(l,3)
2754           a_temp(2,2)=aggi1(l,4)
2755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2757           s1=scalar2(b1(1,iti2),auxvec(1))
2758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2760           s2=scalar2(b1(1,iti1),auxvec(1))
2761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2765           a_temp(1,1)=aggj(l,1)
2766           a_temp(1,2)=aggj(l,2)
2767           a_temp(2,1)=aggj(l,3)
2768           a_temp(2,2)=aggj(l,4)
2769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2771           s1=scalar2(b1(1,iti2),auxvec(1))
2772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2774           s2=scalar2(b1(1,iti1),auxvec(1))
2775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2778           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2779           a_temp(1,1)=aggj1(l,1)
2780           a_temp(1,2)=aggj1(l,2)
2781           a_temp(2,1)=aggj1(l,3)
2782           a_temp(2,2)=aggj1(l,4)
2783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2785           s1=scalar2(b1(1,iti2),auxvec(1))
2786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2788           s2=scalar2(b1(1,iti1),auxvec(1))
2789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2792           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2793         enddo
2794         endif
2795       endif
2796       return
2797       end
2798 C-----------------------------------------------------------------------------
2799       subroutine vecpr(u,v,w)
2800       implicit real*8(a-h,o-z)
2801       dimension u(3),v(3),w(3)
2802       w(1)=u(2)*v(3)-u(3)*v(2)
2803       w(2)=-u(1)*v(3)+u(3)*v(1)
2804       w(3)=u(1)*v(2)-u(2)*v(1)
2805       return
2806       end
2807 C-----------------------------------------------------------------------------
2808       subroutine unormderiv(u,ugrad,unorm,ungrad)
2809 C This subroutine computes the derivatives of a normalized vector u, given
2810 C the derivatives computed without normalization conditions, ugrad. Returns
2811 C ungrad.
2812       implicit none
2813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2814       double precision vec(3)
2815       double precision scalar
2816       integer i,j
2817 c      write (2,*) 'ugrad',ugrad
2818 c      write (2,*) 'u',u
2819       do i=1,3
2820         vec(i)=scalar(ugrad(1,i),u(1))
2821       enddo
2822 c      write (2,*) 'vec',vec
2823       do i=1,3
2824         do j=1,3
2825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2826         enddo
2827       enddo
2828 c      write (2,*) 'ungrad',ungrad
2829       return
2830       end
2831 C-----------------------------------------------------------------------------
2832       subroutine escp(evdw2,evdw2_14)
2833 C
2834 C This subroutine calculates the excluded-volume interaction energy between
2835 C peptide-group centers and side chains and its gradient in virtual-bond and
2836 C side-chain vectors.
2837 C
2838       implicit real*8 (a-h,o-z)
2839       include 'DIMENSIONS'
2840       include 'DIMENSIONS.ZSCOPT'
2841       include 'COMMON.GEO'
2842       include 'COMMON.VAR'
2843       include 'COMMON.LOCAL'
2844       include 'COMMON.CHAIN'
2845       include 'COMMON.DERIV'
2846       include 'COMMON.INTERACT'
2847       include 'COMMON.FFIELD'
2848       include 'COMMON.IOUNITS'
2849       dimension ggg(3)
2850       evdw2=0.0D0
2851       evdw2_14=0.0d0
2852 cd    print '(a)','Enter ESCP'
2853 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2854 c     &  ' scal14',scal14
2855       do i=iatscp_s,iatscp_e
2856         iteli=itel(i)
2857 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2858 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2859         if (iteli.eq.0) goto 1225
2860         xi=0.5D0*(c(1,i)+c(1,i+1))
2861         yi=0.5D0*(c(2,i)+c(2,i+1))
2862         zi=0.5D0*(c(3,i)+c(3,i+1))
2863
2864         do iint=1,nscp_gr(i)
2865
2866         do j=iscpstart(i,iint),iscpend(i,iint)
2867           itypj=itype(j)
2868 C Uncomment following three lines for SC-p interactions
2869 c         xj=c(1,nres+j)-xi
2870 c         yj=c(2,nres+j)-yi
2871 c         zj=c(3,nres+j)-zi
2872 C Uncomment following three lines for Ca-p interactions
2873           xj=c(1,j)-xi
2874           yj=c(2,j)-yi
2875           zj=c(3,j)-zi
2876           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2877           fac=rrij**expon2
2878           e1=fac*fac*aad(itypj,iteli)
2879           e2=fac*bad(itypj,iteli)
2880           if (iabs(j-i) .le. 2) then
2881             e1=scal14*e1
2882             e2=scal14*e2
2883             evdw2_14=evdw2_14+e1+e2
2884           endif
2885           evdwij=e1+e2
2886 c          write (iout,*) i,j,evdwij
2887           evdw2=evdw2+evdwij
2888           if (calc_grad) then
2889 C
2890 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2891 C
2892           fac=-(evdwij+e1)*rrij
2893           ggg(1)=xj*fac
2894           ggg(2)=yj*fac
2895           ggg(3)=zj*fac
2896           if (j.lt.i) then
2897 cd          write (iout,*) 'j<i'
2898 C Uncomment following three lines for SC-p interactions
2899 c           do k=1,3
2900 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2901 c           enddo
2902           else
2903 cd          write (iout,*) 'j>i'
2904             do k=1,3
2905               ggg(k)=-ggg(k)
2906 C Uncomment following line for SC-p interactions
2907 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2908             enddo
2909           endif
2910           do k=1,3
2911             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2912           enddo
2913           kstart=min0(i+1,j)
2914           kend=max0(i-1,j-1)
2915 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2916 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2917           do k=kstart,kend
2918             do l=1,3
2919               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2920             enddo
2921           enddo
2922           endif
2923         enddo
2924         enddo ! iint
2925  1225   continue
2926       enddo ! i
2927       do i=1,nct
2928         do j=1,3
2929           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2930           gradx_scp(j,i)=expon*gradx_scp(j,i)
2931         enddo
2932       enddo
2933 C******************************************************************************
2934 C
2935 C                              N O T E !!!
2936 C
2937 C To save time the factor EXPON has been extracted from ALL components
2938 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2939 C use!
2940 C
2941 C******************************************************************************
2942       return
2943       end
2944 C--------------------------------------------------------------------------
2945       subroutine edis(ehpb)
2946 C
2947 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2948 C
2949       implicit real*8 (a-h,o-z)
2950       include 'DIMENSIONS'
2951       include 'DIMENSIONS.FREE'
2952       include 'COMMON.SBRIDGE'
2953       include 'COMMON.CHAIN'
2954       include 'COMMON.DERIV'
2955       include 'COMMON.VAR'
2956       include 'COMMON.INTERACT'
2957       include 'COMMON.IOUNITS'
2958       include 'COMMON.CONTROL'
2959       dimension ggg(3)
2960       ehpb=0.0D0
2961 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2962 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2963       if (link_end.eq.0) return
2964       do i=link_start,link_end
2965 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2966 C CA-CA distance used in regularization of structure.
2967         ii=ihpb(i)
2968         jj=jhpb(i)
2969 C iii and jjj point to the residues for which the distance is assigned.
2970         if (ii.gt.nres) then
2971           iii=ii-nres
2972           jjj=jj-nres
2973         else
2974           iii=ii
2975           jjj=jj
2976         endif
2977 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2978 c     &    dhpb(i),dhpb1(i),forcon(i)
2979 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2980 C    distance and angle dependent SS bond potential.
2981         if (.not.dyn_ss .and. i.le.nss) then
2982 C 15/02/13 CC dynamic SSbond - additional check
2983         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2984           call ssbond_ene(iii,jjj,eij)
2985           ehpb=ehpb+2*eij
2986          endif
2987 cd          write (iout,*) "eij",eij
2988         else if (ii.gt.nres .and. jj.gt.nres) then
2989 c Restraints from contact prediction
2990           dd=dist(ii,jj)
2991          if (constr_dist.eq.11) then
2992             ehpb=ehpb+fordepth(i)**4.0d0
2993      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2994             fac=fordepth(i)**4.0d0
2995      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2996          else
2997           if (dhpb1(i).gt.0.0d0) then
2998             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2999             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3000 c            write (iout,*) "beta nmr",
3001 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3002           else
3003             dd=dist(ii,jj)
3004             rdis=dd-dhpb(i)
3005 C Get the force constant corresponding to this distance.
3006             waga=forcon(i)
3007 C Calculate the contribution to energy.
3008             ehpb=ehpb+waga*rdis*rdis
3009 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3010 C
3011 C Evaluate gradient.
3012 C
3013             fac=waga*rdis/dd
3014           endif !end dhpb1(i).gt.0
3015          endif !end const_dist=11
3016           do j=1,3
3017             ggg(j)=fac*(c(j,jj)-c(j,ii))
3018           enddo
3019           do j=1,3
3020             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3021             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3022           enddo
3023           do k=1,3
3024             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3025             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3026           enddo
3027         else
3028 C Calculate the distance between the two points and its difference from the
3029 C target distance.
3030           dd=dist(ii,jj)
3031 C          write(iout,*) "after",dd
3032           if (constr_dist.eq.11) then
3033             ehpb=ehpb+fordepth(i)**4.0d0
3034      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3035             fac=fordepth(i)**4.0d0
3036      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3037 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3038 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3039 C            print *,ehpb,"tu?"
3040 C            write(iout,*) ehpb,"btu?",
3041 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3042 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3043 C     &    ehpb,fordepth(i),dd
3044            else
3045           if (dhpb1(i).gt.0.0d0) then
3046             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3047             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3048 c            write (iout,*) "alph nmr",
3049 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3050           else
3051             rdis=dd-dhpb(i)
3052 C Get the force constant corresponding to this distance.
3053             waga=forcon(i)
3054 C Calculate the contribution to energy.
3055             ehpb=ehpb+waga*rdis*rdis
3056 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3057 C
3058 C Evaluate gradient.
3059 C
3060             fac=waga*rdis/dd
3061           endif
3062           endif
3063 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3064 cd   &   ' waga=',waga,' fac=',fac
3065             do j=1,3
3066               ggg(j)=fac*(c(j,jj)-c(j,ii))
3067             enddo
3068 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3069 C If this is a SC-SC distance, we need to calculate the contributions to the
3070 C Cartesian gradient in the SC vectors (ghpbx).
3071           if (iii.lt.ii) then
3072           do j=1,3
3073             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3074             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3075           enddo
3076           endif
3077           do k=1,3
3078             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3079             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3080           enddo
3081         endif
3082       enddo
3083       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3084       return
3085       end
3086 C--------------------------------------------------------------------------
3087       subroutine ssbond_ene(i,j,eij)
3088 C
3089 C Calculate the distance and angle dependent SS-bond potential energy
3090 C using a free-energy function derived based on RHF/6-31G** ab initio
3091 C calculations of diethyl disulfide.
3092 C
3093 C A. Liwo and U. Kozlowska, 11/24/03
3094 C
3095       implicit real*8 (a-h,o-z)
3096       include 'DIMENSIONS'
3097       include 'DIMENSIONS.ZSCOPT'
3098       include 'COMMON.SBRIDGE'
3099       include 'COMMON.CHAIN'
3100       include 'COMMON.DERIV'
3101       include 'COMMON.LOCAL'
3102       include 'COMMON.INTERACT'
3103       include 'COMMON.VAR'
3104       include 'COMMON.IOUNITS'
3105       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3106       itypi=itype(i)
3107       xi=c(1,nres+i)
3108       yi=c(2,nres+i)
3109       zi=c(3,nres+i)
3110       dxi=dc_norm(1,nres+i)
3111       dyi=dc_norm(2,nres+i)
3112       dzi=dc_norm(3,nres+i)
3113       dsci_inv=dsc_inv(itypi)
3114       itypj=itype(j)
3115       dscj_inv=dsc_inv(itypj)
3116       xj=c(1,nres+j)-xi
3117       yj=c(2,nres+j)-yi
3118       zj=c(3,nres+j)-zi
3119       dxj=dc_norm(1,nres+j)
3120       dyj=dc_norm(2,nres+j)
3121       dzj=dc_norm(3,nres+j)
3122       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3123       rij=dsqrt(rrij)
3124       erij(1)=xj*rij
3125       erij(2)=yj*rij
3126       erij(3)=zj*rij
3127       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3128       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3129       om12=dxi*dxj+dyi*dyj+dzi*dzj
3130       do k=1,3
3131         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3132         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3133       enddo
3134       rij=1.0d0/rij
3135       deltad=rij-d0cm
3136       deltat1=1.0d0-om1
3137       deltat2=1.0d0+om2
3138       deltat12=om2-om1+2.0d0
3139       cosphi=om12-om1*om2
3140       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3141      &  +akct*deltad*deltat12+ebr
3142 c     &  +akct*deltad*deltat12
3143      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3144       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3145      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3146      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3147       ed=2*akcm*deltad+akct*deltat12
3148       pom1=akct*deltad
3149       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3150       eom1=-2*akth*deltat1-pom1-om2*pom2
3151       eom2= 2*akth*deltat2+pom1-om1*pom2
3152       eom12=pom2
3153       do k=1,3
3154         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3155       enddo
3156       do k=1,3
3157         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3158      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3159         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3160      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3161       enddo
3162 C
3163 C Calculate the components of the gradient in DC and X
3164 C
3165       do k=i,j-1
3166         do l=1,3
3167           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3168         enddo
3169       enddo
3170       return
3171       end
3172 C--------------------------------------------------------------------------
3173 c MODELLER restraint function
3174       subroutine e_modeller(ehomology_constr)
3175       implicit real*8 (a-h,o-z)
3176       include 'DIMENSIONS'
3177       include 'DIMENSIONS.ZSCOPT'
3178       include 'DIMENSIONS.FREE'
3179       integer nnn, i, j, k, ki, irec, l
3180       integer katy, odleglosci, test7
3181       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3182       real*8 distance(max_template),distancek(max_template),
3183      &    min_odl,godl(max_template),dih_diff(max_template)
3184
3185 c
3186 c     FP - 30/10/2014 Temporary specifications for homology restraints
3187 c
3188       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3189      &                 sgtheta
3190       double precision, dimension (maxres) :: guscdiff,usc_diff
3191       double precision, dimension (max_template) ::
3192      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3193      &           theta_diff
3194
3195       include 'COMMON.SBRIDGE'
3196       include 'COMMON.CHAIN'
3197       include 'COMMON.GEO'
3198       include 'COMMON.DERIV'
3199       include 'COMMON.LOCAL'
3200       include 'COMMON.INTERACT'
3201       include 'COMMON.VAR'
3202       include 'COMMON.IOUNITS'
3203       include 'COMMON.CONTROL'
3204       include 'COMMON.HOMRESTR'
3205 c
3206       include 'COMMON.SETUP'
3207       include 'COMMON.NAMES'
3208
3209       do i=1,max_template
3210         distancek(i)=9999999.9
3211       enddo
3212
3213       odleg=0.0d0
3214
3215 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3216 c function)
3217 C AL 5/2/14 - Introduce list of restraints
3218 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3219 #ifdef DEBUG
3220       write(iout,*) "------- dist restrs start -------"
3221 #endif
3222       do ii = link_start_homo,link_end_homo
3223          i = ires_homo(ii)
3224          j = jres_homo(ii)
3225          dij=dist(i,j)
3226 c        write (iout,*) "dij(",i,j,") =",dij
3227          nexl=0
3228          do k=1,constr_homology
3229            if(.not.l_homo(k,ii)) then
3230               nexl=nexl+1
3231               cycle
3232            endif
3233            distance(k)=odl(k,ii)-dij
3234 c          write (iout,*) "distance(",k,") =",distance(k)
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3239 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3240 c          write (iout,*) "distancek(",k,") =",distancek(k)
3241 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3242 c
3243 c          For Lorentzian-type Urestr
3244 c
3245            if (waga_dist.lt.0.0d0) then
3246               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3247               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3248      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3249            endif
3250          enddo
3251
3252 c         min_odl=minval(distancek)
3253          do kk=1,constr_homology
3254           if(l_homo(kk,ii)) then
3255             min_odl=distancek(kk)
3256             exit
3257           endif
3258          enddo
3259          do kk=1,constr_homology
3260           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3261      &              min_odl=distancek(kk)
3262          enddo
3263 c        write (iout,* )"min_odl",min_odl
3264 #ifdef DEBUG
3265          write (iout,*) "ij dij",i,j,dij
3266          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3267          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3268          write (iout,* )"min_odl",min_odl
3269 #endif
3270 #ifdef OLDRESTR
3271          odleg2=0.0d0
3272 #else
3273          if (waga_dist.ge.0.0d0) then
3274            odleg2=nexl
3275          else
3276            odleg2=0.0d0
3277          endif
3278 #endif
3279          do k=1,constr_homology
3280 c Nie wiem po co to liczycie jeszcze raz!
3281 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3282 c     &              (2*(sigma_odl(i,j,k))**2))
3283            if(.not.l_homo(k,ii)) cycle
3284            if (waga_dist.ge.0.0d0) then
3285 c
3286 c          For Gaussian-type Urestr
3287 c
3288             godl(k)=dexp(-distancek(k)+min_odl)
3289             odleg2=odleg2+godl(k)
3290 c
3291 c          For Lorentzian-type Urestr
3292 c
3293            else
3294             odleg2=odleg2+distancek(k)
3295            endif
3296
3297 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3298 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3299 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3300 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3301
3302          enddo
3303 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3304 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3305 #ifdef DEBUG
3306          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3307          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3308 #endif
3309            if (waga_dist.ge.0.0d0) then
3310 c
3311 c          For Gaussian-type Urestr
3312 c
3313               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3314 c
3315 c          For Lorentzian-type Urestr
3316 c
3317            else
3318               odleg=odleg+odleg2/constr_homology
3319            endif
3320 c
3321 #ifdef GRAD
3322 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3323 c Gradient
3324 c
3325 c          For Gaussian-type Urestr
3326 c
3327          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3328          sum_sgodl=0.0d0
3329          do k=1,constr_homology
3330 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3331 c     &           *waga_dist)+min_odl
3332 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3333 c
3334          if(.not.l_homo(k,ii)) cycle
3335          if (waga_dist.ge.0.0d0) then
3336 c          For Gaussian-type Urestr
3337 c
3338            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3339 c
3340 c          For Lorentzian-type Urestr
3341 c
3342          else
3343            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3344      &           sigma_odlir(k,ii)**2)**2)
3345          endif
3346            sum_sgodl=sum_sgodl+sgodl
3347
3348 c            sgodl2=sgodl2+sgodl
3349 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3350 c      write(iout,*) "constr_homology=",constr_homology
3351 c      write(iout,*) i, j, k, "TEST K"
3352          enddo
3353          if (waga_dist.ge.0.0d0) then
3354 c
3355 c          For Gaussian-type Urestr
3356 c
3357             grad_odl3=waga_homology(iset)*waga_dist
3358      &                *sum_sgodl/(sum_godl*dij)
3359 c
3360 c          For Lorentzian-type Urestr
3361 c
3362          else
3363 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3364 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3365             grad_odl3=-waga_homology(iset)*waga_dist*
3366      &                sum_sgodl/(constr_homology*dij)
3367          endif
3368 c
3369 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3370
3371
3372 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3373 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3374 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3375
3376 ccc      write(iout,*) godl, sgodl, grad_odl3
3377
3378 c          grad_odl=grad_odl+grad_odl3
3379
3380          do jik=1,3
3381             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3382 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3383 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3384 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3385             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3386             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3387 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3388 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3389 c         if (i.eq.25.and.j.eq.27) then
3390 c         write(iout,*) "jik",jik,"i",i,"j",j
3391 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3392 c         write(iout,*) "grad_odl3",grad_odl3
3393 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3394 c         write(iout,*) "ggodl",ggodl
3395 c         write(iout,*) "ghpbc(",jik,i,")",
3396 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3397 c     &                 ghpbc(jik,j)
3398 c         endif
3399          enddo
3400 #endif
3401 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3402 ccc     & dLOG(odleg2),"-odleg=", -odleg
3403
3404       enddo ! ii-loop for dist
3405 #ifdef DEBUG
3406       write(iout,*) "------- dist restrs end -------"
3407 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3408 c    &     waga_d.eq.1.0d0) call sum_gradient
3409 #endif
3410 c Pseudo-energy and gradient from dihedral-angle restraints from
3411 c homology templates
3412 c      write (iout,*) "End of distance loop"
3413 c      call flush(iout)
3414       kat=0.0d0
3415 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3416 #ifdef DEBUG
3417       write(iout,*) "------- dih restrs start -------"
3418       do i=idihconstr_start_homo,idihconstr_end_homo
3419         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3420       enddo
3421 #endif
3422       do i=idihconstr_start_homo,idihconstr_end_homo
3423 #ifdef OLDRESTR
3424         kat2=0.0d0
3425 #else
3426         kat2=nexl
3427 #endif
3428 c        betai=beta(i,i+1,i+2,i+3)
3429         betai = phi(i)
3430 c       write (iout,*) "betai =",betai
3431         do k=1,constr_homology
3432           dih_diff(k)=pinorm(dih(k,i)-betai)
3433 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3434 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3435 c     &                                   -(6.28318-dih_diff(i,k))
3436 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3437 c     &                                   6.28318+dih_diff(i,k)
3438
3439           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3440 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3441           gdih(k)=dexp(kat3)
3442           kat2=kat2+gdih(k)
3443 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3444 c          write(*,*)""
3445         enddo
3446 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3447 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3448 #ifdef DEBUG
3449         write (iout,*) "i",i," betai",betai," kat2",kat2
3450         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3451 #endif
3452         if (kat2.le.1.0d-14) cycle
3453         kat=kat-dLOG(kat2/constr_homology)
3454 c       write (iout,*) "kat",kat ! sum of -ln-s
3455
3456 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3457 ccc     & dLOG(kat2), "-kat=", -kat
3458
3459 #ifdef GRAD
3460 c ----------------------------------------------------------------------
3461 c Gradient
3462 c ----------------------------------------------------------------------
3463
3464         sum_gdih=kat2
3465         sum_sgdih=0.0d0
3466         do k=1,constr_homology
3467           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3468 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3469           sum_sgdih=sum_sgdih+sgdih
3470         enddo
3471 c       grad_dih3=sum_sgdih/sum_gdih
3472         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3473
3474 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3475 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3476 ccc     & gloc(nphi+i-3,icg)
3477         gloc(i,icg)=gloc(i,icg)+grad_dih3
3478 c        if (i.eq.25) then
3479 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3480 c        endif
3481 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3482 ccc     & gloc(nphi+i-3,icg)
3483 #endif
3484       enddo ! i-loop for dih
3485 #ifdef DEBUG
3486       write(iout,*) "------- dih restrs end -------"
3487 #endif
3488
3489 c Pseudo-energy and gradient for theta angle restraints from
3490 c homology templates
3491 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3492 c adapted
3493
3494 c
3495 c     For constr_homology reference structures (FP)
3496 c
3497 c     Uconst_back_tot=0.0d0
3498       Eval=0.0d0
3499       Erot=0.0d0
3500 c     Econstr_back legacy
3501 #ifdef GRAD
3502       do i=1,nres
3503 c     do i=ithet_start,ithet_end
3504        dutheta(i)=0.0d0
3505 c     enddo
3506 c     do i=loc_start,loc_end
3507         do j=1,3
3508           duscdiff(j,i)=0.0d0
3509           duscdiffx(j,i)=0.0d0
3510         enddo
3511       enddo
3512 #endif
3513 c
3514 c     do iref=1,nref
3515 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3516 c     write (iout,*) "waga_theta",waga_theta
3517       if (waga_theta.gt.0.0d0) then
3518 #ifdef DEBUG
3519       write (iout,*) "usampl",usampl
3520       write(iout,*) "------- theta restrs start -------"
3521 c     do i=ithet_start,ithet_end
3522 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3523 c     enddo
3524 #endif
3525 c     write (iout,*) "maxres",maxres,"nres",nres
3526
3527       do i=ithet_start,ithet_end
3528 c
3529 c     do i=1,nfrag_back
3530 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3531 c
3532 c Deviation of theta angles wrt constr_homology ref structures
3533 c
3534         utheta_i=0.0d0 ! argument of Gaussian for single k
3535 #ifdef OLDRESTR
3536         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3537 #else
3538         gutheta_i=nexl
3539 #endif
3540 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3541 c       over residues in a fragment
3542 c       write (iout,*) "theta(",i,")=",theta(i)
3543         do k=1,constr_homology
3544 c
3545 c         dtheta_i=theta(j)-thetaref(j,iref)
3546 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3547           theta_diff(k)=thetatpl(k,i)-theta(i)
3548 c
3549           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3550 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3551           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3552           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3553 c         Gradient for single Gaussian restraint in subr Econstr_back
3554 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3555 c
3556         enddo
3557 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3558 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3559
3560 c
3561 #ifdef GRAD
3562 c         Gradient for multiple Gaussian restraint
3563         sum_gtheta=gutheta_i
3564         sum_sgtheta=0.0d0
3565         do k=1,constr_homology
3566 c        New generalized expr for multiple Gaussian from Econstr_back
3567          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3568 c
3569 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3570           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3571         enddo
3572 c
3573 c       Final value of gradient using same var as in Econstr_back
3574         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3575      &               *waga_homology(iset)
3576 c       dutheta(i)=sum_sgtheta/sum_gtheta
3577 c
3578 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3579 #endif
3580         Eval=Eval-dLOG(gutheta_i/constr_homology)
3581 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3582 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3583 c       Uconst_back=Uconst_back+utheta(i)
3584       enddo ! (i-loop for theta)
3585 #ifdef DEBUG
3586       write(iout,*) "------- theta restrs end -------"
3587 #endif
3588       endif
3589 c
3590 c Deviation of local SC geometry
3591 c
3592 c Separation of two i-loops (instructed by AL - 11/3/2014)
3593 c
3594 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3595 c     write (iout,*) "waga_d",waga_d
3596
3597 #ifdef DEBUG
3598       write(iout,*) "------- SC restrs start -------"
3599       write (iout,*) "Initial duscdiff,duscdiffx"
3600       do i=loc_start,loc_end
3601         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3602      &                 (duscdiffx(jik,i),jik=1,3)
3603       enddo
3604 #endif
3605       do i=loc_start,loc_end
3606         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3607 #ifdef OLDRESTR
3608         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3609 #else
3610         guscdiff(i)=nexl
3611 #endif
3612 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3613 c       write(iout,*) "xxtab, yytab, zztab"
3614 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3615         do k=1,constr_homology
3616 c
3617           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3618 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3619           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3620           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3621 c         write(iout,*) "dxx, dyy, dzz"
3622 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3623 c
3624           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3625 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3626 c         uscdiffk(k)=usc_diff(i)
3627           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3628           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3629 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3630 c     &      xxref(j),yyref(j),zzref(j)
3631         enddo
3632 c
3633 c       Gradient
3634 c
3635 c       Generalized expression for multiple Gaussian acc to that for a single
3636 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3637 c
3638 c       Original implementation
3639 c       sum_guscdiff=guscdiff(i)
3640 c
3641 c       sum_sguscdiff=0.0d0
3642 c       do k=1,constr_homology
3643 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3644 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3645 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3646 c       enddo
3647 c
3648 c       Implementation of new expressions for gradient (Jan. 2015)
3649 c
3650 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3651 #ifdef GRAD
3652         do k=1,constr_homology
3653 c
3654 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3655 c       before. Now the drivatives should be correct
3656 c
3657           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3658 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3659           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3660           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3661 c
3662 c         New implementation
3663 c
3664           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3665      &                 sigma_d(k,i) ! for the grad wrt r'
3666 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3667 c
3668 c
3669 c        New implementation
3670          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3671          do jik=1,3
3672             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3673      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3674      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3675             duscdiff(jik,i)=duscdiff(jik,i)+
3676      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3677      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3678             duscdiffx(jik,i)=duscdiffx(jik,i)+
3679      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3680      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3681 c
3682 #ifdef DEBUG
3683              write(iout,*) "jik",jik,"i",i
3684              write(iout,*) "dxx, dyy, dzz"
3685              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3686              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3687 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3688 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3689 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3690 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3691 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3692 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3693 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3694 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3695 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3696 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3697 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3698 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3699 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3700 c            endif
3701 #endif
3702          enddo
3703         enddo
3704 #endif
3705 c
3706 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3707 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3708 c
3709 c        write (iout,*) i," uscdiff",uscdiff(i)
3710 c
3711 c Put together deviations from local geometry
3712
3713 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3714 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3715         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3716 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3717 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3718 c       Uconst_back=Uconst_back+usc_diff(i)
3719 c
3720 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3721 c
3722 c     New implment: multiplied by sum_sguscdiff
3723 c
3724
3725       enddo ! (i-loop for dscdiff)
3726
3727 c      endif
3728
3729 #ifdef DEBUG
3730       write(iout,*) "------- SC restrs end -------"
3731         write (iout,*) "------ After SC loop in e_modeller ------"
3732         do i=loc_start,loc_end
3733          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3734          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3735         enddo
3736       if (waga_theta.eq.1.0d0) then
3737       write (iout,*) "in e_modeller after SC restr end: dutheta"
3738       do i=ithet_start,ithet_end
3739         write (iout,*) i,dutheta(i)
3740       enddo
3741       endif
3742       if (waga_d.eq.1.0d0) then
3743       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3744       do i=1,nres
3745         write (iout,*) i,(duscdiff(j,i),j=1,3)
3746         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3747       enddo
3748       endif
3749 #endif
3750
3751 c Total energy from homology restraints
3752 #ifdef DEBUG
3753       write (iout,*) "odleg",odleg," kat",kat
3754       write (iout,*) "odleg",odleg," kat",kat
3755       write (iout,*) "Eval",Eval," Erot",Erot
3756       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3757       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3758       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3759 #endif
3760 c
3761 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3762 c
3763 c     ehomology_constr=odleg+kat
3764 c
3765 c     For Lorentzian-type Urestr
3766 c
3767
3768       if (waga_dist.ge.0.0d0) then
3769 c
3770 c          For Gaussian-type Urestr
3771 c
3772 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3773 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3774         ehomology_constr=waga_dist*odleg+waga_angle*kat+
3775      &              waga_theta*Eval+waga_d*Erot
3776 c     write (iout,*) "ehomology_constr=",ehomology_constr
3777       else
3778 c
3779 c          For Lorentzian-type Urestr
3780 c
3781 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3782 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3783         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
3784      &              waga_theta*Eval+waga_d*Erot
3785 c     write (iout,*) "ehomology_constr=",ehomology_constr
3786       endif
3787 #ifdef DEBUG
3788       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3789      & "Eval",waga_theta,eval,
3790      &   "Erot",waga_d,Erot
3791       write (iout,*) "ehomology_constr",ehomology_constr
3792 #endif
3793       return
3794
3795   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3796   747 format(a12,i4,i4,i4,f8.3,f8.3)
3797   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3798   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3799   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3800      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3801       end
3802 c-----------------------------------------------------------------------
3803       subroutine ebond(estr)
3804 c
3805 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3806 c
3807       implicit real*8 (a-h,o-z)
3808       include 'DIMENSIONS'
3809       include 'DIMENSIONS.ZSCOPT'
3810       include 'DIMENSIONS.FREE'
3811       include 'COMMON.LOCAL'
3812       include 'COMMON.GEO'
3813       include 'COMMON.INTERACT'
3814       include 'COMMON.DERIV'
3815       include 'COMMON.VAR'
3816       include 'COMMON.CHAIN'
3817       include 'COMMON.IOUNITS'
3818       include 'COMMON.NAMES'
3819       include 'COMMON.FFIELD'
3820       include 'COMMON.CONTROL'
3821       double precision u(3),ud(3)
3822       logical :: lprn=.false.
3823       estr=0.0d0
3824       do i=nnt+1,nct
3825         diff = vbld(i)-vbldp0
3826 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3827         estr=estr+diff*diff
3828         do j=1,3
3829           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3830         enddo
3831       enddo
3832       estr=0.5d0*AKP*estr
3833 c
3834 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3835 c
3836       do i=nnt,nct
3837         iti=itype(i)
3838         if (iti.ne.10) then
3839           nbi=nbondterm(iti)
3840           if (nbi.eq.1) then
3841             diff=vbld(i+nres)-vbldsc0(1,iti)
3842             if (lprn)
3843      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3844      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3845             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3846             do j=1,3
3847               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3848             enddo
3849           else
3850             do j=1,nbi
3851               diff=vbld(i+nres)-vbldsc0(j,iti)
3852               ud(j)=aksc(j,iti)*diff
3853               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3854             enddo
3855             uprod=u(1)
3856             do j=2,nbi
3857               uprod=uprod*u(j)
3858             enddo
3859             usum=0.0d0
3860             usumsqder=0.0d0
3861             do j=1,nbi
3862               uprod1=1.0d0
3863               uprod2=1.0d0
3864               do k=1,nbi
3865                 if (k.ne.j) then
3866                   uprod1=uprod1*u(k)
3867                   uprod2=uprod2*u(k)*u(k)
3868                 endif
3869               enddo
3870               usum=usum+uprod1
3871               usumsqder=usumsqder+ud(j)*uprod2
3872             enddo
3873             if (lprn)
3874      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3875      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3876             estr=estr+uprod/usum
3877             do j=1,3
3878              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3879             enddo
3880           endif
3881         endif
3882       enddo
3883       return
3884       end
3885 #ifdef CRYST_THETA
3886 C--------------------------------------------------------------------------
3887       subroutine ebend(etheta)
3888 C
3889 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3890 C angles gamma and its derivatives in consecutive thetas and gammas.
3891 C
3892       implicit real*8 (a-h,o-z)
3893       include 'DIMENSIONS'
3894       include 'DIMENSIONS.ZSCOPT'
3895       include 'COMMON.LOCAL'
3896       include 'COMMON.GEO'
3897       include 'COMMON.INTERACT'
3898       include 'COMMON.DERIV'
3899       include 'COMMON.VAR'
3900       include 'COMMON.CHAIN'
3901       include 'COMMON.IOUNITS'
3902       include 'COMMON.NAMES'
3903       include 'COMMON.FFIELD'
3904       common /calcthet/ term1,term2,termm,diffak,ratak,
3905      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3906      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3907       double precision y(2),z(2)
3908       delta=0.02d0*pi
3909       time11=dexp(-2*time)
3910       time12=1.0d0
3911       etheta=0.0D0
3912 c      write (iout,*) "nres",nres
3913 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3914 c      write (iout,*) ithet_start,ithet_end
3915       do i=ithet_start,ithet_end
3916 C Zero the energy function and its derivative at 0 or pi.
3917         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3918         it=itype(i-1)
3919 c        if (i.gt.ithet_start .and.
3920 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3921 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3922 c          phii=phi(i)
3923 c          y(1)=dcos(phii)
3924 c          y(2)=dsin(phii)
3925 c        else
3926 c          y(1)=0.0D0
3927 c          y(2)=0.0D0
3928 c        endif
3929 c        if (i.lt.nres .and. itel(i).ne.0) then
3930 c          phii1=phi(i+1)
3931 c          z(1)=dcos(phii1)
3932 c          z(2)=dsin(phii1)
3933 c        else
3934 c          z(1)=0.0D0
3935 c          z(2)=0.0D0
3936 c        endif
3937         if (i.gt.3) then
3938 #ifdef OSF
3939           phii=phi(i)
3940           icrc=0
3941           call proc_proc(phii,icrc)
3942           if (icrc.eq.1) phii=150.0
3943 #else
3944           phii=phi(i)
3945 #endif
3946           y(1)=dcos(phii)
3947           y(2)=dsin(phii)
3948         else
3949           y(1)=0.0D0
3950           y(2)=0.0D0
3951         endif
3952         if (i.lt.nres) then
3953 #ifdef OSF
3954           phii1=phi(i+1)
3955           icrc=0
3956           call proc_proc(phii1,icrc)
3957           if (icrc.eq.1) phii1=150.0
3958           phii1=pinorm(phii1)
3959           z(1)=cos(phii1)
3960 #else
3961           phii1=phi(i+1)
3962           z(1)=dcos(phii1)
3963 #endif
3964           z(2)=dsin(phii1)
3965         else
3966           z(1)=0.0D0
3967           z(2)=0.0D0
3968         endif
3969 C Calculate the "mean" value of theta from the part of the distribution
3970 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3971 C In following comments this theta will be referred to as t_c.
3972         thet_pred_mean=0.0d0
3973         do k=1,2
3974           athetk=athet(k,it)
3975           bthetk=bthet(k,it)
3976           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3977         enddo
3978 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3979         dthett=thet_pred_mean*ssd
3980         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3981 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3982 C Derivatives of the "mean" values in gamma1 and gamma2.
3983         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3984         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3985         if (theta(i).gt.pi-delta) then
3986           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3987      &         E_tc0)
3988           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3989           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3990           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3991      &        E_theta)
3992           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3993      &        E_tc)
3994         else if (theta(i).lt.delta) then
3995           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3996           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3997           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3998      &        E_theta)
3999           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4000           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4001      &        E_tc)
4002         else
4003           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4004      &        E_theta,E_tc)
4005         endif
4006         etheta=etheta+ethetai
4007 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4008 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4009         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4010         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4011         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4012  1215   continue
4013       enddo
4014 C Ufff.... We've done all this!!!
4015       return
4016       end
4017 C---------------------------------------------------------------------------
4018       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4019      &     E_tc)
4020       implicit real*8 (a-h,o-z)
4021       include 'DIMENSIONS'
4022       include 'COMMON.LOCAL'
4023       include 'COMMON.IOUNITS'
4024       common /calcthet/ term1,term2,termm,diffak,ratak,
4025      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4026      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4027 C Calculate the contributions to both Gaussian lobes.
4028 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4029 C The "polynomial part" of the "standard deviation" of this part of
4030 C the distribution.
4031         sig=polthet(3,it)
4032         do j=2,0,-1
4033           sig=sig*thet_pred_mean+polthet(j,it)
4034         enddo
4035 C Derivative of the "interior part" of the "standard deviation of the"
4036 C gamma-dependent Gaussian lobe in t_c.
4037         sigtc=3*polthet(3,it)
4038         do j=2,1,-1
4039           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4040         enddo
4041         sigtc=sig*sigtc
4042 C Set the parameters of both Gaussian lobes of the distribution.
4043 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4044         fac=sig*sig+sigc0(it)
4045         sigcsq=fac+fac
4046         sigc=1.0D0/sigcsq
4047 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4048         sigsqtc=-4.0D0*sigcsq*sigtc
4049 c       print *,i,sig,sigtc,sigsqtc
4050 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4051         sigtc=-sigtc/(fac*fac)
4052 C Following variable is sigma(t_c)**(-2)
4053         sigcsq=sigcsq*sigcsq
4054         sig0i=sig0(it)
4055         sig0inv=1.0D0/sig0i**2
4056         delthec=thetai-thet_pred_mean
4057         delthe0=thetai-theta0i
4058         term1=-0.5D0*sigcsq*delthec*delthec
4059         term2=-0.5D0*sig0inv*delthe0*delthe0
4060 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4061 C NaNs in taking the logarithm. We extract the largest exponent which is added
4062 C to the energy (this being the log of the distribution) at the end of energy
4063 C term evaluation for this virtual-bond angle.
4064         if (term1.gt.term2) then
4065           termm=term1
4066           term2=dexp(term2-termm)
4067           term1=1.0d0
4068         else
4069           termm=term2
4070           term1=dexp(term1-termm)
4071           term2=1.0d0
4072         endif
4073 C The ratio between the gamma-independent and gamma-dependent lobes of
4074 C the distribution is a Gaussian function of thet_pred_mean too.
4075         diffak=gthet(2,it)-thet_pred_mean
4076         ratak=diffak/gthet(3,it)**2
4077         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4078 C Let's differentiate it in thet_pred_mean NOW.
4079         aktc=ak*ratak
4080 C Now put together the distribution terms to make complete distribution.
4081         termexp=term1+ak*term2
4082         termpre=sigc+ak*sig0i
4083 C Contribution of the bending energy from this theta is just the -log of
4084 C the sum of the contributions from the two lobes and the pre-exponential
4085 C factor. Simple enough, isn't it?
4086         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4087 C NOW the derivatives!!!
4088 C 6/6/97 Take into account the deformation.
4089         E_theta=(delthec*sigcsq*term1
4090      &       +ak*delthe0*sig0inv*term2)/termexp
4091         E_tc=((sigtc+aktc*sig0i)/termpre
4092      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4093      &       aktc*term2)/termexp)
4094       return
4095       end
4096 c-----------------------------------------------------------------------------
4097       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4098       implicit real*8 (a-h,o-z)
4099       include 'DIMENSIONS'
4100       include 'COMMON.LOCAL'
4101       include 'COMMON.IOUNITS'
4102       common /calcthet/ term1,term2,termm,diffak,ratak,
4103      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4104      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4105       delthec=thetai-thet_pred_mean
4106       delthe0=thetai-theta0i
4107 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4108       t3 = thetai-thet_pred_mean
4109       t6 = t3**2
4110       t9 = term1
4111       t12 = t3*sigcsq
4112       t14 = t12+t6*sigsqtc
4113       t16 = 1.0d0
4114       t21 = thetai-theta0i
4115       t23 = t21**2
4116       t26 = term2
4117       t27 = t21*t26
4118       t32 = termexp
4119       t40 = t32**2
4120       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4121      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4122      & *(-t12*t9-ak*sig0inv*t27)
4123       return
4124       end
4125 #else
4126 C--------------------------------------------------------------------------
4127       subroutine ebend(etheta)
4128 C
4129 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4130 C angles gamma and its derivatives in consecutive thetas and gammas.
4131 C ab initio-derived potentials from
4132 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4133 C
4134       implicit real*8 (a-h,o-z)
4135       include 'DIMENSIONS'
4136       include 'DIMENSIONS.ZSCOPT'
4137       include 'DIMENSIONS.FREE'
4138       include 'COMMON.LOCAL'
4139       include 'COMMON.GEO'
4140       include 'COMMON.INTERACT'
4141       include 'COMMON.DERIV'
4142       include 'COMMON.VAR'
4143       include 'COMMON.CHAIN'
4144       include 'COMMON.IOUNITS'
4145       include 'COMMON.NAMES'
4146       include 'COMMON.FFIELD'
4147       include 'COMMON.CONTROL'
4148       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4149      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4150      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4151      & sinph1ph2(maxdouble,maxdouble)
4152       logical lprn /.false./, lprn1 /.false./
4153       etheta=0.0D0
4154 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4155       do i=ithet_start,ithet_end
4156         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4157      &    (itype(i).eq.ntyp1)) cycle
4158         dethetai=0.0d0
4159         dephii=0.0d0
4160         dephii1=0.0d0
4161         theti2=0.5d0*theta(i)
4162         ityp2=ithetyp(itype(i-1))
4163         do k=1,nntheterm
4164           coskt(k)=dcos(k*theti2)
4165           sinkt(k)=dsin(k*theti2)
4166         enddo
4167         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4168 #ifdef OSF
4169           phii=phi(i)
4170           if (phii.ne.phii) phii=150.0
4171 #else
4172           phii=phi(i)
4173 #endif
4174           ityp1=ithetyp(itype(i-2))
4175           do k=1,nsingle
4176             cosph1(k)=dcos(k*phii)
4177             sinph1(k)=dsin(k*phii)
4178           enddo
4179         else
4180           phii=0.0d0
4181           ityp1=ithetyp(itype(i-2))
4182           do k=1,nsingle
4183             cosph1(k)=0.0d0
4184             sinph1(k)=0.0d0
4185           enddo
4186         endif
4187         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4188 #ifdef OSF
4189           phii1=phi(i+1)
4190           if (phii1.ne.phii1) phii1=150.0
4191           phii1=pinorm(phii1)
4192 #else
4193           phii1=phi(i+1)
4194 #endif
4195           ityp3=ithetyp(itype(i))
4196           do k=1,nsingle
4197             cosph2(k)=dcos(k*phii1)
4198             sinph2(k)=dsin(k*phii1)
4199           enddo
4200         else
4201           phii1=0.0d0
4202 c          ityp3=nthetyp+1
4203           ityp3=ithetyp(itype(i))
4204           do k=1,nsingle
4205             cosph2(k)=0.0d0
4206             sinph2(k)=0.0d0
4207           enddo
4208         endif
4209 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4210 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4211 c        call flush(iout)
4212         ethetai=aa0thet(ityp1,ityp2,ityp3)
4213         do k=1,ndouble
4214           do l=1,k-1
4215             ccl=cosph1(l)*cosph2(k-l)
4216             ssl=sinph1(l)*sinph2(k-l)
4217             scl=sinph1(l)*cosph2(k-l)
4218             csl=cosph1(l)*sinph2(k-l)
4219             cosph1ph2(l,k)=ccl-ssl
4220             cosph1ph2(k,l)=ccl+ssl
4221             sinph1ph2(l,k)=scl+csl
4222             sinph1ph2(k,l)=scl-csl
4223           enddo
4224         enddo
4225         if (lprn) then
4226         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4227      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4228         write (iout,*) "coskt and sinkt"
4229         do k=1,nntheterm
4230           write (iout,*) k,coskt(k),sinkt(k)
4231         enddo
4232         endif
4233         do k=1,ntheterm
4234           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4235           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4236      &      *coskt(k)
4237           if (lprn)
4238      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4239      &     " ethetai",ethetai
4240         enddo
4241         if (lprn) then
4242         write (iout,*) "cosph and sinph"
4243         do k=1,nsingle
4244           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4245         enddo
4246         write (iout,*) "cosph1ph2 and sinph2ph2"
4247         do k=2,ndouble
4248           do l=1,k-1
4249             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4250      &         sinph1ph2(l,k),sinph1ph2(k,l)
4251           enddo
4252         enddo
4253         write(iout,*) "ethetai",ethetai
4254         endif
4255         do m=1,ntheterm2
4256           do k=1,nsingle
4257             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4258      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4259      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4260      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4261             ethetai=ethetai+sinkt(m)*aux
4262             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4263             dephii=dephii+k*sinkt(m)*(
4264      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4265      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4266             dephii1=dephii1+k*sinkt(m)*(
4267      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4268      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4269             if (lprn)
4270      &      write (iout,*) "m",m," k",k," bbthet",
4271      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4272      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4273      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4274      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4275           enddo
4276         enddo
4277         if (lprn)
4278      &  write(iout,*) "ethetai",ethetai
4279         do m=1,ntheterm3
4280           do k=2,ndouble
4281             do l=1,k-1
4282               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4283      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4284      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4285      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4286               ethetai=ethetai+sinkt(m)*aux
4287               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4288               dephii=dephii+l*sinkt(m)*(
4289      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4290      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4291      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4292      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4293               dephii1=dephii1+(k-l)*sinkt(m)*(
4294      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4295      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4296      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4297      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4298               if (lprn) then
4299               write (iout,*) "m",m," k",k," l",l," ffthet",
4300      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4301      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4302      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4303      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4304               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4305      &            cosph1ph2(k,l)*sinkt(m),
4306      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4307               endif
4308             enddo
4309           enddo
4310         enddo
4311 10      continue
4312 c        lprn1=.true.
4313         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4314      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4315      &   phii1*rad2deg,ethetai
4316 c        lprn1=.false.
4317         etheta=etheta+ethetai
4318
4319         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4320         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4321         gloc(nphi+i-2,icg)=wang*dethetai
4322       enddo
4323       return
4324       end
4325 #endif
4326 #ifdef CRYST_SC
4327 c-----------------------------------------------------------------------------
4328       subroutine esc(escloc)
4329 C Calculate the local energy of a side chain and its derivatives in the
4330 C corresponding virtual-bond valence angles THETA and the spherical angles
4331 C ALPHA and OMEGA.
4332       implicit real*8 (a-h,o-z)
4333       include 'DIMENSIONS'
4334       include 'DIMENSIONS.ZSCOPT'
4335       include 'COMMON.GEO'
4336       include 'COMMON.LOCAL'
4337       include 'COMMON.VAR'
4338       include 'COMMON.INTERACT'
4339       include 'COMMON.DERIV'
4340       include 'COMMON.CHAIN'
4341       include 'COMMON.IOUNITS'
4342       include 'COMMON.NAMES'
4343       include 'COMMON.FFIELD'
4344       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4345      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4346       common /sccalc/ time11,time12,time112,theti,it,nlobit
4347       delta=0.02d0*pi
4348       escloc=0.0D0
4349 c     write (iout,'(a)') 'ESC'
4350       do i=loc_start,loc_end
4351         it=itype(i)
4352         if (it.eq.10) goto 1
4353         nlobit=nlob(it)
4354 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4355 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4356         theti=theta(i+1)-pipol
4357         x(1)=dtan(theti)
4358         x(2)=alph(i)
4359         x(3)=omeg(i)
4360 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4361
4362         if (x(2).gt.pi-delta) then
4363           xtemp(1)=x(1)
4364           xtemp(2)=pi-delta
4365           xtemp(3)=x(3)
4366           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4367           xtemp(2)=pi
4368           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4369           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4370      &        escloci,dersc(2))
4371           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4372      &        ddersc0(1),dersc(1))
4373           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4374      &        ddersc0(3),dersc(3))
4375           xtemp(2)=pi-delta
4376           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4377           xtemp(2)=pi
4378           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4379           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4380      &            dersc0(2),esclocbi,dersc02)
4381           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4382      &            dersc12,dersc01)
4383           call splinthet(x(2),0.5d0*delta,ss,ssd)
4384           dersc0(1)=dersc01
4385           dersc0(2)=dersc02
4386           dersc0(3)=0.0d0
4387           do k=1,3
4388             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4389           enddo
4390           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4391 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4392 c    &             esclocbi,ss,ssd
4393           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4394 c         escloci=esclocbi
4395 c         write (iout,*) escloci
4396         else if (x(2).lt.delta) then
4397           xtemp(1)=x(1)
4398           xtemp(2)=delta
4399           xtemp(3)=x(3)
4400           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4401           xtemp(2)=0.0d0
4402           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4403           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4404      &        escloci,dersc(2))
4405           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4406      &        ddersc0(1),dersc(1))
4407           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4408      &        ddersc0(3),dersc(3))
4409           xtemp(2)=delta
4410           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4411           xtemp(2)=0.0d0
4412           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4413           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4414      &            dersc0(2),esclocbi,dersc02)
4415           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4416      &            dersc12,dersc01)
4417           dersc0(1)=dersc01
4418           dersc0(2)=dersc02
4419           dersc0(3)=0.0d0
4420           call splinthet(x(2),0.5d0*delta,ss,ssd)
4421           do k=1,3
4422             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4423           enddo
4424           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4425 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4426 c    &             esclocbi,ss,ssd
4427           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4428 c         write (iout,*) escloci
4429         else
4430           call enesc(x,escloci,dersc,ddummy,.false.)
4431         endif
4432
4433         escloc=escloc+escloci
4434 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4435
4436         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4437      &   wscloc*dersc(1)
4438         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4439         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4440     1   continue
4441       enddo
4442       return
4443       end
4444 C---------------------------------------------------------------------------
4445       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4446       implicit real*8 (a-h,o-z)
4447       include 'DIMENSIONS'
4448       include 'COMMON.GEO'
4449       include 'COMMON.LOCAL'
4450       include 'COMMON.IOUNITS'
4451       common /sccalc/ time11,time12,time112,theti,it,nlobit
4452       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4453       double precision contr(maxlob,-1:1)
4454       logical mixed
4455 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4456         escloc_i=0.0D0
4457         do j=1,3
4458           dersc(j)=0.0D0
4459           if (mixed) ddersc(j)=0.0d0
4460         enddo
4461         x3=x(3)
4462
4463 C Because of periodicity of the dependence of the SC energy in omega we have
4464 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4465 C To avoid underflows, first compute & store the exponents.
4466
4467         do iii=-1,1
4468
4469           x(3)=x3+iii*dwapi
4470
4471           do j=1,nlobit
4472             do k=1,3
4473               z(k)=x(k)-censc(k,j,it)
4474             enddo
4475             do k=1,3
4476               Axk=0.0D0
4477               do l=1,3
4478                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4479               enddo
4480               Ax(k,j,iii)=Axk
4481             enddo
4482             expfac=0.0D0
4483             do k=1,3
4484               expfac=expfac+Ax(k,j,iii)*z(k)
4485             enddo
4486             contr(j,iii)=expfac
4487           enddo ! j
4488
4489         enddo ! iii
4490
4491         x(3)=x3
4492 C As in the case of ebend, we want to avoid underflows in exponentiation and
4493 C subsequent NaNs and INFs in energy calculation.
4494 C Find the largest exponent
4495         emin=contr(1,-1)
4496         do iii=-1,1
4497           do j=1,nlobit
4498             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4499           enddo
4500         enddo
4501         emin=0.5D0*emin
4502 cd      print *,'it=',it,' emin=',emin
4503
4504 C Compute the contribution to SC energy and derivatives
4505         do iii=-1,1
4506
4507           do j=1,nlobit
4508             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4509 cd          print *,'j=',j,' expfac=',expfac
4510             escloc_i=escloc_i+expfac
4511             do k=1,3
4512               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4513             enddo
4514             if (mixed) then
4515               do k=1,3,2
4516                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4517      &            +gaussc(k,2,j,it))*expfac
4518               enddo
4519             endif
4520           enddo
4521
4522         enddo ! iii
4523
4524         dersc(1)=dersc(1)/cos(theti)**2
4525         ddersc(1)=ddersc(1)/cos(theti)**2
4526         ddersc(3)=ddersc(3)
4527
4528         escloci=-(dlog(escloc_i)-emin)
4529         do j=1,3
4530           dersc(j)=dersc(j)/escloc_i
4531         enddo
4532         if (mixed) then
4533           do j=1,3,2
4534             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4535           enddo
4536         endif
4537       return
4538       end
4539 C------------------------------------------------------------------------------
4540       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4541       implicit real*8 (a-h,o-z)
4542       include 'DIMENSIONS'
4543       include 'COMMON.GEO'
4544       include 'COMMON.LOCAL'
4545       include 'COMMON.IOUNITS'
4546       common /sccalc/ time11,time12,time112,theti,it,nlobit
4547       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4548       double precision contr(maxlob)
4549       logical mixed
4550
4551       escloc_i=0.0D0
4552
4553       do j=1,3
4554         dersc(j)=0.0D0
4555       enddo
4556
4557       do j=1,nlobit
4558         do k=1,2
4559           z(k)=x(k)-censc(k,j,it)
4560         enddo
4561         z(3)=dwapi
4562         do k=1,3
4563           Axk=0.0D0
4564           do l=1,3
4565             Axk=Axk+gaussc(l,k,j,it)*z(l)
4566           enddo
4567           Ax(k,j)=Axk
4568         enddo
4569         expfac=0.0D0
4570         do k=1,3
4571           expfac=expfac+Ax(k,j)*z(k)
4572         enddo
4573         contr(j)=expfac
4574       enddo ! j
4575
4576 C As in the case of ebend, we want to avoid underflows in exponentiation and
4577 C subsequent NaNs and INFs in energy calculation.
4578 C Find the largest exponent
4579       emin=contr(1)
4580       do j=1,nlobit
4581         if (emin.gt.contr(j)) emin=contr(j)
4582       enddo
4583       emin=0.5D0*emin
4584
4585 C Compute the contribution to SC energy and derivatives
4586
4587       dersc12=0.0d0
4588       do j=1,nlobit
4589         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4590         escloc_i=escloc_i+expfac
4591         do k=1,2
4592           dersc(k)=dersc(k)+Ax(k,j)*expfac
4593         enddo
4594         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4595      &            +gaussc(1,2,j,it))*expfac
4596         dersc(3)=0.0d0
4597       enddo
4598
4599       dersc(1)=dersc(1)/cos(theti)**2
4600       dersc12=dersc12/cos(theti)**2
4601       escloci=-(dlog(escloc_i)-emin)
4602       do j=1,2
4603         dersc(j)=dersc(j)/escloc_i
4604       enddo
4605       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4606       return
4607       end
4608 #else
4609 c----------------------------------------------------------------------------------
4610       subroutine esc(escloc)
4611 C Calculate the local energy of a side chain and its derivatives in the
4612 C corresponding virtual-bond valence angles THETA and the spherical angles
4613 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4614 C added by Urszula Kozlowska. 07/11/2007
4615 C
4616       implicit real*8 (a-h,o-z)
4617       include 'DIMENSIONS'
4618       include 'DIMENSIONS.ZSCOPT'
4619       include 'DIMENSIONS.FREE'
4620       include 'COMMON.GEO'
4621       include 'COMMON.LOCAL'
4622       include 'COMMON.VAR'
4623       include 'COMMON.SCROT'
4624       include 'COMMON.INTERACT'
4625       include 'COMMON.DERIV'
4626       include 'COMMON.CHAIN'
4627       include 'COMMON.IOUNITS'
4628       include 'COMMON.NAMES'
4629       include 'COMMON.FFIELD'
4630       include 'COMMON.CONTROL'
4631       include 'COMMON.VECTORS'
4632       double precision x_prime(3),y_prime(3),z_prime(3)
4633      &    , sumene,dsc_i,dp2_i,x(65),
4634      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4635      &    de_dxx,de_dyy,de_dzz,de_dt
4636       double precision s1_t,s1_6_t,s2_t,s2_6_t
4637       double precision
4638      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4639      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4640      & dt_dCi(3),dt_dCi1(3)
4641       common /sccalc/ time11,time12,time112,theti,it,nlobit
4642       delta=0.02d0*pi
4643       escloc=0.0D0
4644       do i=loc_start,loc_end
4645         costtab(i+1) =dcos(theta(i+1))
4646         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4647         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4648         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4649         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4650         cosfac=dsqrt(cosfac2)
4651         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4652         sinfac=dsqrt(sinfac2)
4653         it=itype(i)
4654         if (it.eq.10) goto 1
4655 c
4656 C  Compute the axes of tghe local cartesian coordinates system; store in
4657 c   x_prime, y_prime and z_prime
4658 c
4659         do j=1,3
4660           x_prime(j) = 0.00
4661           y_prime(j) = 0.00
4662           z_prime(j) = 0.00
4663         enddo
4664 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4665 C     &   dc_norm(3,i+nres)
4666         do j = 1,3
4667           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4668           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4669         enddo
4670         do j = 1,3
4671           z_prime(j) = -uz(j,i-1)
4672         enddo
4673 c       write (2,*) "i",i
4674 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4675 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4676 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4677 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4678 c      & " xy",scalar(x_prime(1),y_prime(1)),
4679 c      & " xz",scalar(x_prime(1),z_prime(1)),
4680 c      & " yy",scalar(y_prime(1),y_prime(1)),
4681 c      & " yz",scalar(y_prime(1),z_prime(1)),
4682 c      & " zz",scalar(z_prime(1),z_prime(1))
4683 c
4684 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4685 C to local coordinate system. Store in xx, yy, zz.
4686 c
4687         xx=0.0d0
4688         yy=0.0d0
4689         zz=0.0d0
4690         do j = 1,3
4691           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4692           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4693           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4694         enddo
4695
4696         xxtab(i)=xx
4697         yytab(i)=yy
4698         zztab(i)=zz
4699 C
4700 C Compute the energy of the ith side cbain
4701 C
4702 c        write (2,*) "xx",xx," yy",yy," zz",zz
4703         it=itype(i)
4704         do j = 1,65
4705           x(j) = sc_parmin(j,it)
4706         enddo
4707 #ifdef CHECK_COORD
4708 Cc diagnostics - remove later
4709         xx1 = dcos(alph(2))
4710         yy1 = dsin(alph(2))*dcos(omeg(2))
4711         zz1 = -dsin(alph(2))*dsin(omeg(2))
4712         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4713      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4714      &    xx1,yy1,zz1
4715 C,"  --- ", xx_w,yy_w,zz_w
4716 c end diagnostics
4717 #endif
4718         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4719      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4720      &   + x(10)*yy*zz
4721         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4722      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4723      & + x(20)*yy*zz
4724         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4725      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4726      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4727      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4728      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4729      &  +x(40)*xx*yy*zz
4730         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4731      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4732      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4733      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4734      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4735      &  +x(60)*xx*yy*zz
4736         dsc_i   = 0.743d0+x(61)
4737         dp2_i   = 1.9d0+x(62)
4738         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4739      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4740         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4741      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4742         s1=(1+x(63))/(0.1d0 + dscp1)
4743         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4744         s2=(1+x(65))/(0.1d0 + dscp2)
4745         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4746         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4747      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4748 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4749 c     &   sumene4,
4750 c     &   dscp1,dscp2,sumene
4751 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4752         escloc = escloc + sumene
4753 c        write (2,*) "escloc",escloc
4754         if (.not. calc_grad) goto 1
4755
4756 #ifdef DEBUG2
4757 C
4758 C This section to check the numerical derivatives of the energy of ith side
4759 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4760 C #define DEBUG in the code to turn it on.
4761 C
4762         write (2,*) "sumene               =",sumene
4763         aincr=1.0d-7
4764         xxsave=xx
4765         xx=xx+aincr
4766         write (2,*) xx,yy,zz
4767         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4768         de_dxx_num=(sumenep-sumene)/aincr
4769         xx=xxsave
4770         write (2,*) "xx+ sumene from enesc=",sumenep
4771         yysave=yy
4772         yy=yy+aincr
4773         write (2,*) xx,yy,zz
4774         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4775         de_dyy_num=(sumenep-sumene)/aincr
4776         yy=yysave
4777         write (2,*) "yy+ sumene from enesc=",sumenep
4778         zzsave=zz
4779         zz=zz+aincr
4780         write (2,*) xx,yy,zz
4781         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4782         de_dzz_num=(sumenep-sumene)/aincr
4783         zz=zzsave
4784         write (2,*) "zz+ sumene from enesc=",sumenep
4785         costsave=cost2tab(i+1)
4786         sintsave=sint2tab(i+1)
4787         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4788         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4789         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4790         de_dt_num=(sumenep-sumene)/aincr
4791         write (2,*) " t+ sumene from enesc=",sumenep
4792         cost2tab(i+1)=costsave
4793         sint2tab(i+1)=sintsave
4794 C End of diagnostics section.
4795 #endif
4796 C
4797 C Compute the gradient of esc
4798 C
4799         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4800         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4801         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4802         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4803         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4804         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4805         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4806         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4807         pom1=(sumene3*sint2tab(i+1)+sumene1)
4808      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4809         pom2=(sumene4*cost2tab(i+1)+sumene2)
4810      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4811         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4812         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4813      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4814      &  +x(40)*yy*zz
4815         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4816         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4817      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4818      &  +x(60)*yy*zz
4819         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4820      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4821      &        +(pom1+pom2)*pom_dx
4822 #ifdef DEBUG
4823         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4824 #endif
4825 C
4826         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4827         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4828      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4829      &  +x(40)*xx*zz
4830         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4831         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4832      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4833      &  +x(59)*zz**2 +x(60)*xx*zz
4834         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4835      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4836      &        +(pom1-pom2)*pom_dy
4837 #ifdef DEBUG
4838         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4839 #endif
4840 C
4841         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4842      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4843      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4844      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4845      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4846      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4847      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4848      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4849 #ifdef DEBUG
4850         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4851 #endif
4852 C
4853         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4854      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4855      &  +pom1*pom_dt1+pom2*pom_dt2
4856 #ifdef DEBUG
4857         write(2,*), "de_dt = ", de_dt,de_dt_num
4858 #endif
4859 c
4860 C
4861        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4862        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4863        cosfac2xx=cosfac2*xx
4864        sinfac2yy=sinfac2*yy
4865        do k = 1,3
4866          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4867      &      vbld_inv(i+1)
4868          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4869      &      vbld_inv(i)
4870          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4871          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4872 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4873 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4874 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4875 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4876          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4877          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4878          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4879          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4880          dZZ_Ci1(k)=0.0d0
4881          dZZ_Ci(k)=0.0d0
4882          do j=1,3
4883            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4884            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4885          enddo
4886
4887          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4888          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4889          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4890 c
4891          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4892          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4893        enddo
4894
4895        do k=1,3
4896          dXX_Ctab(k,i)=dXX_Ci(k)
4897          dXX_C1tab(k,i)=dXX_Ci1(k)
4898          dYY_Ctab(k,i)=dYY_Ci(k)
4899          dYY_C1tab(k,i)=dYY_Ci1(k)
4900          dZZ_Ctab(k,i)=dZZ_Ci(k)
4901          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4902          dXX_XYZtab(k,i)=dXX_XYZ(k)
4903          dYY_XYZtab(k,i)=dYY_XYZ(k)
4904          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4905        enddo
4906
4907        do k = 1,3
4908 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4909 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4910 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4911 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4912 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4913 c     &    dt_dci(k)
4914 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4915 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4916          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4917      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4918          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4919      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4920          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4921      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4922        enddo
4923 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4924 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4925
4926 C to check gradient call subroutine check_grad
4927
4928     1 continue
4929       enddo
4930       return
4931       end
4932 #endif
4933 c------------------------------------------------------------------------------
4934       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4935 C
4936 C This procedure calculates two-body contact function g(rij) and its derivative:
4937 C
4938 C           eps0ij                                     !       x < -1
4939 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4940 C            0                                         !       x > 1
4941 C
4942 C where x=(rij-r0ij)/delta
4943 C
4944 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4945 C
4946       implicit none
4947       double precision rij,r0ij,eps0ij,fcont,fprimcont
4948       double precision x,x2,x4,delta
4949 c     delta=0.02D0*r0ij
4950 c      delta=0.2D0*r0ij
4951       x=(rij-r0ij)/delta
4952       if (x.lt.-1.0D0) then
4953         fcont=eps0ij
4954         fprimcont=0.0D0
4955       else if (x.le.1.0D0) then
4956         x2=x*x
4957         x4=x2*x2
4958         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4959         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4960       else
4961         fcont=0.0D0
4962         fprimcont=0.0D0
4963       endif
4964       return
4965       end
4966 c------------------------------------------------------------------------------
4967       subroutine splinthet(theti,delta,ss,ssder)
4968       implicit real*8 (a-h,o-z)
4969       include 'DIMENSIONS'
4970       include 'DIMENSIONS.ZSCOPT'
4971       include 'COMMON.VAR'
4972       include 'COMMON.GEO'
4973       thetup=pi-delta
4974       thetlow=delta
4975       if (theti.gt.pipol) then
4976         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4977       else
4978         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4979         ssder=-ssder
4980       endif
4981       return
4982       end
4983 c------------------------------------------------------------------------------
4984       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4985       implicit none
4986       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4987       double precision ksi,ksi2,ksi3,a1,a2,a3
4988       a1=fprim0*delta/(f1-f0)
4989       a2=3.0d0-2.0d0*a1
4990       a3=a1-2.0d0
4991       ksi=(x-x0)/delta
4992       ksi2=ksi*ksi
4993       ksi3=ksi2*ksi
4994       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4995       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4996       return
4997       end
4998 c------------------------------------------------------------------------------
4999       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5000       implicit none
5001       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5002       double precision ksi,ksi2,ksi3,a1,a2,a3
5003       ksi=(x-x0)/delta
5004       ksi2=ksi*ksi
5005       ksi3=ksi2*ksi
5006       a1=fprim0x*delta
5007       a2=3*(f1x-f0x)-2*fprim0x*delta
5008       a3=fprim0x*delta-2*(f1x-f0x)
5009       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5010       return
5011       end
5012 C-----------------------------------------------------------------------------
5013 #ifdef CRYST_TOR
5014 C-----------------------------------------------------------------------------
5015       subroutine etor(etors,edihcnstr,fact)
5016       implicit real*8 (a-h,o-z)
5017       include 'DIMENSIONS'
5018       include 'DIMENSIONS.ZSCOPT'
5019       include 'COMMON.VAR'
5020       include 'COMMON.GEO'
5021       include 'COMMON.LOCAL'
5022       include 'COMMON.TORSION'
5023       include 'COMMON.INTERACT'
5024       include 'COMMON.DERIV'
5025       include 'COMMON.CHAIN'
5026       include 'COMMON.NAMES'
5027       include 'COMMON.IOUNITS'
5028       include 'COMMON.FFIELD'
5029       include 'COMMON.TORCNSTR'
5030       logical lprn
5031 C Set lprn=.true. for debugging
5032       lprn=.false.
5033 c      lprn=.true.
5034       etors=0.0D0
5035       do i=iphi_start,iphi_end
5036         itori=itortyp(itype(i-2))
5037         itori1=itortyp(itype(i-1))
5038         phii=phi(i)
5039         gloci=0.0D0
5040 C Proline-Proline pair is a special case...
5041         if (itori.eq.3 .and. itori1.eq.3) then
5042           if (phii.gt.-dwapi3) then
5043             cosphi=dcos(3*phii)
5044             fac=1.0D0/(1.0D0-cosphi)
5045             etorsi=v1(1,3,3)*fac
5046             etorsi=etorsi+etorsi
5047             etors=etors+etorsi-v1(1,3,3)
5048             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5049           endif
5050           do j=1,3
5051             v1ij=v1(j+1,itori,itori1)
5052             v2ij=v2(j+1,itori,itori1)
5053             cosphi=dcos(j*phii)
5054             sinphi=dsin(j*phii)
5055             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5056             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5057           enddo
5058         else
5059           do j=1,nterm_old
5060             v1ij=v1(j,itori,itori1)
5061             v2ij=v2(j,itori,itori1)
5062             cosphi=dcos(j*phii)
5063             sinphi=dsin(j*phii)
5064             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5065             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5066           enddo
5067         endif
5068         if (lprn)
5069      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5070      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5071      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5072         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5073 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5074       enddo
5075 ! 6/20/98 - dihedral angle constraints
5076       edihcnstr=0.0d0
5077       do i=1,ndih_constr
5078         itori=idih_constr(i)
5079         phii=phi(itori)
5080         difi=phii-phi0(i)
5081         if (difi.gt.drange(i)) then
5082           difi=difi-drange(i)
5083           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5084           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5085         else if (difi.lt.-drange(i)) then
5086           difi=difi+drange(i)
5087           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5088           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5089         endif
5090 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5091 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5092       enddo
5093 !      write (iout,*) 'edihcnstr',edihcnstr
5094       return
5095       end
5096 c------------------------------------------------------------------------------
5097 #else
5098       subroutine etor(etors,edihcnstr,fact)
5099       implicit real*8 (a-h,o-z)
5100       include 'DIMENSIONS'
5101       include 'DIMENSIONS.ZSCOPT'
5102       include 'COMMON.VAR'
5103       include 'COMMON.GEO'
5104       include 'COMMON.LOCAL'
5105       include 'COMMON.TORSION'
5106       include 'COMMON.INTERACT'
5107       include 'COMMON.DERIV'
5108       include 'COMMON.CHAIN'
5109       include 'COMMON.NAMES'
5110       include 'COMMON.IOUNITS'
5111       include 'COMMON.FFIELD'
5112       include 'COMMON.TORCNSTR'
5113       logical lprn
5114 C Set lprn=.true. for debugging
5115       lprn=.false.
5116 c      lprn=.true.
5117       etors=0.0D0
5118       do i=iphi_start,iphi_end
5119         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5120         itori=itortyp(itype(i-2))
5121         itori1=itortyp(itype(i-1))
5122         phii=phi(i)
5123         gloci=0.0D0
5124 C Regular cosine and sine terms
5125         do j=1,nterm(itori,itori1)
5126           v1ij=v1(j,itori,itori1)
5127           v2ij=v2(j,itori,itori1)
5128           cosphi=dcos(j*phii)
5129           sinphi=dsin(j*phii)
5130           etors=etors+v1ij*cosphi+v2ij*sinphi
5131           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5132         enddo
5133 C Lorentz terms
5134 C                         v1
5135 C  E = SUM ----------------------------------- - v1
5136 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5137 C
5138         cosphi=dcos(0.5d0*phii)
5139         sinphi=dsin(0.5d0*phii)
5140         do j=1,nlor(itori,itori1)
5141           vl1ij=vlor1(j,itori,itori1)
5142           vl2ij=vlor2(j,itori,itori1)
5143           vl3ij=vlor3(j,itori,itori1)
5144           pom=vl2ij*cosphi+vl3ij*sinphi
5145           pom1=1.0d0/(pom*pom+1.0d0)
5146           etors=etors+vl1ij*pom1
5147           pom=-pom*pom1*pom1
5148           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5149         enddo
5150 C Subtract the constant term
5151         etors=etors-v0(itori,itori1)
5152         if (lprn)
5153      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5154      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5155      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5156         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5157 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5158  1215   continue
5159       enddo
5160 ! 6/20/98 - dihedral angle constraints
5161       edihcnstr=0.0d0
5162       do i=1,ndih_constr
5163         itori=idih_constr(i)
5164         phii=phi(itori)
5165         difi=pinorm(phii-phi0(i))
5166         edihi=0.0d0
5167         if (difi.gt.drange(i)) then
5168           difi=difi-drange(i)
5169           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5170           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5171           edihi=0.25d0*ftors*difi**4
5172         else if (difi.lt.-drange(i)) then
5173           difi=difi+drange(i)
5174           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5175           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5176           edihi=0.25d0*ftors*difi**4
5177         else
5178           difi=0.0d0
5179         endif
5180 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5181 c     &    drange(i),edihi
5182 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5183 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5184       enddo
5185 !      write (iout,*) 'edihcnstr',edihcnstr
5186       return
5187       end
5188 c----------------------------------------------------------------------------
5189       subroutine etor_d(etors_d,fact2)
5190 C 6/23/01 Compute double torsional energy
5191       implicit real*8 (a-h,o-z)
5192       include 'DIMENSIONS'
5193       include 'DIMENSIONS.ZSCOPT'
5194       include 'COMMON.VAR'
5195       include 'COMMON.GEO'
5196       include 'COMMON.LOCAL'
5197       include 'COMMON.TORSION'
5198       include 'COMMON.INTERACT'
5199       include 'COMMON.DERIV'
5200       include 'COMMON.CHAIN'
5201       include 'COMMON.NAMES'
5202       include 'COMMON.IOUNITS'
5203       include 'COMMON.FFIELD'
5204       include 'COMMON.TORCNSTR'
5205       logical lprn
5206 C Set lprn=.true. for debugging
5207       lprn=.false.
5208 c     lprn=.true.
5209       etors_d=0.0D0
5210       do i=iphi_start,iphi_end-1
5211         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5212      &     goto 1215
5213         itori=itortyp(itype(i-2))
5214         itori1=itortyp(itype(i-1))
5215         itori2=itortyp(itype(i))
5216         phii=phi(i)
5217         phii1=phi(i+1)
5218         gloci1=0.0D0
5219         gloci2=0.0D0
5220 C Regular cosine and sine terms
5221         do j=1,ntermd_1(itori,itori1,itori2)
5222           v1cij=v1c(1,j,itori,itori1,itori2)
5223           v1sij=v1s(1,j,itori,itori1,itori2)
5224           v2cij=v1c(2,j,itori,itori1,itori2)
5225           v2sij=v1s(2,j,itori,itori1,itori2)
5226           cosphi1=dcos(j*phii)
5227           sinphi1=dsin(j*phii)
5228           cosphi2=dcos(j*phii1)
5229           sinphi2=dsin(j*phii1)
5230           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5231      &     v2cij*cosphi2+v2sij*sinphi2
5232           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5233           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5234         enddo
5235         do k=2,ntermd_2(itori,itori1,itori2)
5236           do l=1,k-1
5237             v1cdij = v2c(k,l,itori,itori1,itori2)
5238             v2cdij = v2c(l,k,itori,itori1,itori2)
5239             v1sdij = v2s(k,l,itori,itori1,itori2)
5240             v2sdij = v2s(l,k,itori,itori1,itori2)
5241             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5242             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5243             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5244             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5245             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5246      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5247             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5248      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5249             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5250      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5251           enddo
5252         enddo
5253         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5254         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5255  1215   continue
5256       enddo
5257       return
5258       end
5259 #endif
5260 c------------------------------------------------------------------------------
5261       subroutine eback_sc_corr(esccor)
5262 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5263 c        conformational states; temporarily implemented as differences
5264 c        between UNRES torsional potentials (dependent on three types of
5265 c        residues) and the torsional potentials dependent on all 20 types
5266 c        of residues computed from AM1 energy surfaces of terminally-blocked
5267 c        amino-acid residues.
5268       implicit real*8 (a-h,o-z)
5269       include 'DIMENSIONS'
5270       include 'DIMENSIONS.ZSCOPT'
5271       include 'DIMENSIONS.FREE'
5272       include 'COMMON.VAR'
5273       include 'COMMON.GEO'
5274       include 'COMMON.LOCAL'
5275       include 'COMMON.TORSION'
5276       include 'COMMON.SCCOR'
5277       include 'COMMON.INTERACT'
5278       include 'COMMON.DERIV'
5279       include 'COMMON.CHAIN'
5280       include 'COMMON.NAMES'
5281       include 'COMMON.IOUNITS'
5282       include 'COMMON.FFIELD'
5283       include 'COMMON.CONTROL'
5284       logical lprn
5285 C Set lprn=.true. for debugging
5286       lprn=.false.
5287 c      lprn=.true.
5288 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5289       esccor=0.0D0
5290       do i=itau_start,itau_end
5291         esccor_ii=0.0D0
5292         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5293         isccori=isccortyp(itype(i-2))
5294         isccori1=isccortyp(itype(i-1))
5295         phii=phi(i)
5296 cccc  Added 9 May 2012
5297 cc Tauangle is torsional engle depending on the value of first digit
5298 c(see comment below)
5299 cc Omicron is flat angle depending on the value of first digit
5300 c(see comment below)
5301
5302
5303         do intertyp=1,3 !intertyp
5304 cc Added 09 May 2012 (Adasko)
5305 cc  Intertyp means interaction type of backbone mainchain correlation:
5306 c   1 = SC...Ca...Ca...Ca
5307 c   2 = Ca...Ca...Ca...SC
5308 c   3 = SC...Ca...Ca...SCi
5309         gloci=0.0D0
5310         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5311      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5312      &      (itype(i-1).eq.21)))
5313      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5314      &     .or.(itype(i-2).eq.21)))
5315      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5316      &      (itype(i-1).eq.21)))) cycle
5317         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5318         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5319      & cycle
5320         do j=1,nterm_sccor(isccori,isccori1)
5321           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5322           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5323           cosphi=dcos(j*tauangle(intertyp,i))
5324           sinphi=dsin(j*tauangle(intertyp,i))
5325           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5326 #ifdef DEBUG
5327           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5328 #endif
5329           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5330         enddo
5331         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5332 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5333 c     &gloc_sc(intertyp,i-3,icg)
5334         if (lprn)
5335      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5336      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5337      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5338      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5339         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5340        enddo !intertyp
5341 #ifdef DEBUG
5342        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5343 #endif
5344       enddo
5345 c        do i=1,nres
5346 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5347 c        enddo
5348       return
5349       end
5350 c------------------------------------------------------------------------------
5351       subroutine multibody(ecorr)
5352 C This subroutine calculates multi-body contributions to energy following
5353 C the idea of Skolnick et al. If side chains I and J make a contact and
5354 C at the same time side chains I+1 and J+1 make a contact, an extra
5355 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5356       implicit real*8 (a-h,o-z)
5357       include 'DIMENSIONS'
5358       include 'COMMON.IOUNITS'
5359       include 'COMMON.DERIV'
5360       include 'COMMON.INTERACT'
5361       include 'COMMON.CONTACTS'
5362       double precision gx(3),gx1(3)
5363       logical lprn
5364
5365 C Set lprn=.true. for debugging
5366       lprn=.false.
5367
5368       if (lprn) then
5369         write (iout,'(a)') 'Contact function values:'
5370         do i=nnt,nct-2
5371           write (iout,'(i2,20(1x,i2,f10.5))')
5372      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5373         enddo
5374       endif
5375       ecorr=0.0D0
5376       do i=nnt,nct
5377         do j=1,3
5378           gradcorr(j,i)=0.0D0
5379           gradxorr(j,i)=0.0D0
5380         enddo
5381       enddo
5382       do i=nnt,nct-2
5383
5384         DO ISHIFT = 3,4
5385
5386         i1=i+ishift
5387         num_conti=num_cont(i)
5388         num_conti1=num_cont(i1)
5389         do jj=1,num_conti
5390           j=jcont(jj,i)
5391           do kk=1,num_conti1
5392             j1=jcont(kk,i1)
5393             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5394 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5395 cd   &                   ' ishift=',ishift
5396 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5397 C The system gains extra energy.
5398               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5399             endif   ! j1==j+-ishift
5400           enddo     ! kk
5401         enddo       ! jj
5402
5403         ENDDO ! ISHIFT
5404
5405       enddo         ! i
5406       return
5407       end
5408 c------------------------------------------------------------------------------
5409       double precision function esccorr(i,j,k,l,jj,kk)
5410       implicit real*8 (a-h,o-z)
5411       include 'DIMENSIONS'
5412       include 'COMMON.IOUNITS'
5413       include 'COMMON.DERIV'
5414       include 'COMMON.INTERACT'
5415       include 'COMMON.CONTACTS'
5416       double precision gx(3),gx1(3)
5417       logical lprn
5418       lprn=.false.
5419       eij=facont(jj,i)
5420       ekl=facont(kk,k)
5421 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5422 C Calculate the multi-body contribution to energy.
5423 C Calculate multi-body contributions to the gradient.
5424 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5425 cd   & k,l,(gacont(m,kk,k),m=1,3)
5426       do m=1,3
5427         gx(m) =ekl*gacont(m,jj,i)
5428         gx1(m)=eij*gacont(m,kk,k)
5429         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5430         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5431         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5432         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5433       enddo
5434       do m=i,j-1
5435         do ll=1,3
5436           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5437         enddo
5438       enddo
5439       do m=k,l-1
5440         do ll=1,3
5441           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5442         enddo
5443       enddo
5444       esccorr=-eij*ekl
5445       return
5446       end
5447 c------------------------------------------------------------------------------
5448 #ifdef MPL
5449       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5450       implicit real*8 (a-h,o-z)
5451       include 'DIMENSIONS'
5452       integer dimen1,dimen2,atom,indx
5453       double precision buffer(dimen1,dimen2)
5454       double precision zapas
5455       common /contacts_hb/ zapas(3,20,maxres,7),
5456      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5457      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5458       num_kont=num_cont_hb(atom)
5459       do i=1,num_kont
5460         do k=1,7
5461           do j=1,3
5462             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5463           enddo ! j
5464         enddo ! k
5465         buffer(i,indx+22)=facont_hb(i,atom)
5466         buffer(i,indx+23)=ees0p(i,atom)
5467         buffer(i,indx+24)=ees0m(i,atom)
5468         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5469       enddo ! i
5470       buffer(1,indx+26)=dfloat(num_kont)
5471       return
5472       end
5473 c------------------------------------------------------------------------------
5474       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5475       implicit real*8 (a-h,o-z)
5476       include 'DIMENSIONS'
5477       integer dimen1,dimen2,atom,indx
5478       double precision buffer(dimen1,dimen2)
5479       double precision zapas
5480       common /contacts_hb/ zapas(3,20,maxres,7),
5481      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5482      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5483       num_kont=buffer(1,indx+26)
5484       num_kont_old=num_cont_hb(atom)
5485       num_cont_hb(atom)=num_kont+num_kont_old
5486       do i=1,num_kont
5487         ii=i+num_kont_old
5488         do k=1,7
5489           do j=1,3
5490             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5491           enddo ! j
5492         enddo ! k
5493         facont_hb(ii,atom)=buffer(i,indx+22)
5494         ees0p(ii,atom)=buffer(i,indx+23)
5495         ees0m(ii,atom)=buffer(i,indx+24)
5496         jcont_hb(ii,atom)=buffer(i,indx+25)
5497       enddo ! i
5498       return
5499       end
5500 c------------------------------------------------------------------------------
5501 #endif
5502       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5503 C This subroutine calculates multi-body contributions to hydrogen-bonding
5504       implicit real*8 (a-h,o-z)
5505       include 'DIMENSIONS'
5506       include 'DIMENSIONS.ZSCOPT'
5507       include 'COMMON.IOUNITS'
5508 #ifdef MPL
5509       include 'COMMON.INFO'
5510 #endif
5511       include 'COMMON.FFIELD'
5512       include 'COMMON.DERIV'
5513       include 'COMMON.INTERACT'
5514       include 'COMMON.CONTACTS'
5515 #ifdef MPL
5516       parameter (max_cont=maxconts)
5517       parameter (max_dim=2*(8*3+2))
5518       parameter (msglen1=max_cont*max_dim*4)
5519       parameter (msglen2=2*msglen1)
5520       integer source,CorrelType,CorrelID,Error
5521       double precision buffer(max_cont,max_dim)
5522 #endif
5523       double precision gx(3),gx1(3)
5524       logical lprn,ldone
5525
5526 C Set lprn=.true. for debugging
5527       lprn=.false.
5528 #ifdef MPL
5529       n_corr=0
5530       n_corr1=0
5531       if (fgProcs.le.1) goto 30
5532       if (lprn) then
5533         write (iout,'(a)') 'Contact function values:'
5534         do i=nnt,nct-2
5535           write (iout,'(2i3,50(1x,i2,f5.2))')
5536      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5537      &    j=1,num_cont_hb(i))
5538         enddo
5539       endif
5540 C Caution! Following code assumes that electrostatic interactions concerning
5541 C a given atom are split among at most two processors!
5542       CorrelType=477
5543       CorrelID=MyID+1
5544       ldone=.false.
5545       do i=1,max_cont
5546         do j=1,max_dim
5547           buffer(i,j)=0.0D0
5548         enddo
5549       enddo
5550       mm=mod(MyRank,2)
5551 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5552       if (mm) 20,20,10
5553    10 continue
5554 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5555       if (MyRank.gt.0) then
5556 C Send correlation contributions to the preceding processor
5557         msglen=msglen1
5558         nn=num_cont_hb(iatel_s)
5559         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5560 cd      write (iout,*) 'The BUFFER array:'
5561 cd      do i=1,nn
5562 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5563 cd      enddo
5564         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5565           msglen=msglen2
5566             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5567 C Clear the contacts of the atom passed to the neighboring processor
5568         nn=num_cont_hb(iatel_s+1)
5569 cd      do i=1,nn
5570 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5571 cd      enddo
5572             num_cont_hb(iatel_s)=0
5573         endif
5574 cd      write (iout,*) 'Processor ',MyID,MyRank,
5575 cd   & ' is sending correlation contribution to processor',MyID-1,
5576 cd   & ' msglen=',msglen
5577 cd      write (*,*) 'Processor ',MyID,MyRank,
5578 cd   & ' is sending correlation contribution to processor',MyID-1,
5579 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5580         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5581 cd      write (iout,*) 'Processor ',MyID,
5582 cd   & ' has sent correlation contribution to processor',MyID-1,
5583 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5584 cd      write (*,*) 'Processor ',MyID,
5585 cd   & ' has sent correlation contribution to processor',MyID-1,
5586 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5587         msglen=msglen1
5588       endif ! (MyRank.gt.0)
5589       if (ldone) goto 30
5590       ldone=.true.
5591    20 continue
5592 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5593       if (MyRank.lt.fgProcs-1) then
5594 C Receive correlation contributions from the next processor
5595         msglen=msglen1
5596         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5597 cd      write (iout,*) 'Processor',MyID,
5598 cd   & ' is receiving correlation contribution from processor',MyID+1,
5599 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5600 cd      write (*,*) 'Processor',MyID,
5601 cd   & ' is receiving correlation contribution from processor',MyID+1,
5602 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5603         nbytes=-1
5604         do while (nbytes.le.0)
5605           call mp_probe(MyID+1,CorrelType,nbytes)
5606         enddo
5607 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5608         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5609 cd      write (iout,*) 'Processor',MyID,
5610 cd   & ' has received correlation contribution from processor',MyID+1,
5611 cd   & ' msglen=',msglen,' nbytes=',nbytes
5612 cd      write (iout,*) 'The received BUFFER array:'
5613 cd      do i=1,max_cont
5614 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5615 cd      enddo
5616         if (msglen.eq.msglen1) then
5617           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5618         else if (msglen.eq.msglen2)  then
5619           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5620           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5621         else
5622           write (iout,*)
5623      & 'ERROR!!!! message length changed while processing correlations.'
5624           write (*,*)
5625      & 'ERROR!!!! message length changed while processing correlations.'
5626           call mp_stopall(Error)
5627         endif ! msglen.eq.msglen1
5628       endif ! MyRank.lt.fgProcs-1
5629       if (ldone) goto 30
5630       ldone=.true.
5631       goto 10
5632    30 continue
5633 #endif
5634       if (lprn) then
5635         write (iout,'(a)') 'Contact function values:'
5636         do i=nnt,nct-2
5637           write (iout,'(2i3,50(1x,i2,f5.2))')
5638      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5639      &    j=1,num_cont_hb(i))
5640         enddo
5641       endif
5642       ecorr=0.0D0
5643 C Remove the loop below after debugging !!!
5644       do i=nnt,nct
5645         do j=1,3
5646           gradcorr(j,i)=0.0D0
5647           gradxorr(j,i)=0.0D0
5648         enddo
5649       enddo
5650 C Calculate the local-electrostatic correlation terms
5651       do i=iatel_s,iatel_e+1
5652         i1=i+1
5653         num_conti=num_cont_hb(i)
5654         num_conti1=num_cont_hb(i+1)
5655         do jj=1,num_conti
5656           j=jcont_hb(jj,i)
5657           do kk=1,num_conti1
5658             j1=jcont_hb(kk,i1)
5659 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5660 c     &         ' jj=',jj,' kk=',kk
5661             if (j1.eq.j+1 .or. j1.eq.j-1) then
5662 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5663 C The system gains extra energy.
5664               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5665 #ifdef DEBUG
5666               write (iout,*) "ecorr",i,j,i+1,j1,
5667      &               ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5668 #endif
5669               n_corr=n_corr+1
5670             else if (j1.eq.j) then
5671 C Contacts I-J and I-(J+1) occur simultaneously.
5672 C The system loses extra energy.
5673 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5674             endif
5675           enddo ! kk
5676           do kk=1,num_conti
5677             j1=jcont_hb(kk,i)
5678 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5679 c    &         ' jj=',jj,' kk=',kk
5680             if (j1.eq.j+1) then
5681 C Contacts I-J and (I+1)-J occur simultaneously.
5682 C The system loses extra energy.
5683 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5684             endif ! j1==j+1
5685           enddo ! kk
5686         enddo ! jj
5687       enddo ! i
5688       return
5689       end
5690 c------------------------------------------------------------------------------
5691       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5692      &  n_corr1)
5693 C This subroutine calculates multi-body contributions to hydrogen-bonding
5694       implicit real*8 (a-h,o-z)
5695       include 'DIMENSIONS'
5696       include 'DIMENSIONS.ZSCOPT'
5697       include 'COMMON.IOUNITS'
5698 #ifdef MPL
5699       include 'COMMON.INFO'
5700 #endif
5701       include 'COMMON.FFIELD'
5702       include 'COMMON.DERIV'
5703       include 'COMMON.INTERACT'
5704       include 'COMMON.CONTACTS'
5705 #ifdef MPL
5706       parameter (max_cont=maxconts)
5707       parameter (max_dim=2*(8*3+2))
5708       parameter (msglen1=max_cont*max_dim*4)
5709       parameter (msglen2=2*msglen1)
5710       integer source,CorrelType,CorrelID,Error
5711       double precision buffer(max_cont,max_dim)
5712 #endif
5713       double precision gx(3),gx1(3)
5714       logical lprn,ldone
5715
5716 C Set lprn=.true. for debugging
5717       lprn=.false.
5718       eturn6=0.0d0
5719 #ifdef MPL
5720       n_corr=0
5721       n_corr1=0
5722       if (fgProcs.le.1) goto 30
5723       if (lprn) then
5724         write (iout,'(a)') 'Contact function values:'
5725         do i=nnt,nct-2
5726           write (iout,'(2i3,50(1x,i2,f5.2))')
5727      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5728      &    j=1,num_cont_hb(i))
5729         enddo
5730       endif
5731 C Caution! Following code assumes that electrostatic interactions concerning
5732 C a given atom are split among at most two processors!
5733       CorrelType=477
5734       CorrelID=MyID+1
5735       ldone=.false.
5736       do i=1,max_cont
5737         do j=1,max_dim
5738           buffer(i,j)=0.0D0
5739         enddo
5740       enddo
5741       mm=mod(MyRank,2)
5742 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5743       if (mm) 20,20,10
5744    10 continue
5745 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5746       if (MyRank.gt.0) then
5747 C Send correlation contributions to the preceding processor
5748         msglen=msglen1
5749         nn=num_cont_hb(iatel_s)
5750         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5751 cd      write (iout,*) 'The BUFFER array:'
5752 cd      do i=1,nn
5753 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5754 cd      enddo
5755         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5756           msglen=msglen2
5757             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5758 C Clear the contacts of the atom passed to the neighboring processor
5759         nn=num_cont_hb(iatel_s+1)
5760 cd      do i=1,nn
5761 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5762 cd      enddo
5763             num_cont_hb(iatel_s)=0
5764         endif
5765 cd      write (iout,*) 'Processor ',MyID,MyRank,
5766 cd   & ' is sending correlation contribution to processor',MyID-1,
5767 cd   & ' msglen=',msglen
5768 cd      write (*,*) 'Processor ',MyID,MyRank,
5769 cd   & ' is sending correlation contribution to processor',MyID-1,
5770 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5771         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5772 cd      write (iout,*) 'Processor ',MyID,
5773 cd   & ' has sent correlation contribution to processor',MyID-1,
5774 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5775 cd      write (*,*) 'Processor ',MyID,
5776 cd   & ' has sent correlation contribution to processor',MyID-1,
5777 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5778         msglen=msglen1
5779       endif ! (MyRank.gt.0)
5780       if (ldone) goto 30
5781       ldone=.true.
5782    20 continue
5783 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5784       if (MyRank.lt.fgProcs-1) then
5785 C Receive correlation contributions from the next processor
5786         msglen=msglen1
5787         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5788 cd      write (iout,*) 'Processor',MyID,
5789 cd   & ' is receiving correlation contribution from processor',MyID+1,
5790 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5791 cd      write (*,*) 'Processor',MyID,
5792 cd   & ' is receiving correlation contribution from processor',MyID+1,
5793 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5794         nbytes=-1
5795         do while (nbytes.le.0)
5796           call mp_probe(MyID+1,CorrelType,nbytes)
5797         enddo
5798 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5799         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5800 cd      write (iout,*) 'Processor',MyID,
5801 cd   & ' has received correlation contribution from processor',MyID+1,
5802 cd   & ' msglen=',msglen,' nbytes=',nbytes
5803 cd      write (iout,*) 'The received BUFFER array:'
5804 cd      do i=1,max_cont
5805 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5806 cd      enddo
5807         if (msglen.eq.msglen1) then
5808           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5809         else if (msglen.eq.msglen2)  then
5810           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5811           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5812         else
5813           write (iout,*)
5814      & 'ERROR!!!! message length changed while processing correlations.'
5815           write (*,*)
5816      & 'ERROR!!!! message length changed while processing correlations.'
5817           call mp_stopall(Error)
5818         endif ! msglen.eq.msglen1
5819       endif ! MyRank.lt.fgProcs-1
5820       if (ldone) goto 30
5821       ldone=.true.
5822       goto 10
5823    30 continue
5824 #endif
5825       if (lprn) then
5826         write (iout,'(a)') 'Contact function values:'
5827         do i=nnt,nct-2
5828           write (iout,'(2i3,50(1x,i2,f5.2))')
5829      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5830      &    j=1,num_cont_hb(i))
5831         enddo
5832       endif
5833       ecorr=0.0D0
5834       ecorr5=0.0d0
5835       ecorr6=0.0d0
5836 C Remove the loop below after debugging !!!
5837       do i=nnt,nct
5838         do j=1,3
5839           gradcorr(j,i)=0.0D0
5840           gradxorr(j,i)=0.0D0
5841         enddo
5842       enddo
5843 C Calculate the dipole-dipole interaction energies
5844       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5845       do i=iatel_s,iatel_e+1
5846         num_conti=num_cont_hb(i)
5847         do jj=1,num_conti
5848           j=jcont_hb(jj,i)
5849           call dipole(i,j,jj)
5850         enddo
5851       enddo
5852       endif
5853 C Calculate the local-electrostatic correlation terms
5854       do i=iatel_s,iatel_e+1
5855         i1=i+1
5856         num_conti=num_cont_hb(i)
5857         num_conti1=num_cont_hb(i+1)
5858         do jj=1,num_conti
5859           j=jcont_hb(jj,i)
5860           do kk=1,num_conti1
5861             j1=jcont_hb(kk,i1)
5862 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5863 c     &         ' jj=',jj,' kk=',kk
5864             if (j1.eq.j+1 .or. j1.eq.j-1) then
5865 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5866 C The system gains extra energy.
5867               n_corr=n_corr+1
5868               sqd1=dsqrt(d_cont(jj,i))
5869               sqd2=dsqrt(d_cont(kk,i1))
5870               sred_geom = sqd1*sqd2
5871               IF (sred_geom.lt.cutoff_corr) THEN
5872                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5873      &            ekont,fprimcont)
5874 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5875 c     &         ' jj=',jj,' kk=',kk
5876                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5877                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5878                 do l=1,3
5879                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5880                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5881                 enddo
5882                 n_corr1=n_corr1+1
5883 cd               write (iout,*) 'sred_geom=',sred_geom,
5884 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5885                 call calc_eello(i,j,i+1,j1,jj,kk)
5886                 if (wcorr4.gt.0.0d0)
5887      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5888                 if (wcorr5.gt.0.0d0)
5889      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5890 c                print *,"wcorr5",ecorr5
5891 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5892 cd                write(2,*)'ijkl',i,j,i+1,j1
5893                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5894      &               .or. wturn6.eq.0.0d0))then
5895 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5896                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5897 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5898 cd     &            'ecorr6=',ecorr6
5899 cd                write (iout,'(4e15.5)') sred_geom,
5900 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5901 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5902 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5903                 else if (wturn6.gt.0.0d0
5904      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5905 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5906                   eturn6=eturn6+eello_turn6(i,jj,kk)
5907 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5908                 endif
5909               ENDIF
5910 1111          continue
5911             else if (j1.eq.j) then
5912 C Contacts I-J and I-(J+1) occur simultaneously.
5913 C The system loses extra energy.
5914 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5915             endif
5916           enddo ! kk
5917           do kk=1,num_conti
5918             j1=jcont_hb(kk,i)
5919 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5920 c    &         ' jj=',jj,' kk=',kk
5921             if (j1.eq.j+1) then
5922 C Contacts I-J and (I+1)-J occur simultaneously.
5923 C The system loses extra energy.
5924 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5925             endif ! j1==j+1
5926           enddo ! kk
5927         enddo ! jj
5928       enddo ! i
5929       return
5930       end
5931 c------------------------------------------------------------------------------
5932       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5933       implicit real*8 (a-h,o-z)
5934       include 'DIMENSIONS'
5935       include 'COMMON.IOUNITS'
5936       include 'COMMON.DERIV'
5937       include 'COMMON.INTERACT'
5938       include 'COMMON.CONTACTS'
5939       double precision gx(3),gx1(3)
5940       logical lprn
5941       lprn=.false.
5942       eij=facont_hb(jj,i)
5943       ekl=facont_hb(kk,k)
5944       ees0pij=ees0p(jj,i)
5945       ees0pkl=ees0p(kk,k)
5946       ees0mij=ees0m(jj,i)
5947       ees0mkl=ees0m(kk,k)
5948       ekont=eij*ekl
5949       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5950 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5951 C Following 4 lines for diagnostics.
5952 cd    ees0pkl=0.0D0
5953 cd    ees0pij=1.0D0
5954 cd    ees0mkl=0.0D0
5955 cd    ees0mij=1.0D0
5956 cd      write (iout,*)'Contacts have occurred for peptide groups',i,j,
5957 cd     &   ' and',k,l
5958 cd      write (iout,*)'Contacts have occurred for peptide groups',
5959 cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5960 cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5961 C Calculate the multi-body contribution to energy.
5962       ecorr=ecorr+ekont*ees
5963       if (calc_grad) then
5964 C Calculate multi-body contributions to the gradient.
5965       do ll=1,3
5966         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5967         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5968      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5969      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5970         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5971      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5972      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5973         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5974         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5975      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5976      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5977         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5978      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5979      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5980       enddo
5981       do m=i+1,j-1
5982         do ll=1,3
5983           gradcorr(ll,m)=gradcorr(ll,m)+
5984      &     ees*ekl*gacont_hbr(ll,jj,i)-
5985      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5986      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5987         enddo
5988       enddo
5989       do m=k+1,l-1
5990         do ll=1,3
5991           gradcorr(ll,m)=gradcorr(ll,m)+
5992      &     ees*eij*gacont_hbr(ll,kk,k)-
5993      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5994      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5995         enddo
5996       enddo
5997       endif
5998       ehbcorr=ekont*ees
5999       return
6000       end
6001 C---------------------------------------------------------------------------
6002       subroutine dipole(i,j,jj)
6003       implicit real*8 (a-h,o-z)
6004       include 'DIMENSIONS'
6005       include 'DIMENSIONS.ZSCOPT'
6006       include 'COMMON.IOUNITS'
6007       include 'COMMON.CHAIN'
6008       include 'COMMON.FFIELD'
6009       include 'COMMON.DERIV'
6010       include 'COMMON.INTERACT'
6011       include 'COMMON.CONTACTS'
6012       include 'COMMON.TORSION'
6013       include 'COMMON.VAR'
6014       include 'COMMON.GEO'
6015       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6016      &  auxmat(2,2)
6017       iti1 = itortyp(itype(i+1))
6018       if (j.lt.nres-1) then
6019         itj1 = itortyp(itype(j+1))
6020       else
6021         itj1=ntortyp+1
6022       endif
6023       do iii=1,2
6024         dipi(iii,1)=Ub2(iii,i)
6025         dipderi(iii)=Ub2der(iii,i)
6026         dipi(iii,2)=b1(iii,iti1)
6027         dipj(iii,1)=Ub2(iii,j)
6028         dipderj(iii)=Ub2der(iii,j)
6029         dipj(iii,2)=b1(iii,itj1)
6030       enddo
6031       kkk=0
6032       do iii=1,2
6033         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6034         do jjj=1,2
6035           kkk=kkk+1
6036           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6037         enddo
6038       enddo
6039       if (.not.calc_grad) return
6040       do kkk=1,5
6041         do lll=1,3
6042           mmm=0
6043           do iii=1,2
6044             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6045      &        auxvec(1))
6046             do jjj=1,2
6047               mmm=mmm+1
6048               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6049             enddo
6050           enddo
6051         enddo
6052       enddo
6053       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6054       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6055       do iii=1,2
6056         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6057       enddo
6058       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6059       do iii=1,2
6060         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6061       enddo
6062       return
6063       end
6064 C---------------------------------------------------------------------------
6065       subroutine calc_eello(i,j,k,l,jj,kk)
6066 C
6067 C This subroutine computes matrices and vectors needed to calculate
6068 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6069 C
6070       implicit real*8 (a-h,o-z)
6071       include 'DIMENSIONS'
6072       include 'DIMENSIONS.ZSCOPT'
6073       include 'COMMON.IOUNITS'
6074       include 'COMMON.CHAIN'
6075       include 'COMMON.DERIV'
6076       include 'COMMON.INTERACT'
6077       include 'COMMON.CONTACTS'
6078       include 'COMMON.TORSION'
6079       include 'COMMON.VAR'
6080       include 'COMMON.GEO'
6081       include 'COMMON.FFIELD'
6082       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6083      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6084       logical lprn
6085       common /kutas/ lprn
6086 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6087 cd     & ' jj=',jj,' kk=',kk
6088 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6089       do iii=1,2
6090         do jjj=1,2
6091           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6092           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6093         enddo
6094       enddo
6095       call transpose2(aa1(1,1),aa1t(1,1))
6096       call transpose2(aa2(1,1),aa2t(1,1))
6097       do kkk=1,5
6098         do lll=1,3
6099           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6100      &      aa1tder(1,1,lll,kkk))
6101           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6102      &      aa2tder(1,1,lll,kkk))
6103         enddo
6104       enddo
6105       if (l.eq.j+1) then
6106 C parallel orientation of the two CA-CA-CA frames.
6107         if (i.gt.1) then
6108           iti=itortyp(itype(i))
6109         else
6110           iti=ntortyp+1
6111         endif
6112         itk1=itortyp(itype(k+1))
6113         itj=itortyp(itype(j))
6114         if (l.lt.nres-1) then
6115           itl1=itortyp(itype(l+1))
6116         else
6117           itl1=ntortyp+1
6118         endif
6119 C A1 kernel(j+1) A2T
6120 cd        do iii=1,2
6121 cd          write (iout,'(3f10.5,5x,3f10.5)')
6122 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6123 cd        enddo
6124         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6125      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6126      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6127 C Following matrices are needed only for 6-th order cumulants
6128         IF (wcorr6.gt.0.0d0) THEN
6129         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6130      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6131      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6133      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6134      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6135      &   ADtEAderx(1,1,1,1,1,1))
6136         lprn=.false.
6137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6138      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6139      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6140      &   ADtEA1derx(1,1,1,1,1,1))
6141         ENDIF
6142 C End 6-th order cumulants
6143 cd        lprn=.false.
6144 cd        if (lprn) then
6145 cd        write (2,*) 'In calc_eello6'
6146 cd        do iii=1,2
6147 cd          write (2,*) 'iii=',iii
6148 cd          do kkk=1,5
6149 cd            write (2,*) 'kkk=',kkk
6150 cd            do jjj=1,2
6151 cd              write (2,'(3(2f10.5),5x)')
6152 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6153 cd            enddo
6154 cd          enddo
6155 cd        enddo
6156 cd        endif
6157         call transpose2(EUgder(1,1,k),auxmat(1,1))
6158         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6159         call transpose2(EUg(1,1,k),auxmat(1,1))
6160         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6161         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6162         do iii=1,2
6163           do kkk=1,5
6164             do lll=1,3
6165               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6166      &          EAEAderx(1,1,lll,kkk,iii,1))
6167             enddo
6168           enddo
6169         enddo
6170 C A1T kernel(i+1) A2
6171         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6172      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6173      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6174 C Following matrices are needed only for 6-th order cumulants
6175         IF (wcorr6.gt.0.0d0) THEN
6176         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6177      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6178      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6179         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6180      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6181      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6182      &   ADtEAderx(1,1,1,1,1,2))
6183         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6184      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6185      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6186      &   ADtEA1derx(1,1,1,1,1,2))
6187         ENDIF
6188 C End 6-th order cumulants
6189         call transpose2(EUgder(1,1,l),auxmat(1,1))
6190         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6191         call transpose2(EUg(1,1,l),auxmat(1,1))
6192         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6193         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6194         do iii=1,2
6195           do kkk=1,5
6196             do lll=1,3
6197               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6198      &          EAEAderx(1,1,lll,kkk,iii,2))
6199             enddo
6200           enddo
6201         enddo
6202 C AEAb1 and AEAb2
6203 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6204 C They are needed only when the fifth- or the sixth-order cumulants are
6205 C indluded.
6206         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6207         call transpose2(AEA(1,1,1),auxmat(1,1))
6208         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6209         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6210         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6211         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6212         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6213         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6214         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6215         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6216         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6217         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6218         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6219         call transpose2(AEA(1,1,2),auxmat(1,1))
6220         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6221         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6222         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6223         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6224         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6225         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6226         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6227         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6228         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6229         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6230         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6231 C Calculate the Cartesian derivatives of the vectors.
6232         do iii=1,2
6233           do kkk=1,5
6234             do lll=1,3
6235               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6236               call matvec2(auxmat(1,1),b1(1,iti),
6237      &          AEAb1derx(1,lll,kkk,iii,1,1))
6238               call matvec2(auxmat(1,1),Ub2(1,i),
6239      &          AEAb2derx(1,lll,kkk,iii,1,1))
6240               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6241      &          AEAb1derx(1,lll,kkk,iii,2,1))
6242               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6243      &          AEAb2derx(1,lll,kkk,iii,2,1))
6244               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6245               call matvec2(auxmat(1,1),b1(1,itj),
6246      &          AEAb1derx(1,lll,kkk,iii,1,2))
6247               call matvec2(auxmat(1,1),Ub2(1,j),
6248      &          AEAb2derx(1,lll,kkk,iii,1,2))
6249               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6250      &          AEAb1derx(1,lll,kkk,iii,2,2))
6251               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6252      &          AEAb2derx(1,lll,kkk,iii,2,2))
6253             enddo
6254           enddo
6255         enddo
6256         ENDIF
6257 C End vectors
6258       else
6259 C Antiparallel orientation of the two CA-CA-CA frames.
6260         if (i.gt.1) then
6261           iti=itortyp(itype(i))
6262         else
6263           iti=ntortyp+1
6264         endif
6265         itk1=itortyp(itype(k+1))
6266         itl=itortyp(itype(l))
6267         itj=itortyp(itype(j))
6268         if (j.lt.nres-1) then
6269           itj1=itortyp(itype(j+1))
6270         else
6271           itj1=ntortyp+1
6272         endif
6273 C A2 kernel(j-1)T A1T
6274         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6275      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6276      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6277 C Following matrices are needed only for 6-th order cumulants
6278         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6279      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6280         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6281      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6282      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6283         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6284      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6285      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6286      &   ADtEAderx(1,1,1,1,1,1))
6287         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6288      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6289      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6290      &   ADtEA1derx(1,1,1,1,1,1))
6291         ENDIF
6292 C End 6-th order cumulants
6293         call transpose2(EUgder(1,1,k),auxmat(1,1))
6294         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6295         call transpose2(EUg(1,1,k),auxmat(1,1))
6296         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6297         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6298         do iii=1,2
6299           do kkk=1,5
6300             do lll=1,3
6301               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6302      &          EAEAderx(1,1,lll,kkk,iii,1))
6303             enddo
6304           enddo
6305         enddo
6306 C A2T kernel(i+1)T A1
6307         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6308      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6309      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6310 C Following matrices are needed only for 6-th order cumulants
6311         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6312      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6313         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6314      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6315      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6316         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6317      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6318      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6319      &   ADtEAderx(1,1,1,1,1,2))
6320         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6321      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6322      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6323      &   ADtEA1derx(1,1,1,1,1,2))
6324         ENDIF
6325 C End 6-th order cumulants
6326         call transpose2(EUgder(1,1,j),auxmat(1,1))
6327         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6328         call transpose2(EUg(1,1,j),auxmat(1,1))
6329         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6330         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6331         do iii=1,2
6332           do kkk=1,5
6333             do lll=1,3
6334               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6335      &          EAEAderx(1,1,lll,kkk,iii,2))
6336             enddo
6337           enddo
6338         enddo
6339 C AEAb1 and AEAb2
6340 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6341 C They are needed only when the fifth- or the sixth-order cumulants are
6342 C indluded.
6343         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6344      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6345         call transpose2(AEA(1,1,1),auxmat(1,1))
6346         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6347         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6348         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6349         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6350         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6351         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6352         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6353         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6354         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6355         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6356         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6357         call transpose2(AEA(1,1,2),auxmat(1,1))
6358         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6359         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6360         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6361         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6362         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6363         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6364         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6365         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6366         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6367         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6368         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6369 C Calculate the Cartesian derivatives of the vectors.
6370         do iii=1,2
6371           do kkk=1,5
6372             do lll=1,3
6373               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6374               call matvec2(auxmat(1,1),b1(1,iti),
6375      &          AEAb1derx(1,lll,kkk,iii,1,1))
6376               call matvec2(auxmat(1,1),Ub2(1,i),
6377      &          AEAb2derx(1,lll,kkk,iii,1,1))
6378               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6379      &          AEAb1derx(1,lll,kkk,iii,2,1))
6380               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6381      &          AEAb2derx(1,lll,kkk,iii,2,1))
6382               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6383               call matvec2(auxmat(1,1),b1(1,itl),
6384      &          AEAb1derx(1,lll,kkk,iii,1,2))
6385               call matvec2(auxmat(1,1),Ub2(1,l),
6386      &          AEAb2derx(1,lll,kkk,iii,1,2))
6387               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6388      &          AEAb1derx(1,lll,kkk,iii,2,2))
6389               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6390      &          AEAb2derx(1,lll,kkk,iii,2,2))
6391             enddo
6392           enddo
6393         enddo
6394         ENDIF
6395 C End vectors
6396       endif
6397       return
6398       end
6399 C---------------------------------------------------------------------------
6400       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6401      &  KK,KKderg,AKA,AKAderg,AKAderx)
6402       implicit none
6403       integer nderg
6404       logical transp
6405       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6406      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6407      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6408       integer iii,kkk,lll
6409       integer jjj,mmm
6410       logical lprn
6411       common /kutas/ lprn
6412       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6413       do iii=1,nderg
6414         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6415      &    AKAderg(1,1,iii))
6416       enddo
6417 cd      if (lprn) write (2,*) 'In kernel'
6418       do kkk=1,5
6419 cd        if (lprn) write (2,*) 'kkk=',kkk
6420         do lll=1,3
6421           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6422      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6423 cd          if (lprn) then
6424 cd            write (2,*) 'lll=',lll
6425 cd            write (2,*) 'iii=1'
6426 cd            do jjj=1,2
6427 cd              write (2,'(3(2f10.5),5x)')
6428 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6429 cd            enddo
6430 cd          endif
6431           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6432      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6433 cd          if (lprn) then
6434 cd            write (2,*) 'lll=',lll
6435 cd            write (2,*) 'iii=2'
6436 cd            do jjj=1,2
6437 cd              write (2,'(3(2f10.5),5x)')
6438 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6439 cd            enddo
6440 cd          endif
6441         enddo
6442       enddo
6443       return
6444       end
6445 C---------------------------------------------------------------------------
6446       double precision function eello4(i,j,k,l,jj,kk)
6447       implicit real*8 (a-h,o-z)
6448       include 'DIMENSIONS'
6449       include 'DIMENSIONS.ZSCOPT'
6450       include 'COMMON.IOUNITS'
6451       include 'COMMON.CHAIN'
6452       include 'COMMON.DERIV'
6453       include 'COMMON.INTERACT'
6454       include 'COMMON.CONTACTS'
6455       include 'COMMON.TORSION'
6456       include 'COMMON.VAR'
6457       include 'COMMON.GEO'
6458       double precision pizda(2,2),ggg1(3),ggg2(3)
6459 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6460 cd        eello4=0.0d0
6461 cd        return
6462 cd      endif
6463 cd      print *,'eello4:',i,j,k,l,jj,kk
6464 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6465 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6466 cold      eij=facont_hb(jj,i)
6467 cold      ekl=facont_hb(kk,k)
6468 cold      ekont=eij*ekl
6469       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6470       if (calc_grad) then
6471 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6472       gcorr_loc(k-1)=gcorr_loc(k-1)
6473      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6474       if (l.eq.j+1) then
6475         gcorr_loc(l-1)=gcorr_loc(l-1)
6476      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6477       else
6478         gcorr_loc(j-1)=gcorr_loc(j-1)
6479      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6480       endif
6481       do iii=1,2
6482         do kkk=1,5
6483           do lll=1,3
6484             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6485      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6486 cd            derx(lll,kkk,iii)=0.0d0
6487           enddo
6488         enddo
6489       enddo
6490 cd      gcorr_loc(l-1)=0.0d0
6491 cd      gcorr_loc(j-1)=0.0d0
6492 cd      gcorr_loc(k-1)=0.0d0
6493 cd      eel4=1.0d0
6494 cd      write (iout,*)'Contacts have occurred for peptide groups',
6495 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6496 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6497       if (j.lt.nres-1) then
6498         j1=j+1
6499         j2=j-1
6500       else
6501         j1=j-1
6502         j2=j-2
6503       endif
6504       if (l.lt.nres-1) then
6505         l1=l+1
6506         l2=l-1
6507       else
6508         l1=l-1
6509         l2=l-2
6510       endif
6511       do ll=1,3
6512 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6513         ggg1(ll)=eel4*g_contij(ll,1)
6514         ggg2(ll)=eel4*g_contij(ll,2)
6515         ghalf=0.5d0*ggg1(ll)
6516 cd        ghalf=0.0d0
6517         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6518         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6519         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6520         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6521 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6522         ghalf=0.5d0*ggg2(ll)
6523 cd        ghalf=0.0d0
6524         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6525         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6526         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6527         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6528       enddo
6529 cd      goto 1112
6530       do m=i+1,j-1
6531         do ll=1,3
6532 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6533           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6534         enddo
6535       enddo
6536       do m=k+1,l-1
6537         do ll=1,3
6538 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6539           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6540         enddo
6541       enddo
6542 1112  continue
6543       do m=i+2,j2
6544         do ll=1,3
6545           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6546         enddo
6547       enddo
6548       do m=k+2,l2
6549         do ll=1,3
6550           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6551         enddo
6552       enddo
6553 cd      do iii=1,nres-3
6554 cd        write (2,*) iii,gcorr_loc(iii)
6555 cd      enddo
6556       endif
6557       eello4=ekont*eel4
6558 cd      write (2,*) 'ekont',ekont
6559 cd      write (iout,*) 'eello4',ekont*eel4
6560       return
6561       end
6562 C---------------------------------------------------------------------------
6563       double precision function eello5(i,j,k,l,jj,kk)
6564       implicit real*8 (a-h,o-z)
6565       include 'DIMENSIONS'
6566       include 'DIMENSIONS.ZSCOPT'
6567       include 'COMMON.IOUNITS'
6568       include 'COMMON.CHAIN'
6569       include 'COMMON.DERIV'
6570       include 'COMMON.INTERACT'
6571       include 'COMMON.CONTACTS'
6572       include 'COMMON.TORSION'
6573       include 'COMMON.VAR'
6574       include 'COMMON.GEO'
6575       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6576       double precision ggg1(3),ggg2(3)
6577 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6578 C                                                                              C
6579 C                            Parallel chains                                   C
6580 C                                                                              C
6581 C          o             o                   o             o                   C
6582 C         /l\           / \             \   / \           / \   /              C
6583 C        /   \         /   \             \ /   \         /   \ /               C
6584 C       j| o |l1       | o |              o| o |         | o |o                C
6585 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6586 C      \i/   \         /   \ /             /   \         /   \                 C
6587 C       o    k1             o                                                  C
6588 C         (I)          (II)                (III)          (IV)                 C
6589 C                                                                              C
6590 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6591 C                                                                              C
6592 C                            Antiparallel chains                               C
6593 C                                                                              C
6594 C          o             o                   o             o                   C
6595 C         /j\           / \             \   / \           / \   /              C
6596 C        /   \         /   \             \ /   \         /   \ /               C
6597 C      j1| o |l        | o |              o| o |         | o |o                C
6598 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6599 C      \i/   \         /   \ /             /   \         /   \                 C
6600 C       o     k1            o                                                  C
6601 C         (I)          (II)                (III)          (IV)                 C
6602 C                                                                              C
6603 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6604 C                                                                              C
6605 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6606 C                                                                              C
6607 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6608 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6609 cd        eello5=0.0d0
6610 cd        return
6611 cd      endif
6612 cd      write (iout,*)
6613 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6614 cd     &   ' and',k,l
6615       itk=itortyp(itype(k))
6616       itl=itortyp(itype(l))
6617       itj=itortyp(itype(j))
6618       eello5_1=0.0d0
6619       eello5_2=0.0d0
6620       eello5_3=0.0d0
6621       eello5_4=0.0d0
6622 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6623 cd     &   eel5_3_num,eel5_4_num)
6624       do iii=1,2
6625         do kkk=1,5
6626           do lll=1,3
6627             derx(lll,kkk,iii)=0.0d0
6628           enddo
6629         enddo
6630       enddo
6631 cd      eij=facont_hb(jj,i)
6632 cd      ekl=facont_hb(kk,k)
6633 cd      ekont=eij*ekl
6634 cd      write (iout,*)'Contacts have occurred for peptide groups',
6635 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6636 cd      goto 1111
6637 C Contribution from the graph I.
6638 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6639 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6640       call transpose2(EUg(1,1,k),auxmat(1,1))
6641       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6642       vv(1)=pizda(1,1)-pizda(2,2)
6643       vv(2)=pizda(1,2)+pizda(2,1)
6644       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6645      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6646       if (calc_grad) then
6647 C Explicit gradient in virtual-dihedral angles.
6648       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6649      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6650      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6651       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6652       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6653       vv(1)=pizda(1,1)-pizda(2,2)
6654       vv(2)=pizda(1,2)+pizda(2,1)
6655       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6656      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6657      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6658       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6659       vv(1)=pizda(1,1)-pizda(2,2)
6660       vv(2)=pizda(1,2)+pizda(2,1)
6661       if (l.eq.j+1) then
6662         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6663      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6664      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6665       else
6666         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6667      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6668      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6669       endif
6670 C Cartesian gradient
6671       do iii=1,2
6672         do kkk=1,5
6673           do lll=1,3
6674             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6675      &        pizda(1,1))
6676             vv(1)=pizda(1,1)-pizda(2,2)
6677             vv(2)=pizda(1,2)+pizda(2,1)
6678             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6679      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6680      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6681           enddo
6682         enddo
6683       enddo
6684 c      goto 1112
6685       endif
6686 c1111  continue
6687 C Contribution from graph II
6688       call transpose2(EE(1,1,itk),auxmat(1,1))
6689       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6690       vv(1)=pizda(1,1)+pizda(2,2)
6691       vv(2)=pizda(2,1)-pizda(1,2)
6692       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6693      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6694       if (calc_grad) then
6695 C Explicit gradient in virtual-dihedral angles.
6696       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6697      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6698       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6699       vv(1)=pizda(1,1)+pizda(2,2)
6700       vv(2)=pizda(2,1)-pizda(1,2)
6701       if (l.eq.j+1) then
6702         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6703      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6704      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6705       else
6706         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6707      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6708      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6709       endif
6710 C Cartesian gradient
6711       do iii=1,2
6712         do kkk=1,5
6713           do lll=1,3
6714             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6715      &        pizda(1,1))
6716             vv(1)=pizda(1,1)+pizda(2,2)
6717             vv(2)=pizda(2,1)-pizda(1,2)
6718             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6719      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6720      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6721           enddo
6722         enddo
6723       enddo
6724 cd      goto 1112
6725       endif
6726 cd1111  continue
6727       if (l.eq.j+1) then
6728 cd        goto 1110
6729 C Parallel orientation
6730 C Contribution from graph III
6731         call transpose2(EUg(1,1,l),auxmat(1,1))
6732         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6733         vv(1)=pizda(1,1)-pizda(2,2)
6734         vv(2)=pizda(1,2)+pizda(2,1)
6735         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6736      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6737         if (calc_grad) then
6738 C Explicit gradient in virtual-dihedral angles.
6739         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6740      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6741      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6742         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6743         vv(1)=pizda(1,1)-pizda(2,2)
6744         vv(2)=pizda(1,2)+pizda(2,1)
6745         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6746      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6747      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6748         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6749         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6750         vv(1)=pizda(1,1)-pizda(2,2)
6751         vv(2)=pizda(1,2)+pizda(2,1)
6752         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6753      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6754      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6755 C Cartesian gradient
6756         do iii=1,2
6757           do kkk=1,5
6758             do lll=1,3
6759               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6760      &          pizda(1,1))
6761               vv(1)=pizda(1,1)-pizda(2,2)
6762               vv(2)=pizda(1,2)+pizda(2,1)
6763               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6764      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6765      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6766             enddo
6767           enddo
6768         enddo
6769 cd        goto 1112
6770         endif
6771 C Contribution from graph IV
6772 cd1110    continue
6773         call transpose2(EE(1,1,itl),auxmat(1,1))
6774         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6775         vv(1)=pizda(1,1)+pizda(2,2)
6776         vv(2)=pizda(2,1)-pizda(1,2)
6777         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6778      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6779         if (calc_grad) then
6780 C Explicit gradient in virtual-dihedral angles.
6781         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6782      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6783         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6784         vv(1)=pizda(1,1)+pizda(2,2)
6785         vv(2)=pizda(2,1)-pizda(1,2)
6786         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6787      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6788      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6789 C Cartesian gradient
6790         do iii=1,2
6791           do kkk=1,5
6792             do lll=1,3
6793               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6794      &          pizda(1,1))
6795               vv(1)=pizda(1,1)+pizda(2,2)
6796               vv(2)=pizda(2,1)-pizda(1,2)
6797               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6798      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6799      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6800             enddo
6801           enddo
6802         enddo
6803         endif
6804       else
6805 C Antiparallel orientation
6806 C Contribution from graph III
6807 c        goto 1110
6808         call transpose2(EUg(1,1,j),auxmat(1,1))
6809         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6810         vv(1)=pizda(1,1)-pizda(2,2)
6811         vv(2)=pizda(1,2)+pizda(2,1)
6812         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6813      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6814         if (calc_grad) then
6815 C Explicit gradient in virtual-dihedral angles.
6816         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6817      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6818      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6819         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6820         vv(1)=pizda(1,1)-pizda(2,2)
6821         vv(2)=pizda(1,2)+pizda(2,1)
6822         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6823      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6824      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6825         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6826         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6827         vv(1)=pizda(1,1)-pizda(2,2)
6828         vv(2)=pizda(1,2)+pizda(2,1)
6829         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6830      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6831      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6832 C Cartesian gradient
6833         do iii=1,2
6834           do kkk=1,5
6835             do lll=1,3
6836               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6837      &          pizda(1,1))
6838               vv(1)=pizda(1,1)-pizda(2,2)
6839               vv(2)=pizda(1,2)+pizda(2,1)
6840               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6841      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6842      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6843             enddo
6844           enddo
6845         enddo
6846 cd        goto 1112
6847         endif
6848 C Contribution from graph IV
6849 1110    continue
6850         call transpose2(EE(1,1,itj),auxmat(1,1))
6851         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6852         vv(1)=pizda(1,1)+pizda(2,2)
6853         vv(2)=pizda(2,1)-pizda(1,2)
6854         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6855      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6856         if (calc_grad) then
6857 C Explicit gradient in virtual-dihedral angles.
6858         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6859      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6860         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6861         vv(1)=pizda(1,1)+pizda(2,2)
6862         vv(2)=pizda(2,1)-pizda(1,2)
6863         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6864      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6865      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6866 C Cartesian gradient
6867         do iii=1,2
6868           do kkk=1,5
6869             do lll=1,3
6870               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6871      &          pizda(1,1))
6872               vv(1)=pizda(1,1)+pizda(2,2)
6873               vv(2)=pizda(2,1)-pizda(1,2)
6874               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6875      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6876      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6877             enddo
6878           enddo
6879         enddo
6880       endif
6881       endif
6882 1112  continue
6883       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6884 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6885 cd        write (2,*) 'ijkl',i,j,k,l
6886 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6887 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6888 cd      endif
6889 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6890 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6891 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6892 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6893       if (calc_grad) then
6894       if (j.lt.nres-1) then
6895         j1=j+1
6896         j2=j-1
6897       else
6898         j1=j-1
6899         j2=j-2
6900       endif
6901       if (l.lt.nres-1) then
6902         l1=l+1
6903         l2=l-1
6904       else
6905         l1=l-1
6906         l2=l-2
6907       endif
6908 cd      eij=1.0d0
6909 cd      ekl=1.0d0
6910 cd      ekont=1.0d0
6911 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6912       do ll=1,3
6913         ggg1(ll)=eel5*g_contij(ll,1)
6914         ggg2(ll)=eel5*g_contij(ll,2)
6915 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6916         ghalf=0.5d0*ggg1(ll)
6917 cd        ghalf=0.0d0
6918         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6919         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6920         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6921         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6922 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6923         ghalf=0.5d0*ggg2(ll)
6924 cd        ghalf=0.0d0
6925         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6926         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6927         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6928         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6929       enddo
6930 cd      goto 1112
6931       do m=i+1,j-1
6932         do ll=1,3
6933 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6934           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6935         enddo
6936       enddo
6937       do m=k+1,l-1
6938         do ll=1,3
6939 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6940           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6941         enddo
6942       enddo
6943 c1112  continue
6944       do m=i+2,j2
6945         do ll=1,3
6946           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6947         enddo
6948       enddo
6949       do m=k+2,l2
6950         do ll=1,3
6951           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6952         enddo
6953       enddo
6954 cd      do iii=1,nres-3
6955 cd        write (2,*) iii,g_corr5_loc(iii)
6956 cd      enddo
6957       endif
6958       eello5=ekont*eel5
6959 cd      write (2,*) 'ekont',ekont
6960 cd      write (iout,*) 'eello5',ekont*eel5
6961       return
6962       end
6963 c--------------------------------------------------------------------------
6964       double precision function eello6(i,j,k,l,jj,kk)
6965       implicit real*8 (a-h,o-z)
6966       include 'DIMENSIONS'
6967       include 'DIMENSIONS.ZSCOPT'
6968       include 'COMMON.IOUNITS'
6969       include 'COMMON.CHAIN'
6970       include 'COMMON.DERIV'
6971       include 'COMMON.INTERACT'
6972       include 'COMMON.CONTACTS'
6973       include 'COMMON.TORSION'
6974       include 'COMMON.VAR'
6975       include 'COMMON.GEO'
6976       include 'COMMON.FFIELD'
6977       double precision ggg1(3),ggg2(3)
6978 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6979 cd        eello6=0.0d0
6980 cd        return
6981 cd      endif
6982 cd      write (iout,*)
6983 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6984 cd     &   ' and',k,l
6985       eello6_1=0.0d0
6986       eello6_2=0.0d0
6987       eello6_3=0.0d0
6988       eello6_4=0.0d0
6989       eello6_5=0.0d0
6990       eello6_6=0.0d0
6991 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6992 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6993       do iii=1,2
6994         do kkk=1,5
6995           do lll=1,3
6996             derx(lll,kkk,iii)=0.0d0
6997           enddo
6998         enddo
6999       enddo
7000 cd      eij=facont_hb(jj,i)
7001 cd      ekl=facont_hb(kk,k)
7002 cd      ekont=eij*ekl
7003 cd      eij=1.0d0
7004 cd      ekl=1.0d0
7005 cd      ekont=1.0d0
7006       if (l.eq.j+1) then
7007         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7008         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7009         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7010         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7011         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7012         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7013       else
7014         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7015         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7016         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7017         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7018         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7019           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7020         else
7021           eello6_5=0.0d0
7022         endif
7023         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7024       endif
7025 C If turn contributions are considered, they will be handled separately.
7026       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7027 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7028 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7029 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7030 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7031 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7032 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7033 cd      goto 1112
7034       if (calc_grad) then
7035       if (j.lt.nres-1) then
7036         j1=j+1
7037         j2=j-1
7038       else
7039         j1=j-1
7040         j2=j-2
7041       endif
7042       if (l.lt.nres-1) then
7043         l1=l+1
7044         l2=l-1
7045       else
7046         l1=l-1
7047         l2=l-2
7048       endif
7049       do ll=1,3
7050         ggg1(ll)=eel6*g_contij(ll,1)
7051         ggg2(ll)=eel6*g_contij(ll,2)
7052 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7053         ghalf=0.5d0*ggg1(ll)
7054 cd        ghalf=0.0d0
7055         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7056         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7057         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7058         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7059         ghalf=0.5d0*ggg2(ll)
7060 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7061 cd        ghalf=0.0d0
7062         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7063         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7064         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7065         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7066       enddo
7067 cd      goto 1112
7068       do m=i+1,j-1
7069         do ll=1,3
7070 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7071           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7072         enddo
7073       enddo
7074       do m=k+1,l-1
7075         do ll=1,3
7076 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7077           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7078         enddo
7079       enddo
7080 1112  continue
7081       do m=i+2,j2
7082         do ll=1,3
7083           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7084         enddo
7085       enddo
7086       do m=k+2,l2
7087         do ll=1,3
7088           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7089         enddo
7090       enddo
7091 cd      do iii=1,nres-3
7092 cd        write (2,*) iii,g_corr6_loc(iii)
7093 cd      enddo
7094       endif
7095       eello6=ekont*eel6
7096 cd      write (2,*) 'ekont',ekont
7097 cd      write (iout,*) 'eello6',ekont*eel6
7098       return
7099       end
7100 c--------------------------------------------------------------------------
7101       double precision function eello6_graph1(i,j,k,l,imat,swap)
7102       implicit real*8 (a-h,o-z)
7103       include 'DIMENSIONS'
7104       include 'DIMENSIONS.ZSCOPT'
7105       include 'COMMON.IOUNITS'
7106       include 'COMMON.CHAIN'
7107       include 'COMMON.DERIV'
7108       include 'COMMON.INTERACT'
7109       include 'COMMON.CONTACTS'
7110       include 'COMMON.TORSION'
7111       include 'COMMON.VAR'
7112       include 'COMMON.GEO'
7113       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7114       logical swap
7115       logical lprn
7116       common /kutas/ lprn
7117 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7118 C                                                                              C
7119 C      Parallel       Antiparallel                                             C
7120 C                                                                              C
7121 C          o             o                                                     C
7122 C         /l\           /j\                                                    C
7123 C        /   \         /   \                                                   C
7124 C       /| o |         | o |\                                                  C
7125 C     \ j|/k\|  /   \  |/k\|l /                                                C
7126 C      \ /   \ /     \ /   \ /                                                 C
7127 C       o     o       o     o                                                  C
7128 C       i             i                                                        C
7129 C                                                                              C
7130 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7131       itk=itortyp(itype(k))
7132       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7133       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7134       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7135       call transpose2(EUgC(1,1,k),auxmat(1,1))
7136       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7137       vv1(1)=pizda1(1,1)-pizda1(2,2)
7138       vv1(2)=pizda1(1,2)+pizda1(2,1)
7139       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7140       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7141       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7142       s5=scalar2(vv(1),Dtobr2(1,i))
7143 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7144       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7145       if (.not. calc_grad) return
7146       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7147      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7148      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7149      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7150      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7151      & +scalar2(vv(1),Dtobr2der(1,i)))
7152       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7153       vv1(1)=pizda1(1,1)-pizda1(2,2)
7154       vv1(2)=pizda1(1,2)+pizda1(2,1)
7155       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7156       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7157       if (l.eq.j+1) then
7158         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7159      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7160      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7161      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7162      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7163       else
7164         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7165      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7166      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7167      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7168      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7169       endif
7170       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7171       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7172       vv1(1)=pizda1(1,1)-pizda1(2,2)
7173       vv1(2)=pizda1(1,2)+pizda1(2,1)
7174       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7175      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7176      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7177      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7178       do iii=1,2
7179         if (swap) then
7180           ind=3-iii
7181         else
7182           ind=iii
7183         endif
7184         do kkk=1,5
7185           do lll=1,3
7186             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7187             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7188             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7189             call transpose2(EUgC(1,1,k),auxmat(1,1))
7190             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7191      &        pizda1(1,1))
7192             vv1(1)=pizda1(1,1)-pizda1(2,2)
7193             vv1(2)=pizda1(1,2)+pizda1(2,1)
7194             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7195             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7196      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7197             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7198      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7199             s5=scalar2(vv(1),Dtobr2(1,i))
7200             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7201           enddo
7202         enddo
7203       enddo
7204       return
7205       end
7206 c----------------------------------------------------------------------------
7207       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7208       implicit real*8 (a-h,o-z)
7209       include 'DIMENSIONS'
7210       include 'DIMENSIONS.ZSCOPT'
7211       include 'COMMON.IOUNITS'
7212       include 'COMMON.CHAIN'
7213       include 'COMMON.DERIV'
7214       include 'COMMON.INTERACT'
7215       include 'COMMON.CONTACTS'
7216       include 'COMMON.TORSION'
7217       include 'COMMON.VAR'
7218       include 'COMMON.GEO'
7219       logical swap
7220       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7221      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7222       logical lprn
7223       common /kutas/ lprn
7224 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7225 C                                                                              C
7226 C      Parallel       Antiparallel                                             C
7227 C                                                                              C
7228 C          o             o                                                     C
7229 C     \   /l\           /j\   /                                                C
7230 C      \ /   \         /   \ /                                                 C
7231 C       o| o |         | o |o                                                  C
7232 C     \ j|/k\|      \  |/k\|l                                                  C
7233 C      \ /   \       \ /   \                                                   C
7234 C       o             o                                                        C
7235 C       i             i                                                        C
7236 C                                                                              C
7237 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7238 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7239 C AL 7/4/01 s1 would occur in the sixth-order moment,
7240 C           but not in a cluster cumulant
7241 #ifdef MOMENT
7242       s1=dip(1,jj,i)*dip(1,kk,k)
7243 #endif
7244       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7245       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7246       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7247       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7248       call transpose2(EUg(1,1,k),auxmat(1,1))
7249       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7250       vv(1)=pizda(1,1)-pizda(2,2)
7251       vv(2)=pizda(1,2)+pizda(2,1)
7252       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7253 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7254 #ifdef MOMENT
7255       eello6_graph2=-(s1+s2+s3+s4)
7256 #else
7257       eello6_graph2=-(s2+s3+s4)
7258 #endif
7259 c      eello6_graph2=-s3
7260       if (.not. calc_grad) return
7261 C Derivatives in gamma(i-1)
7262       if (i.gt.1) then
7263 #ifdef MOMENT
7264         s1=dipderg(1,jj,i)*dip(1,kk,k)
7265 #endif
7266         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7267         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7268         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7269         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7270 #ifdef MOMENT
7271         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7272 #else
7273         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7274 #endif
7275 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7276       endif
7277 C Derivatives in gamma(k-1)
7278 #ifdef MOMENT
7279       s1=dip(1,jj,i)*dipderg(1,kk,k)
7280 #endif
7281       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7282       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7283       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7284       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7285       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7286       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7287       vv(1)=pizda(1,1)-pizda(2,2)
7288       vv(2)=pizda(1,2)+pizda(2,1)
7289       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7290 #ifdef MOMENT
7291       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7292 #else
7293       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7294 #endif
7295 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7296 C Derivatives in gamma(j-1) or gamma(l-1)
7297       if (j.gt.1) then
7298 #ifdef MOMENT
7299         s1=dipderg(3,jj,i)*dip(1,kk,k)
7300 #endif
7301         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7302         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7303         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7304         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7305         vv(1)=pizda(1,1)-pizda(2,2)
7306         vv(2)=pizda(1,2)+pizda(2,1)
7307         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7308 #ifdef MOMENT
7309         if (swap) then
7310           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7311         else
7312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7313         endif
7314 #endif
7315         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7316 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7317       endif
7318 C Derivatives in gamma(l-1) or gamma(j-1)
7319       if (l.gt.1) then
7320 #ifdef MOMENT
7321         s1=dip(1,jj,i)*dipderg(3,kk,k)
7322 #endif
7323         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7324         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7325         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7326         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7327         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7328         vv(1)=pizda(1,1)-pizda(2,2)
7329         vv(2)=pizda(1,2)+pizda(2,1)
7330         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7331 #ifdef MOMENT
7332         if (swap) then
7333           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7334         else
7335           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7336         endif
7337 #endif
7338         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7339 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7340       endif
7341 C Cartesian derivatives.
7342       if (lprn) then
7343         write (2,*) 'In eello6_graph2'
7344         do iii=1,2
7345           write (2,*) 'iii=',iii
7346           do kkk=1,5
7347             write (2,*) 'kkk=',kkk
7348             do jjj=1,2
7349               write (2,'(3(2f10.5),5x)')
7350      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7351             enddo
7352           enddo
7353         enddo
7354       endif
7355       do iii=1,2
7356         do kkk=1,5
7357           do lll=1,3
7358 #ifdef MOMENT
7359             if (iii.eq.1) then
7360               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7361             else
7362               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7363             endif
7364 #endif
7365             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7366      &        auxvec(1))
7367             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7368             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7369      &        auxvec(1))
7370             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7371             call transpose2(EUg(1,1,k),auxmat(1,1))
7372             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7373      &        pizda(1,1))
7374             vv(1)=pizda(1,1)-pizda(2,2)
7375             vv(2)=pizda(1,2)+pizda(2,1)
7376             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7377 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7378 #ifdef MOMENT
7379             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7380 #else
7381             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7382 #endif
7383             if (swap) then
7384               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7385             else
7386               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7387             endif
7388           enddo
7389         enddo
7390       enddo
7391       return
7392       end
7393 c----------------------------------------------------------------------------
7394       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7395       implicit real*8 (a-h,o-z)
7396       include 'DIMENSIONS'
7397       include 'DIMENSIONS.ZSCOPT'
7398       include 'COMMON.IOUNITS'
7399       include 'COMMON.CHAIN'
7400       include 'COMMON.DERIV'
7401       include 'COMMON.INTERACT'
7402       include 'COMMON.CONTACTS'
7403       include 'COMMON.TORSION'
7404       include 'COMMON.VAR'
7405       include 'COMMON.GEO'
7406       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7407       logical swap
7408 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7409 C                                                                              C
7410 C      Parallel       Antiparallel                                             C
7411 C                                                                              C
7412 C          o             o                                                     C
7413 C         /l\   /   \   /j\                                                    C
7414 C        /   \ /     \ /   \                                                   C
7415 C       /| o |o       o| o |\                                                  C
7416 C       j|/k\|  /      |/k\|l /                                                C
7417 C        /   \ /       /   \ /                                                 C
7418 C       /     o       /     o                                                  C
7419 C       i             i                                                        C
7420 C                                                                              C
7421 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7422 C
7423 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7424 C           energy moment and not to the cluster cumulant.
7425       iti=itortyp(itype(i))
7426       if (j.lt.nres-1) then
7427         itj1=itortyp(itype(j+1))
7428       else
7429         itj1=ntortyp+1
7430       endif
7431       itk=itortyp(itype(k))
7432       itk1=itortyp(itype(k+1))
7433       if (l.lt.nres-1) then
7434         itl1=itortyp(itype(l+1))
7435       else
7436         itl1=ntortyp+1
7437       endif
7438 #ifdef MOMENT
7439       s1=dip(4,jj,i)*dip(4,kk,k)
7440 #endif
7441       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7442       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7443       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7444       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7445       call transpose2(EE(1,1,itk),auxmat(1,1))
7446       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7447       vv(1)=pizda(1,1)+pizda(2,2)
7448       vv(2)=pizda(2,1)-pizda(1,2)
7449       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7450 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7451 #ifdef MOMENT
7452       eello6_graph3=-(s1+s2+s3+s4)
7453 #else
7454       eello6_graph3=-(s2+s3+s4)
7455 #endif
7456 c      eello6_graph3=-s4
7457       if (.not. calc_grad) return
7458 C Derivatives in gamma(k-1)
7459       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7460       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7461       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7462       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7463 C Derivatives in gamma(l-1)
7464       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7465       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7466       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7467       vv(1)=pizda(1,1)+pizda(2,2)
7468       vv(2)=pizda(2,1)-pizda(1,2)
7469       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7470       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7471 C Cartesian derivatives.
7472       do iii=1,2
7473         do kkk=1,5
7474           do lll=1,3
7475 #ifdef MOMENT
7476             if (iii.eq.1) then
7477               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7478             else
7479               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7480             endif
7481 #endif
7482             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7483      &        auxvec(1))
7484             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7485             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7486      &        auxvec(1))
7487             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7488             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7489      &        pizda(1,1))
7490             vv(1)=pizda(1,1)+pizda(2,2)
7491             vv(2)=pizda(2,1)-pizda(1,2)
7492             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7493 #ifdef MOMENT
7494             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7495 #else
7496             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7497 #endif
7498             if (swap) then
7499               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7500             else
7501               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7502             endif
7503 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7504           enddo
7505         enddo
7506       enddo
7507       return
7508       end
7509 c----------------------------------------------------------------------------
7510       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7511       implicit real*8 (a-h,o-z)
7512       include 'DIMENSIONS'
7513       include 'DIMENSIONS.ZSCOPT'
7514       include 'COMMON.IOUNITS'
7515       include 'COMMON.CHAIN'
7516       include 'COMMON.DERIV'
7517       include 'COMMON.INTERACT'
7518       include 'COMMON.CONTACTS'
7519       include 'COMMON.TORSION'
7520       include 'COMMON.VAR'
7521       include 'COMMON.GEO'
7522       include 'COMMON.FFIELD'
7523       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7524      & auxvec1(2),auxmat1(2,2)
7525       logical swap
7526 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7527 C                                                                              C
7528 C      Parallel       Antiparallel                                             C
7529 C                                                                              C
7530 C          o             o                                                     C
7531 C         /l\   /   \   /j\                                                    C
7532 C        /   \ /     \ /   \                                                   C
7533 C       /| o |o       o| o |\                                                  C
7534 C     \ j|/k\|      \  |/k\|l                                                  C
7535 C      \ /   \       \ /   \                                                   C
7536 C       o     \       o     \                                                  C
7537 C       i             i                                                        C
7538 C                                                                              C
7539 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7540 C
7541 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7542 C           energy moment and not to the cluster cumulant.
7543 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7544       iti=itortyp(itype(i))
7545       itj=itortyp(itype(j))
7546       if (j.lt.nres-1) then
7547         itj1=itortyp(itype(j+1))
7548       else
7549         itj1=ntortyp+1
7550       endif
7551       itk=itortyp(itype(k))
7552       if (k.lt.nres-1) then
7553         itk1=itortyp(itype(k+1))
7554       else
7555         itk1=ntortyp+1
7556       endif
7557       itl=itortyp(itype(l))
7558       if (l.lt.nres-1) then
7559         itl1=itortyp(itype(l+1))
7560       else
7561         itl1=ntortyp+1
7562       endif
7563 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7564 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7565 cd     & ' itl',itl,' itl1',itl1
7566 #ifdef MOMENT
7567       if (imat.eq.1) then
7568         s1=dip(3,jj,i)*dip(3,kk,k)
7569       else
7570         s1=dip(2,jj,j)*dip(2,kk,l)
7571       endif
7572 #endif
7573       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7574       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7575       if (j.eq.l+1) then
7576         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7577         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7578       else
7579         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7580         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7581       endif
7582       call transpose2(EUg(1,1,k),auxmat(1,1))
7583       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7584       vv(1)=pizda(1,1)-pizda(2,2)
7585       vv(2)=pizda(2,1)+pizda(1,2)
7586       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7587 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7588 #ifdef MOMENT
7589       eello6_graph4=-(s1+s2+s3+s4)
7590 #else
7591       eello6_graph4=-(s2+s3+s4)
7592 #endif
7593       if (.not. calc_grad) return
7594 C Derivatives in gamma(i-1)
7595       if (i.gt.1) then
7596 #ifdef MOMENT
7597         if (imat.eq.1) then
7598           s1=dipderg(2,jj,i)*dip(3,kk,k)
7599         else
7600           s1=dipderg(4,jj,j)*dip(2,kk,l)
7601         endif
7602 #endif
7603         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7604         if (j.eq.l+1) then
7605           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7606           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7607         else
7608           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7609           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7610         endif
7611         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7612         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7613 cd          write (2,*) 'turn6 derivatives'
7614 #ifdef MOMENT
7615           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7616 #else
7617           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7618 #endif
7619         else
7620 #ifdef MOMENT
7621           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7622 #else
7623           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7624 #endif
7625         endif
7626       endif
7627 C Derivatives in gamma(k-1)
7628 #ifdef MOMENT
7629       if (imat.eq.1) then
7630         s1=dip(3,jj,i)*dipderg(2,kk,k)
7631       else
7632         s1=dip(2,jj,j)*dipderg(4,kk,l)
7633       endif
7634 #endif
7635       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7636       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7637       if (j.eq.l+1) then
7638         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7639         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7640       else
7641         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7642         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7643       endif
7644       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7645       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7646       vv(1)=pizda(1,1)-pizda(2,2)
7647       vv(2)=pizda(2,1)+pizda(1,2)
7648       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7649       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7650 #ifdef MOMENT
7651         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7652 #else
7653         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7654 #endif
7655       else
7656 #ifdef MOMENT
7657         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7658 #else
7659         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7660 #endif
7661       endif
7662 C Derivatives in gamma(j-1) or gamma(l-1)
7663       if (l.eq.j+1 .and. l.gt.1) then
7664         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7665         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7666         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7667         vv(1)=pizda(1,1)-pizda(2,2)
7668         vv(2)=pizda(2,1)+pizda(1,2)
7669         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7670         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7671       else if (j.gt.1) then
7672         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7673         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7674         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7675         vv(1)=pizda(1,1)-pizda(2,2)
7676         vv(2)=pizda(2,1)+pizda(1,2)
7677         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7678         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7679           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7680         else
7681           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7682         endif
7683       endif
7684 C Cartesian derivatives.
7685       do iii=1,2
7686         do kkk=1,5
7687           do lll=1,3
7688 #ifdef MOMENT
7689             if (iii.eq.1) then
7690               if (imat.eq.1) then
7691                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7692               else
7693                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7694               endif
7695             else
7696               if (imat.eq.1) then
7697                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7698               else
7699                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7700               endif
7701             endif
7702 #endif
7703             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7704      &        auxvec(1))
7705             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7706             if (j.eq.l+1) then
7707               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7708      &          b1(1,itj1),auxvec(1))
7709               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7710             else
7711               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7712      &          b1(1,itl1),auxvec(1))
7713               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7714             endif
7715             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7716      &        pizda(1,1))
7717             vv(1)=pizda(1,1)-pizda(2,2)
7718             vv(2)=pizda(2,1)+pizda(1,2)
7719             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7720             if (swap) then
7721               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7722 #ifdef MOMENT
7723                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7724      &             -(s1+s2+s4)
7725 #else
7726                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7727      &             -(s2+s4)
7728 #endif
7729                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7730               else
7731 #ifdef MOMENT
7732                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7733 #else
7734                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7735 #endif
7736                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7737               endif
7738             else
7739 #ifdef MOMENT
7740               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7741 #else
7742               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7743 #endif
7744               if (l.eq.j+1) then
7745                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7746               else
7747                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7748               endif
7749             endif
7750           enddo
7751         enddo
7752       enddo
7753       return
7754       end
7755 c----------------------------------------------------------------------------
7756       double precision function eello_turn6(i,jj,kk)
7757       implicit real*8 (a-h,o-z)
7758       include 'DIMENSIONS'
7759       include 'DIMENSIONS.ZSCOPT'
7760       include 'COMMON.IOUNITS'
7761       include 'COMMON.CHAIN'
7762       include 'COMMON.DERIV'
7763       include 'COMMON.INTERACT'
7764       include 'COMMON.CONTACTS'
7765       include 'COMMON.TORSION'
7766       include 'COMMON.VAR'
7767       include 'COMMON.GEO'
7768       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7769      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7770      &  ggg1(3),ggg2(3)
7771       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7772      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7773 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7774 C           the respective energy moment and not to the cluster cumulant.
7775       eello_turn6=0.0d0
7776       j=i+4
7777       k=i+1
7778       l=i+3
7779       iti=itortyp(itype(i))
7780       itk=itortyp(itype(k))
7781       itk1=itortyp(itype(k+1))
7782       itl=itortyp(itype(l))
7783       itj=itortyp(itype(j))
7784 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7785 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7786 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7787 cd        eello6=0.0d0
7788 cd        return
7789 cd      endif
7790 cd      write (iout,*)
7791 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7792 cd     &   ' and',k,l
7793 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7794       do iii=1,2
7795         do kkk=1,5
7796           do lll=1,3
7797             derx_turn(lll,kkk,iii)=0.0d0
7798           enddo
7799         enddo
7800       enddo
7801 cd      eij=1.0d0
7802 cd      ekl=1.0d0
7803 cd      ekont=1.0d0
7804       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7805 cd      eello6_5=0.0d0
7806 cd      write (2,*) 'eello6_5',eello6_5
7807 #ifdef MOMENT
7808       call transpose2(AEA(1,1,1),auxmat(1,1))
7809       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7810       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7811       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7812 #else
7813       s1 = 0.0d0
7814 #endif
7815       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7816       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7817       s2 = scalar2(b1(1,itk),vtemp1(1))
7818 #ifdef MOMENT
7819       call transpose2(AEA(1,1,2),atemp(1,1))
7820       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7821       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7822       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7823 #else
7824       s8=0.0d0
7825 #endif
7826       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7827       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7828       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7829 #ifdef MOMENT
7830       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7831       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7832       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7833       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7834       ss13 = scalar2(b1(1,itk),vtemp4(1))
7835       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7836 #else
7837       s13=0.0d0
7838 #endif
7839 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7840 c      s1=0.0d0
7841 c      s2=0.0d0
7842 c      s8=0.0d0
7843 c      s12=0.0d0
7844 c      s13=0.0d0
7845       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7846       if (calc_grad) then
7847 C Derivatives in gamma(i+2)
7848 #ifdef MOMENT
7849       call transpose2(AEA(1,1,1),auxmatd(1,1))
7850       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7851       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7852       call transpose2(AEAderg(1,1,2),atempd(1,1))
7853       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7854       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7855 #else
7856       s8d=0.0d0
7857 #endif
7858       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7859       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7860       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7861 c      s1d=0.0d0
7862 c      s2d=0.0d0
7863 c      s8d=0.0d0
7864 c      s12d=0.0d0
7865 c      s13d=0.0d0
7866       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7867 C Derivatives in gamma(i+3)
7868 #ifdef MOMENT
7869       call transpose2(AEA(1,1,1),auxmatd(1,1))
7870       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7871       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7872       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7873 #else
7874       s1d=0.0d0
7875 #endif
7876       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7877       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7878       s2d = scalar2(b1(1,itk),vtemp1d(1))
7879 #ifdef MOMENT
7880       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7881       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7882 #endif
7883       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7884 #ifdef MOMENT
7885       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7886       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7887       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7888 #else
7889       s13d=0.0d0
7890 #endif
7891 c      s1d=0.0d0
7892 c      s2d=0.0d0
7893 c      s8d=0.0d0
7894 c      s12d=0.0d0
7895 c      s13d=0.0d0
7896 #ifdef MOMENT
7897       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7898      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7899 #else
7900       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7901      &               -0.5d0*ekont*(s2d+s12d)
7902 #endif
7903 C Derivatives in gamma(i+4)
7904       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7905       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7906       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7907 #ifdef MOMENT
7908       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7909       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7910       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7911 #else
7912       s13d = 0.0d0
7913 #endif
7914 c      s1d=0.0d0
7915 c      s2d=0.0d0
7916 c      s8d=0.0d0
7917 C      s12d=0.0d0
7918 c      s13d=0.0d0
7919 #ifdef MOMENT
7920       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7921 #else
7922       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7923 #endif
7924 C Derivatives in gamma(i+5)
7925 #ifdef MOMENT
7926       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7927       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7928       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7929 #else
7930       s1d = 0.0d0
7931 #endif
7932       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7933       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7934       s2d = scalar2(b1(1,itk),vtemp1d(1))
7935 #ifdef MOMENT
7936       call transpose2(AEA(1,1,2),atempd(1,1))
7937       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7938       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7939 #else
7940       s8d = 0.0d0
7941 #endif
7942       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7943       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7944 #ifdef MOMENT
7945       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7946       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7947       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7948 #else
7949       s13d = 0.0d0
7950 #endif
7951 c      s1d=0.0d0
7952 c      s2d=0.0d0
7953 c      s8d=0.0d0
7954 c      s12d=0.0d0
7955 c      s13d=0.0d0
7956 #ifdef MOMENT
7957       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7958      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7959 #else
7960       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7961      &               -0.5d0*ekont*(s2d+s12d)
7962 #endif
7963 C Cartesian derivatives
7964       do iii=1,2
7965         do kkk=1,5
7966           do lll=1,3
7967 #ifdef MOMENT
7968             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7969             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7970             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7971 #else
7972             s1d = 0.0d0
7973 #endif
7974             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7975             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7976      &          vtemp1d(1))
7977             s2d = scalar2(b1(1,itk),vtemp1d(1))
7978 #ifdef MOMENT
7979             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7980             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7981             s8d = -(atempd(1,1)+atempd(2,2))*
7982      &           scalar2(cc(1,1,itl),vtemp2(1))
7983 #else
7984             s8d = 0.0d0
7985 #endif
7986             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7987      &           auxmatd(1,1))
7988             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7989             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7990 c      s1d=0.0d0
7991 c      s2d=0.0d0
7992 c      s8d=0.0d0
7993 c      s12d=0.0d0
7994 c      s13d=0.0d0
7995 #ifdef MOMENT
7996             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7997      &        - 0.5d0*(s1d+s2d)
7998 #else
7999             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8000      &        - 0.5d0*s2d
8001 #endif
8002 #ifdef MOMENT
8003             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8004      &        - 0.5d0*(s8d+s12d)
8005 #else
8006             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8007      &        - 0.5d0*s12d
8008 #endif
8009           enddo
8010         enddo
8011       enddo
8012 #ifdef MOMENT
8013       do kkk=1,5
8014         do lll=1,3
8015           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8016      &      achuj_tempd(1,1))
8017           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8018           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8019           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8020           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8021           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8022      &      vtemp4d(1))
8023           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8024           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8025           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8026         enddo
8027       enddo
8028 #endif
8029 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8030 cd     &  16*eel_turn6_num
8031 cd      goto 1112
8032       if (j.lt.nres-1) then
8033         j1=j+1
8034         j2=j-1
8035       else
8036         j1=j-1
8037         j2=j-2
8038       endif
8039       if (l.lt.nres-1) then
8040         l1=l+1
8041         l2=l-1
8042       else
8043         l1=l-1
8044         l2=l-2
8045       endif
8046       do ll=1,3
8047         ggg1(ll)=eel_turn6*g_contij(ll,1)
8048         ggg2(ll)=eel_turn6*g_contij(ll,2)
8049         ghalf=0.5d0*ggg1(ll)
8050 cd        ghalf=0.0d0
8051         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8052      &    +ekont*derx_turn(ll,2,1)
8053         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8054         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8055      &    +ekont*derx_turn(ll,4,1)
8056         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8057         ghalf=0.5d0*ggg2(ll)
8058 cd        ghalf=0.0d0
8059         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8060      &    +ekont*derx_turn(ll,2,2)
8061         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8062         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8063      &    +ekont*derx_turn(ll,4,2)
8064         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8065       enddo
8066 cd      goto 1112
8067       do m=i+1,j-1
8068         do ll=1,3
8069           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8070         enddo
8071       enddo
8072       do m=k+1,l-1
8073         do ll=1,3
8074           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8075         enddo
8076       enddo
8077 1112  continue
8078       do m=i+2,j2
8079         do ll=1,3
8080           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8081         enddo
8082       enddo
8083       do m=k+2,l2
8084         do ll=1,3
8085           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8086         enddo
8087       enddo
8088 cd      do iii=1,nres-3
8089 cd        write (2,*) iii,g_corr6_loc(iii)
8090 cd      enddo
8091       endif
8092       eello_turn6=ekont*eel_turn6
8093 cd      write (2,*) 'ekont',ekont
8094 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8095       return
8096       end
8097 crc-------------------------------------------------
8098       SUBROUTINE MATVEC2(A1,V1,V2)
8099       implicit real*8 (a-h,o-z)
8100       include 'DIMENSIONS'
8101       DIMENSION A1(2,2),V1(2),V2(2)
8102 c      DO 1 I=1,2
8103 c        VI=0.0
8104 c        DO 3 K=1,2
8105 c    3     VI=VI+A1(I,K)*V1(K)
8106 c        Vaux(I)=VI
8107 c    1 CONTINUE
8108
8109       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8110       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8111
8112       v2(1)=vaux1
8113       v2(2)=vaux2
8114       END
8115 C---------------------------------------
8116       SUBROUTINE MATMAT2(A1,A2,A3)
8117       implicit real*8 (a-h,o-z)
8118       include 'DIMENSIONS'
8119       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8120 c      DIMENSION AI3(2,2)
8121 c        DO  J=1,2
8122 c          A3IJ=0.0
8123 c          DO K=1,2
8124 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8125 c          enddo
8126 c          A3(I,J)=A3IJ
8127 c       enddo
8128 c      enddo
8129
8130       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8131       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8132       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8133       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8134
8135       A3(1,1)=AI3_11
8136       A3(2,1)=AI3_21
8137       A3(1,2)=AI3_12
8138       A3(2,2)=AI3_22
8139       END
8140
8141 c-------------------------------------------------------------------------
8142       double precision function scalar2(u,v)
8143       implicit none
8144       double precision u(2),v(2)
8145       double precision sc
8146       integer i
8147       scalar2=u(1)*v(1)+u(2)*v(2)
8148       return
8149       end
8150
8151 C-----------------------------------------------------------------------------
8152
8153       subroutine transpose2(a,at)
8154       implicit none
8155       double precision a(2,2),at(2,2)
8156       at(1,1)=a(1,1)
8157       at(1,2)=a(2,1)
8158       at(2,1)=a(1,2)
8159       at(2,2)=a(2,2)
8160       return
8161       end
8162 c--------------------------------------------------------------------------
8163       subroutine transpose(n,a,at)
8164       implicit none
8165       integer n,i,j
8166       double precision a(n,n),at(n,n)
8167       do i=1,n
8168         do j=1,n
8169           at(j,i)=a(i,j)
8170         enddo
8171       enddo
8172       return
8173       end
8174 C---------------------------------------------------------------------------
8175       subroutine prodmat3(a1,a2,kk,transp,prod)
8176       implicit none
8177       integer i,j
8178       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8179       logical transp
8180 crc      double precision auxmat(2,2),prod_(2,2)
8181
8182       if (transp) then
8183 crc        call transpose2(kk(1,1),auxmat(1,1))
8184 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8185 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8186
8187            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8188      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8189            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8190      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8191            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8192      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8193            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8194      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8195
8196       else
8197 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8198 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8199
8200            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8201      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8202            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8203      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8204            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8205      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8206            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8207      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8208
8209       endif
8210 c      call transpose2(a2(1,1),a2t(1,1))
8211
8212 crc      print *,transp
8213 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8214 crc      print *,((prod(i,j),i=1,2),j=1,2)
8215
8216       return
8217       end
8218 C-----------------------------------------------------------------------------
8219       double precision function scalar(u,v)
8220       implicit none
8221       double precision u(3),v(3)
8222       double precision sc
8223       integer i
8224       sc=0.0d0
8225       do i=1,3
8226         sc=sc+u(i)*v(i)
8227       enddo
8228       scalar=sc
8229       return
8230       end
8231