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