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