source/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       endif
 104       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 105          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 106       endif
 107
 108
 109 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 110       if (constr_homology.ge.1) then
 111         call e_modeller(ehomology_constr)
 112       else
 113         ehomology_constr=0.0d0
 114       endif
 115
 116 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 117
 118 C     BARTEK for dfa test!
 119       if (wdfa_dist.gt.0) call edfad(edfadis)
 120 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 121       if (wdfa_tor.gt.0) call edfat(edfator)
 122 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 123       if (wdfa_nei.gt.0) call edfan(edfanei)
 124 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 125       if (wdfa_beta.gt.0) call edfab(edfabet)
 126 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 127
 128 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 129 #ifdef SPLITELE
 130       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 131      & +wvdwpp*evdw1
 132      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 133      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 134      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 135      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 136      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 137      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 138      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 139      & +wdfa_beta*edfabet
 140 #else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 142      & +welec*fact(1)*(ees+evdw1)
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 149      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 150      & +wdfa_beta*edfabet
 151 #endif
 152       energia(0)=etot
 153       energia(1)=evdw
 154 #ifdef SCP14
 155       energia(2)=evdw2-evdw2_14
 156       energia(17)=evdw2_14
 157 #else
 158       energia(2)=evdw2
 159       energia(17)=0.0d0
 160 #endif
 161 #ifdef SPLITELE
 162       energia(3)=ees
 163       energia(16)=evdw1
 164 #else
 165       energia(3)=ees+evdw1
 166       energia(16)=0.0d0
 167 #endif
 168       energia(4)=ecorr
 169       energia(5)=ecorr5
 170       energia(6)=ecorr6
 171       energia(7)=eel_loc
 172       energia(8)=eello_turn3
 173       energia(9)=eello_turn4
 174       energia(10)=eturn6
 175       energia(11)=ebe
 176       energia(12)=escloc
 177       energia(13)=etors
 178       energia(14)=etors_d
 179       energia(15)=ehpb
 180       energia(18)=estr
 181       energia(19)=esccor
 182       energia(20)=edihcnstr
 183       energia(21)=evdw_t
 184       energia(22)=ehomology_constr
 185       energia(23)=edfadis
 186       energia(24)=edfator
 187       energia(25)=edfanei
 188       energia(26)=edfabet
 189 c      if (dyn_ss) call dyn_set_nss
 190 c detecting NaNQ
 191 #ifdef ISNAN
 192 #ifdef AIX
 193       if (isnan(etot).ne.0) energia(0)=1.0d+99
 194 #else
 195       if (isnan(etot)) energia(0)=1.0d+99
 196 #endif
 197 #else
 198       i=0
 199 #ifdef WINPGI
 200       idumm=proc_proc(etot,i)
 201 #else
 202       call proc_proc(etot,i)
 203 #endif
 204       if(i.eq.1)energia(0)=1.0d+99
 205 #endif
 206 #ifdef MPL
 207 c     endif
 208 #endif
 209       if (calc_grad) then
 210 C
 211 C Sum up the components of the Cartesian gradient.
 212 C
 213 #ifdef SPLITELE
 214       do i=1,nct
 215         do j=1,3
 216           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 217      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 218      &                wbond*gradb(j,i)+
 219      &                wstrain*ghpbc(j,i)+
 220      &                wcorr*fact(3)*gradcorr(j,i)+
 221      &                wel_loc*fact(2)*gel_loc(j,i)+
 222      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 223      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 224      &                wcorr5*fact(4)*gradcorr5(j,i)+
 225      &                wcorr6*fact(5)*gradcorr6(j,i)+
 226      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 227      &                wsccor*fact(2)*gsccorc(j,i)+
 228      &                wdfa_dist*gdfad(j,i)+
 229      &                wdfa_tor*gdfat(j,i)+
 230      &                wdfa_nei*gdfan(j,i)+
 231      &                wdfa_beta*gdfab(j,i)
 232           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 233      &                  wbond*gradbx(j,i)+
 234      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 235      &                  wsccor*fact(2)*gsccorx(j,i)
 236         enddo
 237 #else
 238       do i=1,nct
 239         do j=1,3
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wcorr*fact(3)*gradcorr(j,i)+
 244      &                wel_loc*fact(2)*gel_loc(j,i)+
 245      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 246      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 247      &                wcorr5*fact(4)*gradcorr5(j,i)+
 248      &                wcorr6*fact(5)*gradcorr6(j,i)+
 249      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 250      &                wsccor*fact(2)*gsccorc(j,i)+
 251      &                wdfa_dist*gdfad(j,i)+
 252      &                wdfa_tor*gdfat(j,i)+
 253      &                wdfa_nei*gdfan(j,i)+
 254      &                wdfa_beta*gdfab(j,i)
 255           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 256      &                  wbond*gradbx(j,i)+
 257      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 258      &                  wsccor*fact(1)*gsccorx(j,i)
 259         enddo
 260 #endif
 261       enddo
 262
 263
 264       do i=1,nres-3
 265         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 266      &   +wcorr5*fact(4)*g_corr5_loc(i)
 267      &   +wcorr6*fact(5)*g_corr6_loc(i)
 268      &   +wturn4*fact(3)*gel_loc_turn4(i)
 269      &   +wturn3*fact(2)*gel_loc_turn3(i)
 270      &   +wturn6*fact(5)*gel_loc_turn6(i)
 271      &   +wel_loc*fact(2)*gel_loc_loc(i)
 272      &   +wsccor*fact(1)*gsccor_loc(i)
 273       enddo
 274       endif
 275       return
 276       end
 277 C------------------------------------------------------------------------
 278       subroutine enerprint(energia,fact)
 279       implicit real*8 (a-h,o-z)
 280       include 'DIMENSIONS'
 281       include 'DIMENSIONS.ZSCOPT'
 282       include 'COMMON.IOUNITS'
 283       include 'COMMON.FFIELD'
 284       include 'COMMON.SBRIDGE'
 285       double precision energia(0:max_ene),fact(6)
 286       etot=energia(0)
 287       evdw=energia(1)+fact(6)*energia(21)
 288 #ifdef SCP14
 289       evdw2=energia(2)+energia(17)
 290 #else
 291       evdw2=energia(2)
 292 #endif
 293       ees=energia(3)
 294 #ifdef SPLITELE
 295       evdw1=energia(16)
 296 #endif
 297       ecorr=energia(4)
 298       ecorr5=energia(5)
 299       ecorr6=energia(6)
 300       eel_loc=energia(7)
 301       eello_turn3=energia(8)
 302       eello_turn4=energia(9)
 303       eello_turn6=energia(10)
 304       ebe=energia(11)
 305       escloc=energia(12)
 306       etors=energia(13)
 307       etors_d=energia(14)
 308       ehpb=energia(15)
 309       esccor=energia(19)
 310       edihcnstr=energia(20)
 311       estr=energia(18)
 312       ehomology_constr=energia(22)
 313       edfadis=energia(23)
 314       edfator=energia(24)
 315       edfanei=energia(25)
 316       edfabet=energia(26)
 317 #ifdef SPLITELE
 318       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 319      &  wvdwpp,
 320      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 321      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 322      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 323      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 324      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 325      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 326      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 327      &  wdfa_beta,etot
 328    10 format (/'Virtual-chain energies:'//
 329      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 330      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 331      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 332      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 333      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 334      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 335      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 336      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 337      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 338      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 339      & ' (SS bridges & dist. cnstr.)'/
 340      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 343      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 344      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 345      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 346      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 347      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 348      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 349      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 350      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 351      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 352      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 353      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 354      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 355      & 'ETOT=  ',1pE16.6,' (total)')
 356 #else
 357       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 358      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 359      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 360      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 361      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 362      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 363      &  edihcnstr,ehomology_constr,ebr*nss,
 364      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 365      &  wdfa_beta,etot
 366    10 format (/'Virtual-chain energies:'//
 367      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 368      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 369      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 370      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 371      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 372      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 373      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 374      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 375      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 376      & ' (SS bridges & dist. cnstr.)'/
 377      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 380      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 381      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 382      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 383      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 384      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 385      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 386      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 387      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 388      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 389      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 390      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 391      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 392      & 'ETOT=  ',1pE16.6,' (total)')
 393 #endif
 394       return
 395       end
 396 C-----------------------------------------------------------------------
 397       subroutine elj(evdw,evdw_t)
 398 C
 399 C This subroutine calculates the interaction energy of nonbonded side chains
 400 C assuming the LJ potential of interaction.
 401 C
 402       implicit real*8 (a-h,o-z)
 403       include 'DIMENSIONS'
 404       include 'DIMENSIONS.ZSCOPT'
 405       include "DIMENSIONS.COMPAR"
 406       parameter (accur=1.0d-10)
 407       include 'COMMON.GEO'
 408       include 'COMMON.VAR'
 409       include 'COMMON.LOCAL'
 410       include 'COMMON.CHAIN'
 411       include 'COMMON.DERIV'
 412       include 'COMMON.INTERACT'
 413       include 'COMMON.TORSION'
 414       include 'COMMON.ENEPS'
 415       include 'COMMON.SBRIDGE'
 416       include 'COMMON.NAMES'
 417       include 'COMMON.IOUNITS'
 418       include 'COMMON.CONTACTS'
 419       dimension gg(3)
 420       integer icant
 421       external icant
 422 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 423       do i=1,210
 424         do j=1,2
 425           eneps_temp(j,i)=0.0d0
 426         enddo
 427       enddo
 428       evdw=0.0D0
 429       evdw_t=0.0d0
 430       do i=iatsc_s,iatsc_e
 431         itypi=itype(i)
 432         itypi1=itype(i+1)
 433         xi=c(1,nres+i)
 434         yi=c(2,nres+i)
 435         zi=c(3,nres+i)
 436 C Change 12/1/95
 437         num_conti=0
 438 C
 439 C Calculate SC interaction energy.
 440 C
 441         do iint=1,nint_gr(i)
 442 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 443 cd   &                  'iend=',iend(i,iint)
 444           do j=istart(i,iint),iend(i,iint)
 445             itypj=itype(j)
 446             xj=c(1,nres+j)-xi
 447             yj=c(2,nres+j)-yi
 448             zj=c(3,nres+j)-zi
 449 C Change 12/1/95 to calculate four-body interactions
 450             rij=xj*xj+yj*yj+zj*zj
 451             rrij=1.0D0/rij
 452 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 453             eps0ij=eps(itypi,itypj)
 454             fac=rrij**expon2
 455             e1=fac*fac*aa(itypi,itypj)
 456             e2=fac*bb(itypi,itypj)
 457             evdwij=e1+e2
 458             ij=icant(itypi,itypj)
 459             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 460             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 461 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 462 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 463 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 464 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 465 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 466 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 467             if (bb(itypi,itypj).gt.0.0d0) then
 468               evdw=evdw+evdwij
 469             else
 470               evdw_t=evdw_t+evdwij
 471             endif
 472             if (calc_grad) then
 473 C
 474 C Calculate the components of the gradient in DC and X
 475 C
 476             fac=-rrij*(e1+evdwij)
 477             gg(1)=xj*fac
 478             gg(2)=yj*fac
 479             gg(3)=zj*fac
 480             do k=1,3
 481               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 482               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 483             enddo
 484             do k=i,j-1
 485               do l=1,3
 486                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 487               enddo
 488             enddo
 489             endif
 490 C
 491 C 12/1/95, revised on 5/20/97
 492 C
 493 C Calculate the contact function. The ith column of the array JCONT will
 494 C contain the numbers of atoms that make contacts with the atom I (of numbers
 495 C greater than I). The arrays FACONT and GACONT will contain the values of
 496 C the contact function and its derivative.
 497 C
 498 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 499 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 500 C Uncomment next line, if the correlation interactions are contact function only
 501             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 502               rij=dsqrt(rij)
 503               sigij=sigma(itypi,itypj)
 504               r0ij=rs0(itypi,itypj)
 505 C
 506 C Check whether the SC's are not too far to make a contact.
 507 C
 508               rcut=1.5d0*r0ij
 509               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 510 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 511 C
 512               if (fcont.gt.0.0D0) then
 513 C If the SC-SC distance if close to sigma, apply spline.
 514 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 515 cAdam &             fcont1,fprimcont1)
 516 cAdam           fcont1=1.0d0-fcont1
 517 cAdam           if (fcont1.gt.0.0d0) then
 518 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 519 cAdam             fcont=fcont*fcont1
 520 cAdam           endif
 521 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 522 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 523 cga             do k=1,3
 524 cga               gg(k)=gg(k)*eps0ij
 525 cga             enddo
 526 cga             eps0ij=-evdwij*eps0ij
 527 C Uncomment for AL's type of SC correlation interactions.
 528 cadam           eps0ij=-evdwij
 529                 num_conti=num_conti+1
 530                 jcont(num_conti,i)=j
 531                 facont(num_conti,i)=fcont*eps0ij
 532                 fprimcont=eps0ij*fprimcont/rij
 533                 fcont=expon*fcont
 534 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 535 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 536 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 537 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 538                 gacont(1,num_conti,i)=-fprimcont*xj
 539                 gacont(2,num_conti,i)=-fprimcont*yj
 540                 gacont(3,num_conti,i)=-fprimcont*zj
 541 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 542 cd              write (iout,'(2i3,3f10.5)')
 543 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 544               endif
 545             endif
 546           enddo      ! j
 547         enddo        ! iint
 548 C Change 12/1/95
 549         num_cont(i)=num_conti
 550       enddo          ! i
 551       if (calc_grad) then
 552       do i=1,nct
 553         do j=1,3
 554           gvdwc(j,i)=expon*gvdwc(j,i)
 555           gvdwx(j,i)=expon*gvdwx(j,i)
 556         enddo
 557       enddo
 558       endif
 559 C******************************************************************************
 560 C
 561 C                              N O T E !!!
 562 C
 563 C To save time, the factor of EXPON has been extracted from ALL components
 564 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 565 C use!
 566 C
 567 C******************************************************************************
 568       return
 569       end
 570 C-----------------------------------------------------------------------------
 571       subroutine eljk(evdw,evdw_t)
 572 C
 573 C This subroutine calculates the interaction energy of nonbonded side chains
 574 C assuming the LJK potential of interaction.
 575 C
 576       implicit real*8 (a-h,o-z)
 577       include 'DIMENSIONS'
 578       include 'DIMENSIONS.ZSCOPT'
 579       include "DIMENSIONS.COMPAR"
 580       include 'COMMON.GEO'
 581       include 'COMMON.VAR'
 582       include 'COMMON.LOCAL'
 583       include 'COMMON.CHAIN'
 584       include 'COMMON.DERIV'
 585       include 'COMMON.INTERACT'
 586       include 'COMMON.ENEPS'
 587       include 'COMMON.IOUNITS'
 588       include 'COMMON.NAMES'
 589       dimension gg(3)
 590       logical scheck
 591       integer icant
 592       external icant
 593 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 594       do i=1,210
 595         do j=1,2
 596           eneps_temp(j,i)=0.0d0
 597         enddo
 598       enddo
 599       evdw=0.0D0
 600       evdw_t=0.0d0
 601       do i=iatsc_s,iatsc_e
 602         itypi=itype(i)
 603         itypi1=itype(i+1)
 604         xi=c(1,nres+i)
 605         yi=c(2,nres+i)
 606         zi=c(3,nres+i)
 607 C
 608 C Calculate SC interaction energy.
 609 C
 610         do iint=1,nint_gr(i)
 611           do j=istart(i,iint),iend(i,iint)
 612             itypj=itype(j)
 613             xj=c(1,nres+j)-xi
 614             yj=c(2,nres+j)-yi
 615             zj=c(3,nres+j)-zi
 616             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 617             fac_augm=rrij**expon
 618             e_augm=augm(itypi,itypj)*fac_augm
 619             r_inv_ij=dsqrt(rrij)
 620             rij=1.0D0/r_inv_ij
 621             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 622             fac=r_shift_inv**expon
 623             e1=fac*fac*aa(itypi,itypj)
 624             e2=fac*bb(itypi,itypj)
 625             evdwij=e_augm+e1+e2
 626             ij=icant(itypi,itypj)
 627             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 628      &        /dabs(eps(itypi,itypj))
 629             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 630 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 631 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 632 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 633 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 634 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 635 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 636 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 637             if (bb(itypi,itypj).gt.0.0d0) then
 638               evdw=evdw+evdwij
 639             else
 640               evdw_t=evdw_t+evdwij
 641             endif
 642             if (calc_grad) then
 643 C
 644 C Calculate the components of the gradient in DC and X
 645 C
 646             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 647             gg(1)=xj*fac
 648             gg(2)=yj*fac
 649             gg(3)=zj*fac
 650             do k=1,3
 651               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 652               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 653             enddo
 654             do k=i,j-1
 655               do l=1,3
 656                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 657               enddo
 658             enddo
 659             endif
 660           enddo      ! j
 661         enddo        ! iint
 662       enddo          ! i
 663       if (calc_grad) then
 664       do i=1,nct
 665         do j=1,3
 666           gvdwc(j,i)=expon*gvdwc(j,i)
 667           gvdwx(j,i)=expon*gvdwx(j,i)
 668         enddo
 669       enddo
 670       endif
 671       return
 672       end
 673 C-----------------------------------------------------------------------------
 674       subroutine ebp(evdw,evdw_t)
 675 C
 676 C This subroutine calculates the interaction energy of nonbonded side chains
 677 C assuming the Berne-Pechukas potential of interaction.
 678 C
 679       implicit real*8 (a-h,o-z)
 680       include 'DIMENSIONS'
 681       include 'DIMENSIONS.ZSCOPT'
 682       include "DIMENSIONS.COMPAR"
 683       include 'COMMON.GEO'
 684       include 'COMMON.VAR'
 685       include 'COMMON.LOCAL'
 686       include 'COMMON.CHAIN'
 687       include 'COMMON.DERIV'
 688       include 'COMMON.NAMES'
 689       include 'COMMON.INTERACT'
 690       include 'COMMON.ENEPS'
 691       include 'COMMON.IOUNITS'
 692       include 'COMMON.CALC'
 693       common /srutu/ icall
 694 c     double precision rrsave(maxdim)
 695       logical lprn
 696       integer icant
 697       external icant
 698       do i=1,210
 699         do j=1,2
 700           eneps_temp(j,i)=0.0d0
 701         enddo
 702       enddo
 703       evdw=0.0D0
 704       evdw_t=0.0d0
 705 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 706 c     if (icall.eq.0) then
 707 c       lprn=.true.
 708 c     else
 709         lprn=.false.
 710 c     endif
 711       ind=0
 712       do i=iatsc_s,iatsc_e
 713         itypi=itype(i)
 714         itypi1=itype(i+1)
 715         xi=c(1,nres+i)
 716         yi=c(2,nres+i)
 717         zi=c(3,nres+i)
 718         dxi=dc_norm(1,nres+i)
 719         dyi=dc_norm(2,nres+i)
 720         dzi=dc_norm(3,nres+i)
 721         dsci_inv=vbld_inv(i+nres)
 722 C
 723 C Calculate SC interaction energy.
 724 C
 725         do iint=1,nint_gr(i)
 726           do j=istart(i,iint),iend(i,iint)
 727             ind=ind+1
 728             itypj=itype(j)
 729             dscj_inv=vbld_inv(j+nres)
 730             chi1=chi(itypi,itypj)
 731             chi2=chi(itypj,itypi)
 732             chi12=chi1*chi2
 733             chip1=chip(itypi)
 734             chip2=chip(itypj)
 735             chip12=chip1*chip2
 736             alf1=alp(itypi)
 737             alf2=alp(itypj)
 738             alf12=0.5D0*(alf1+alf2)
 739 C For diagnostics only!!!
 740 c           chi1=0.0D0
 741 c           chi2=0.0D0
 742 c           chi12=0.0D0
 743 c           chip1=0.0D0
 744 c           chip2=0.0D0
 745 c           chip12=0.0D0
 746 c           alf1=0.0D0
 747 c           alf2=0.0D0
 748 c           alf12=0.0D0
 749             xj=c(1,nres+j)-xi
 750             yj=c(2,nres+j)-yi
 751             zj=c(3,nres+j)-zi
 752             dxj=dc_norm(1,nres+j)
 753             dyj=dc_norm(2,nres+j)
 754             dzj=dc_norm(3,nres+j)
 755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 756 cd          if (icall.eq.0) then
 757 cd            rrsave(ind)=rrij
 758 cd          else
 759 cd            rrij=rrsave(ind)
 760 cd          endif
 761             rij=dsqrt(rrij)
 762 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 763             call sc_angular
 764 C Calculate whole angle-dependent part of epsilon and contributions
 765 C to its derivatives
 766             fac=(rrij*sigsq)**expon2
 767             e1=fac*fac*aa(itypi,itypj)
 768             e2=fac*bb(itypi,itypj)
 769             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 770             eps2der=evdwij*eps3rt
 771             eps3der=evdwij*eps2rt
 772             evdwij=evdwij*eps2rt*eps3rt
 773             ij=icant(itypi,itypj)
 774             aux=eps1*eps2rt**2*eps3rt**2
 775             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 776      &        /dabs(eps(itypi,itypj))
 777             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 778             if (bb(itypi,itypj).gt.0.0d0) then
 779               evdw=evdw+evdwij
 780             else
 781               evdw_t=evdw_t+evdwij
 782             endif
 783             if (calc_grad) then
 784             if (lprn) then
 785             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 786             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 787 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 788 cd     &        restyp(itypi),i,restyp(itypj),j,
 789 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 790 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 791 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 792 cd     &        evdwij
 793             endif
 794 C Calculate gradient components.
 795             e1=e1*eps1*eps2rt**2*eps3rt**2
 796             fac=-expon*(e1+evdwij)
 797             sigder=fac/sigsq
 798             fac=rrij*fac
 799 C Calculate radial part of the gradient
 800             gg(1)=xj*fac
 801             gg(2)=yj*fac
 802             gg(3)=zj*fac
 803 C Calculate the angular part of the gradient and sum add the contributions
 804 C to the appropriate components of the Cartesian gradient.
 805             call sc_grad
 806             endif
 807           enddo      ! j
 808         enddo        ! iint
 809       enddo          ! i
 810 c     stop
 811       return
 812       end
 813 C-----------------------------------------------------------------------------
 814       subroutine egb(evdw,evdw_t)
 815 C
 816 C This subroutine calculates the interaction energy of nonbonded side chains
 817 C assuming the Gay-Berne potential of interaction.
 818 C
 819       implicit real*8 (a-h,o-z)
 820       include 'DIMENSIONS'
 821       include 'DIMENSIONS.ZSCOPT'
 822       include "DIMENSIONS.COMPAR"
 823       include 'COMMON.GEO'
 824       include 'COMMON.VAR'
 825       include 'COMMON.LOCAL'
 826       include 'COMMON.CHAIN'
 827       include 'COMMON.DERIV'
 828       include 'COMMON.NAMES'
 829       include 'COMMON.INTERACT'
 830       include 'COMMON.ENEPS'
 831       include 'COMMON.IOUNITS'
 832       include 'COMMON.CALC'
 833       include 'COMMON.SBRIDGE'
 834       logical lprn
 835       common /srutu/icall
 836       integer icant
 837       external icant
 838       do i=1,210
 839         do j=1,2
 840           eneps_temp(j,i)=0.0d0
 841         enddo
 842       enddo
 843 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 844       evdw=0.0D0
 845       evdw_t=0.0d0
 846       lprn=.false.
 847 c      if (icall.gt.0) lprn=.true.
 848       ind=0
 849       do i=iatsc_s,iatsc_e
 850         itypi=itype(i)
 851         itypi1=itype(i+1)
 852         xi=c(1,nres+i)
 853         yi=c(2,nres+i)
 854         zi=c(3,nres+i)
 855         dxi=dc_norm(1,nres+i)
 856         dyi=dc_norm(2,nres+i)
 857         dzi=dc_norm(3,nres+i)
 858         dsci_inv=vbld_inv(i+nres)
 859 C
 860 C Calculate SC interaction energy.
 861 C
 862         do iint=1,nint_gr(i)
 863           do j=istart(i,iint),iend(i,iint)
 864 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 865 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 866 C formation no electrostatic interactions should be calculated. If it
 867 C would be allowed NaN would appear
 868             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 869 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 870 C residue can or cannot form disulfide bond. There is still bug allowing
 871 C Cys...Cys...Cys bond formation
 872               call dyn_ssbond_ene(i,j,evdwij)
 873 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 874 C function in ssMD.F
 875               evdw=evdw+evdwij
 876 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 877 c     &                        'evdw',i,j,evdwij,' ss'
 878             ELSE
 879             ind=ind+1
 880             itypj=itype(j)
 881             dscj_inv=vbld_inv(j+nres)
 882             sig0ij=sigma(itypi,itypj)
 883             chi1=chi(itypi,itypj)
 884             chi2=chi(itypj,itypi)
 885             chi12=chi1*chi2
 886             chip1=chip(itypi)
 887             chip2=chip(itypj)
 888             chip12=chip1*chip2
 889             alf1=alp(itypi)
 890             alf2=alp(itypj)
 891             alf12=0.5D0*(alf1+alf2)
 892 C For diagnostics only!!!
 893 c           chi1=0.0D0
 894 c           chi2=0.0D0
 895 c           chi12=0.0D0
 896 c           chip1=0.0D0
 897 c           chip2=0.0D0
 898 c           chip12=0.0D0
 899 c           alf1=0.0D0
 900 c           alf2=0.0D0
 901 c           alf12=0.0D0
 902             xj=c(1,nres+j)-xi
 903             yj=c(2,nres+j)-yi
 904             zj=c(3,nres+j)-zi
 905             dxj=dc_norm(1,nres+j)
 906             dyj=dc_norm(2,nres+j)
 907             dzj=dc_norm(3,nres+j)
 908 c            write (iout,*) i,j,xj,yj,zj
 909             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 910             rij=dsqrt(rrij)
 911 C Calculate angle-dependent terms of energy and contributions to their
 912 C derivatives.
 913             call sc_angular
 914             sigsq=1.0D0/sigsq
 915             sig=sig0ij*dsqrt(sigsq)
 916             rij_shift=1.0D0/rij-sig+sig0ij
 917 C I hate to put IF's in the loops, but here don't have another choice!!!!
 918             if (rij_shift.le.0.0D0) then
 919               evdw=1.0D20
 920               return
 921             endif
 922             sigder=-sig*sigsq
 923 c---------------------------------------------------------------
 924             rij_shift=1.0D0/rij_shift
 925             fac=rij_shift**expon
 926             e1=fac*fac*aa(itypi,itypj)
 927             e2=fac*bb(itypi,itypj)
 928             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 929             eps2der=evdwij*eps3rt
 930             eps3der=evdwij*eps2rt
 931             evdwij=evdwij*eps2rt*eps3rt
 932             if (bb(itypi,itypj).gt.0) then
 933               evdw=evdw+evdwij
 934             else
 935               evdw_t=evdw_t+evdwij
 936             endif
 937             ij=icant(itypi,itypj)
 938             aux=eps1*eps2rt**2*eps3rt**2
 939             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 940      &        /dabs(eps(itypi,itypj))
 941             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 942 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 943 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 944 c     &         aux*e2/eps(itypi,itypj)
 945 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 946             if (lprn) then
 947             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 948             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 949             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 950      &        restyp(itypi),i,restyp(itypj),j,
 951      &        epsi,sigm,chi1,chi2,chip1,chip2,
 952      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 953      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 954      &        evdwij
 955             endif
 956             if (calc_grad) then
 957 C Calculate gradient components.
 958             e1=e1*eps1*eps2rt**2*eps3rt**2
 959             fac=-expon*(e1+evdwij)*rij_shift
 960             sigder=fac*sigder
 961             fac=rij*fac
 962 C Calculate the radial part of the gradient
 963             gg(1)=xj*fac
 964             gg(2)=yj*fac
 965             gg(3)=zj*fac
 966 C Calculate angular part of the gradient.
 967             call sc_grad
 968             endif
 969             ENDIF    ! dyn_ss
 970           enddo      ! j
 971         enddo        ! iint
 972       enddo          ! i
 973       return
 974       end
 975 C-----------------------------------------------------------------------------
 976       subroutine egbv(evdw,evdw_t)
 977 C
 978 C This subroutine calculates the interaction energy of nonbonded side chains
 979 C assuming the Gay-Berne-Vorobjev potential of interaction.
 980 C
 981       implicit real*8 (a-h,o-z)
 982       include 'DIMENSIONS'
 983       include 'DIMENSIONS.ZSCOPT'
 984       include "DIMENSIONS.COMPAR"
 985       include 'COMMON.GEO'
 986       include 'COMMON.VAR'
 987       include 'COMMON.LOCAL'
 988       include 'COMMON.CHAIN'
 989       include 'COMMON.DERIV'
 990       include 'COMMON.NAMES'
 991       include 'COMMON.INTERACT'
 992       include 'COMMON.ENEPS'
 993       include 'COMMON.IOUNITS'
 994       include 'COMMON.CALC'
 995       common /srutu/ icall
 996       logical lprn
 997       integer icant
 998       external icant
 999       do i=1,210
1000         do j=1,2
1001           eneps_temp(j,i)=0.0d0
1002         enddo
1003       enddo
1004       evdw=0.0D0
1005       evdw_t=0.0d0
1006 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1007       evdw=0.0D0
1008       lprn=.false.
1009 c      if (icall.gt.0) lprn=.true.
1010       ind=0
1011       do i=iatsc_s,iatsc_e
1012         itypi=itype(i)
1013         itypi1=itype(i+1)
1014         xi=c(1,nres+i)
1015         yi=c(2,nres+i)
1016         zi=c(3,nres+i)
1017         dxi=dc_norm(1,nres+i)
1018         dyi=dc_norm(2,nres+i)
1019         dzi=dc_norm(3,nres+i)
1020         dsci_inv=vbld_inv(i+nres)
1021 C
1022 C Calculate SC interaction energy.
1023 C
1024         do iint=1,nint_gr(i)
1025           do j=istart(i,iint),iend(i,iint)
1026             ind=ind+1
1027             itypj=itype(j)
1028             dscj_inv=vbld_inv(j+nres)
1029             sig0ij=sigma(itypi,itypj)
1030             r0ij=r0(itypi,itypj)
1031             chi1=chi(itypi,itypj)
1032             chi2=chi(itypj,itypi)
1033             chi12=chi1*chi2
1034             chip1=chip(itypi)
1035             chip2=chip(itypj)
1036             chip12=chip1*chip2
1037             alf1=alp(itypi)
1038             alf2=alp(itypj)
1039             alf12=0.5D0*(alf1+alf2)
1040 C For diagnostics only!!!
1041 c           chi1=0.0D0
1042 c           chi2=0.0D0
1043 c           chi12=0.0D0
1044 c           chip1=0.0D0
1045 c           chip2=0.0D0
1046 c           chip12=0.0D0
1047 c           alf1=0.0D0
1048 c           alf2=0.0D0
1049 c           alf12=0.0D0
1050             xj=c(1,nres+j)-xi
1051             yj=c(2,nres+j)-yi
1052             zj=c(3,nres+j)-zi
1053             dxj=dc_norm(1,nres+j)
1054             dyj=dc_norm(2,nres+j)
1055             dzj=dc_norm(3,nres+j)
1056             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1057             rij=dsqrt(rrij)
1058 C Calculate angle-dependent terms of energy and contributions to their
1059 C derivatives.
1060             call sc_angular
1061             sigsq=1.0D0/sigsq
1062             sig=sig0ij*dsqrt(sigsq)
1063             rij_shift=1.0D0/rij-sig+r0ij
1064 C I hate to put IF's in the loops, but here don't have another choice!!!!
1065             if (rij_shift.le.0.0D0) then
1066               evdw=1.0D20
1067               return
1068             endif
1069             sigder=-sig*sigsq
1070 c---------------------------------------------------------------
1071             rij_shift=1.0D0/rij_shift
1072             fac=rij_shift**expon
1073             e1=fac*fac*aa(itypi,itypj)
1074             e2=fac*bb(itypi,itypj)
1075             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1076             eps2der=evdwij*eps3rt
1077             eps3der=evdwij*eps2rt
1078             fac_augm=rrij**expon
1079             e_augm=augm(itypi,itypj)*fac_augm
1080             evdwij=evdwij*eps2rt*eps3rt
1081             if (bb(itypi,itypj).gt.0.0d0) then
1082               evdw=evdw+evdwij+e_augm
1083             else
1084               evdw_t=evdw_t+evdwij+e_augm
1085             endif
1086             ij=icant(itypi,itypj)
1087             aux=eps1*eps2rt**2*eps3rt**2
1088             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1089      &        /dabs(eps(itypi,itypj))
1090             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1091 c            eneps_temp(ij)=eneps_temp(ij)
1092 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1093 c            if (lprn) then
1094 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1097 c     &        restyp(itypi),i,restyp(itypj),j,
1098 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1099 c     &        chi1,chi2,chip1,chip2,
1100 c     &        eps1,eps2rt**2,eps3rt**2,
1101 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1102 c     &        evdwij+e_augm
1103 c            endif
1104             if (calc_grad) then
1105 C Calculate gradient components.
1106             e1=e1*eps1*eps2rt**2*eps3rt**2
1107             fac=-expon*(e1+evdwij)*rij_shift
1108             sigder=fac*sigder
1109             fac=rij*fac-2*expon*rrij*e_augm
1110 C Calculate the radial part of the gradient
1111             gg(1)=xj*fac
1112             gg(2)=yj*fac
1113             gg(3)=zj*fac
1114 C Calculate angular part of the gradient.
1115             call sc_grad
1116             endif
1117           enddo      ! j
1118         enddo        ! iint
1119       enddo          ! i
1120       return
1121       end
1122 C-----------------------------------------------------------------------------
1123       subroutine sc_angular
1124 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1125 C om12. Called by ebp, egb, and egbv.
1126       implicit none
1127       include 'COMMON.CALC'
1128       erij(1)=xj*rij
1129       erij(2)=yj*rij
1130       erij(3)=zj*rij
1131       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1132       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1133       om12=dxi*dxj+dyi*dyj+dzi*dzj
1134       chiom12=chi12*om12
1135 C Calculate eps1(om12) and its derivative in om12
1136       faceps1=1.0D0-om12*chiom12
1137       faceps1_inv=1.0D0/faceps1
1138       eps1=dsqrt(faceps1_inv)
1139 C Following variable is eps1*deps1/dom12
1140       eps1_om12=faceps1_inv*chiom12
1141 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1142 C and om12.
1143       om1om2=om1*om2
1144       chiom1=chi1*om1
1145       chiom2=chi2*om2
1146       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1147       sigsq=1.0D0-facsig*faceps1_inv
1148       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1149       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1150       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1151 C Calculate eps2 and its derivatives in om1, om2, and om12.
1152       chipom1=chip1*om1
1153       chipom2=chip2*om2
1154       chipom12=chip12*om12
1155       facp=1.0D0-om12*chipom12
1156       facp_inv=1.0D0/facp
1157       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1158 C Following variable is the square root of eps2
1159       eps2rt=1.0D0-facp1*facp_inv
1160 C Following three variables are the derivatives of the square root of eps
1161 C in om1, om2, and om12.
1162       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1163       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1164       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1165 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1166       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1167 C Calculate whole angle-dependent part of epsilon and contributions
1168 C to its derivatives
1169       return
1170       end
1171 C----------------------------------------------------------------------------
1172       subroutine sc_grad
1173       implicit real*8 (a-h,o-z)
1174       include 'DIMENSIONS'
1175       include 'DIMENSIONS.ZSCOPT'
1176       include 'COMMON.CHAIN'
1177       include 'COMMON.DERIV'
1178       include 'COMMON.CALC'
1179       double precision dcosom1(3),dcosom2(3)
1180       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1181       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1182       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1183      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1184       do k=1,3
1185         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1186         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1187       enddo
1188       do k=1,3
1189         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1190       enddo
1191       do k=1,3
1192         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1194      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1195         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1197      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1198       enddo
1199 C
1200 C Calculate the components of the gradient in DC and X
1201 C
1202       do k=i,j-1
1203         do l=1,3
1204           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1205         enddo
1206       enddo
1207       return
1208       end
1209 c------------------------------------------------------------------------------
1210       subroutine vec_and_deriv
1211       implicit real*8 (a-h,o-z)
1212       include 'DIMENSIONS'
1213       include 'DIMENSIONS.ZSCOPT'
1214       include 'COMMON.IOUNITS'
1215       include 'COMMON.GEO'
1216       include 'COMMON.VAR'
1217       include 'COMMON.LOCAL'
1218       include 'COMMON.CHAIN'
1219       include 'COMMON.VECTORS'
1220       include 'COMMON.DERIV'
1221       include 'COMMON.INTERACT'
1222       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1223 C Compute the local reference systems. For reference system (i), the
1224 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1225 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1226       do i=1,nres-1
1227 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1228           if (i.eq.nres-1) then
1229 C Case of the last full residue
1230 C Compute the Z-axis
1231             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1232             costh=dcos(pi-theta(nres))
1233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1234             do k=1,3
1235               uz(k,i)=fac*uz(k,i)
1236             enddo
1237             if (calc_grad) then
1238 C Compute the derivatives of uz
1239             uzder(1,1,1)= 0.0d0
1240             uzder(2,1,1)=-dc_norm(3,i-1)
1241             uzder(3,1,1)= dc_norm(2,i-1)
1242             uzder(1,2,1)= dc_norm(3,i-1)
1243             uzder(2,2,1)= 0.0d0
1244             uzder(3,2,1)=-dc_norm(1,i-1)
1245             uzder(1,3,1)=-dc_norm(2,i-1)
1246             uzder(2,3,1)= dc_norm(1,i-1)
1247             uzder(3,3,1)= 0.0d0
1248             uzder(1,1,2)= 0.0d0
1249             uzder(2,1,2)= dc_norm(3,i)
1250             uzder(3,1,2)=-dc_norm(2,i)
1251             uzder(1,2,2)=-dc_norm(3,i)
1252             uzder(2,2,2)= 0.0d0
1253             uzder(3,2,2)= dc_norm(1,i)
1254             uzder(1,3,2)= dc_norm(2,i)
1255             uzder(2,3,2)=-dc_norm(1,i)
1256             uzder(3,3,2)= 0.0d0
1257             endif
1258 C Compute the Y-axis
1259             facy=fac
1260             do k=1,3
1261               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1262             enddo
1263             if (calc_grad) then
1264 C Compute the derivatives of uy
1265             do j=1,3
1266               do k=1,3
1267                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1268      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1269                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1270               enddo
1271               uyder(j,j,1)=uyder(j,j,1)-costh
1272               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1273             enddo
1274             do j=1,2
1275               do k=1,3
1276                 do l=1,3
1277                   uygrad(l,k,j,i)=uyder(l,k,j)
1278                   uzgrad(l,k,j,i)=uzder(l,k,j)
1279                 enddo
1280               enddo
1281             enddo
1282             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1283             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1284             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1285             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1286             endif
1287           else
1288 C Other residues
1289 C Compute the Z-axis
1290             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1291             costh=dcos(pi-theta(i+2))
1292             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1293             do k=1,3
1294               uz(k,i)=fac*uz(k,i)
1295             enddo
1296             if (calc_grad) then
1297 C Compute the derivatives of uz
1298             uzder(1,1,1)= 0.0d0
1299             uzder(2,1,1)=-dc_norm(3,i+1)
1300             uzder(3,1,1)= dc_norm(2,i+1)
1301             uzder(1,2,1)= dc_norm(3,i+1)
1302             uzder(2,2,1)= 0.0d0
1303             uzder(3,2,1)=-dc_norm(1,i+1)
1304             uzder(1,3,1)=-dc_norm(2,i+1)
1305             uzder(2,3,1)= dc_norm(1,i+1)
1306             uzder(3,3,1)= 0.0d0
1307             uzder(1,1,2)= 0.0d0
1308             uzder(2,1,2)= dc_norm(3,i)
1309             uzder(3,1,2)=-dc_norm(2,i)
1310             uzder(1,2,2)=-dc_norm(3,i)
1311             uzder(2,2,2)= 0.0d0
1312             uzder(3,2,2)= dc_norm(1,i)
1313             uzder(1,3,2)= dc_norm(2,i)
1314             uzder(2,3,2)=-dc_norm(1,i)
1315             uzder(3,3,2)= 0.0d0
1316             endif
1317 C Compute the Y-axis
1318             facy=fac
1319             do k=1,3
1320               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1321             enddo
1322             if (calc_grad) then
1323 C Compute the derivatives of uy
1324             do j=1,3
1325               do k=1,3
1326                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1327      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1328                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1329               enddo
1330               uyder(j,j,1)=uyder(j,j,1)-costh
1331               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1332             enddo
1333             do j=1,2
1334               do k=1,3
1335                 do l=1,3
1336                   uygrad(l,k,j,i)=uyder(l,k,j)
1337                   uzgrad(l,k,j,i)=uzder(l,k,j)
1338                 enddo
1339               enddo
1340             enddo
1341             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1342             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1343             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1344             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1345           endif
1346           endif
1347       enddo
1348       if (calc_grad) then
1349       do i=1,nres-1
1350         vbld_inv_temp(1)=vbld_inv(i+1)
1351         if (i.lt.nres-1) then
1352           vbld_inv_temp(2)=vbld_inv(i+2)
1353         else
1354           vbld_inv_temp(2)=vbld_inv(i)
1355         endif
1356         do j=1,2
1357           do k=1,3
1358             do l=1,3
1359               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1360               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1361             enddo
1362           enddo
1363         enddo
1364       enddo
1365       endif
1366       return
1367       end
1368 C-----------------------------------------------------------------------------
1369       subroutine vec_and_deriv_test
1370       implicit real*8 (a-h,o-z)
1371       include 'DIMENSIONS'
1372       include 'DIMENSIONS.ZSCOPT'
1373       include 'COMMON.IOUNITS'
1374       include 'COMMON.GEO'
1375       include 'COMMON.VAR'
1376       include 'COMMON.LOCAL'
1377       include 'COMMON.CHAIN'
1378       include 'COMMON.VECTORS'
1379       dimension uyder(3,3,2),uzder(3,3,2)
1380 C Compute the local reference systems. For reference system (i), the
1381 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1382 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1383       do i=1,nres-1
1384           if (i.eq.nres-1) then
1385 C Case of the last full residue
1386 C Compute the Z-axis
1387             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1388             costh=dcos(pi-theta(nres))
1389             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1390 c            write (iout,*) 'fac',fac,
1391 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i-1)
1399             uzder(3,1,1)= dc_norm(2,i-1)
1400             uzder(1,2,1)= dc_norm(3,i-1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i-1)
1403             uzder(1,3,1)=-dc_norm(2,i-1)
1404             uzder(2,3,1)= dc_norm(1,i-1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             do k=1,3
1417               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1418             enddo
1419             facy=fac
1420             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1421      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1422      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1423             do k=1,3
1424 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1425               uy(k,i)=
1426 c     &        facy*(
1427      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1428      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1429 c     &        )
1430             enddo
1431 c            write (iout,*) 'facy',facy,
1432 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1434             do k=1,3
1435               uy(k,i)=facy*uy(k,i)
1436             enddo
1437 C Compute the derivatives of uy
1438             do j=1,3
1439               do k=1,3
1440                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1441      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1442                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1443               enddo
1444 c              uyder(j,j,1)=uyder(j,j,1)-costh
1445 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1446               uyder(j,j,1)=uyder(j,j,1)
1447      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1448               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1449      &          +uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463           else
1464 C Other residues
1465 C Compute the Z-axis
1466             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1467             costh=dcos(pi-theta(i+2))
1468             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1469             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1470             do k=1,3
1471               uz(k,i)=fac*uz(k,i)
1472             enddo
1473 C Compute the derivatives of uz
1474             uzder(1,1,1)= 0.0d0
1475             uzder(2,1,1)=-dc_norm(3,i+1)
1476             uzder(3,1,1)= dc_norm(2,i+1)
1477             uzder(1,2,1)= dc_norm(3,i+1)
1478             uzder(2,2,1)= 0.0d0
1479             uzder(3,2,1)=-dc_norm(1,i+1)
1480             uzder(1,3,1)=-dc_norm(2,i+1)
1481             uzder(2,3,1)= dc_norm(1,i+1)
1482             uzder(3,3,1)= 0.0d0
1483             uzder(1,1,2)= 0.0d0
1484             uzder(2,1,2)= dc_norm(3,i)
1485             uzder(3,1,2)=-dc_norm(2,i)
1486             uzder(1,2,2)=-dc_norm(3,i)
1487             uzder(2,2,2)= 0.0d0
1488             uzder(3,2,2)= dc_norm(1,i)
1489             uzder(1,3,2)= dc_norm(2,i)
1490             uzder(2,3,2)=-dc_norm(1,i)
1491             uzder(3,3,2)= 0.0d0
1492 C Compute the Y-axis
1493             facy=fac
1494             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1495      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1496      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1497             do k=1,3
1498 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1499               uy(k,i)=
1500 c     &        facy*(
1501      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1502      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1503 c     &        )
1504             enddo
1505 c            write (iout,*) 'facy',facy,
1506 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1508             do k=1,3
1509               uy(k,i)=facy*uy(k,i)
1510             enddo
1511 C Compute the derivatives of uy
1512             do j=1,3
1513               do k=1,3
1514                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1515      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1516                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1517               enddo
1518 c              uyder(j,j,1)=uyder(j,j,1)-costh
1519 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1520               uyder(j,j,1)=uyder(j,j,1)
1521      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1522               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1523      &          +uyder(j,j,2)
1524             enddo
1525             do j=1,2
1526               do k=1,3
1527                 do l=1,3
1528                   uygrad(l,k,j,i)=uyder(l,k,j)
1529                   uzgrad(l,k,j,i)=uzder(l,k,j)
1530                 enddo
1531               enddo
1532             enddo
1533             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1534             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1535             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1536             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1537           endif
1538       enddo
1539       do i=1,nres-1
1540         do j=1,2
1541           do k=1,3
1542             do l=1,3
1543               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1544               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1545             enddo
1546           enddo
1547         enddo
1548       enddo
1549       return
1550       end
1551 C-----------------------------------------------------------------------------
1552       subroutine check_vecgrad
1553       implicit real*8 (a-h,o-z)
1554       include 'DIMENSIONS'
1555       include 'DIMENSIONS.ZSCOPT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.GEO'
1558       include 'COMMON.VAR'
1559       include 'COMMON.LOCAL'
1560       include 'COMMON.CHAIN'
1561       include 'COMMON.VECTORS'
1562       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1563       dimension uyt(3,maxres),uzt(3,maxres)
1564       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1565       double precision delta /1.0d-7/
1566       call vec_and_deriv
1567 cd      do i=1,nres
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1570 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1571 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1572 cd     &     (dc_norm(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1574 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1575 cd          write(iout,'(a)')
1576 cd      enddo
1577       do i=1,nres
1578         do j=1,2
1579           do k=1,3
1580             do l=1,3
1581               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1582               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1583             enddo
1584           enddo
1585         enddo
1586       enddo
1587       call vec_and_deriv
1588       do i=1,nres
1589         do j=1,3
1590           uyt(j,i)=uy(j,i)
1591           uzt(j,i)=uz(j,i)
1592         enddo
1593       enddo
1594       do i=1,nres
1595 cd        write (iout,*) 'i=',i
1596         do k=1,3
1597           erij(k)=dc_norm(k,i)
1598         enddo
1599         do j=1,3
1600           do k=1,3
1601             dc_norm(k,i)=erij(k)
1602           enddo
1603           dc_norm(j,i)=dc_norm(j,i)+delta
1604 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1605 c          do k=1,3
1606 c            dc_norm(k,i)=dc_norm(k,i)/fac
1607 c          enddo
1608 c          write (iout,*) (dc_norm(k,i),k=1,3)
1609 c          write (iout,*) (erij(k),k=1,3)
1610           call vec_and_deriv
1611           do k=1,3
1612             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1613             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1614             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1615             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1616           enddo
1617 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1618 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1619 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1620         enddo
1621         do k=1,3
1622           dc_norm(k,i)=erij(k)
1623         enddo
1624 cd        do k=1,3
1625 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1626 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1627 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1628 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1629 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1630 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1631 cd          write (iout,'(a)')
1632 cd        enddo
1633       enddo
1634       return
1635       end
1636 C--------------------------------------------------------------------------
1637       subroutine set_matrices
1638       implicit real*8 (a-h,o-z)
1639       include 'DIMENSIONS'
1640       include 'DIMENSIONS.ZSCOPT'
1641       include 'COMMON.IOUNITS'
1642       include 'COMMON.GEO'
1643       include 'COMMON.VAR'
1644       include 'COMMON.LOCAL'
1645       include 'COMMON.CHAIN'
1646       include 'COMMON.DERIV'
1647       include 'COMMON.INTERACT'
1648       include 'COMMON.CONTACTS'
1649       include 'COMMON.TORSION'
1650       include 'COMMON.VECTORS'
1651       include 'COMMON.FFIELD'
1652       double precision auxvec(2),auxmat(2,2)
1653 C
1654 C Compute the virtual-bond-torsional-angle dependent quantities needed
1655 C to calculate the el-loc multibody terms of various order.
1656 C
1657       do i=3,nres+1
1658         if (i .lt. nres+1) then
1659           sin1=dsin(phi(i))
1660           cos1=dcos(phi(i))
1661           sintab(i-2)=sin1
1662           costab(i-2)=cos1
1663           obrot(1,i-2)=cos1
1664           obrot(2,i-2)=sin1
1665           sin2=dsin(2*phi(i))
1666           cos2=dcos(2*phi(i))
1667           sintab2(i-2)=sin2
1668           costab2(i-2)=cos2
1669           obrot2(1,i-2)=cos2
1670           obrot2(2,i-2)=sin2
1671           Ug(1,1,i-2)=-cos1
1672           Ug(1,2,i-2)=-sin1
1673           Ug(2,1,i-2)=-sin1
1674           Ug(2,2,i-2)= cos1
1675           Ug2(1,1,i-2)=-cos2
1676           Ug2(1,2,i-2)=-sin2
1677           Ug2(2,1,i-2)=-sin2
1678           Ug2(2,2,i-2)= cos2
1679         else
1680           costab(i-2)=1.0d0
1681           sintab(i-2)=0.0d0
1682           obrot(1,i-2)=1.0d0
1683           obrot(2,i-2)=0.0d0
1684           obrot2(1,i-2)=0.0d0
1685           obrot2(2,i-2)=0.0d0
1686           Ug(1,1,i-2)=1.0d0
1687           Ug(1,2,i-2)=0.0d0
1688           Ug(2,1,i-2)=0.0d0
1689           Ug(2,2,i-2)=1.0d0
1690           Ug2(1,1,i-2)=0.0d0
1691           Ug2(1,2,i-2)=0.0d0
1692           Ug2(2,1,i-2)=0.0d0
1693           Ug2(2,2,i-2)=0.0d0
1694         endif
1695         if (i .gt. 3 .and. i .lt. nres+1) then
1696           obrot_der(1,i-2)=-sin1
1697           obrot_der(2,i-2)= cos1
1698           Ugder(1,1,i-2)= sin1
1699           Ugder(1,2,i-2)=-cos1
1700           Ugder(2,1,i-2)=-cos1
1701           Ugder(2,2,i-2)=-sin1
1702           dwacos2=cos2+cos2
1703           dwasin2=sin2+sin2
1704           obrot2_der(1,i-2)=-dwasin2
1705           obrot2_der(2,i-2)= dwacos2
1706           Ug2der(1,1,i-2)= dwasin2
1707           Ug2der(1,2,i-2)=-dwacos2
1708           Ug2der(2,1,i-2)=-dwacos2
1709           Ug2der(2,2,i-2)=-dwasin2
1710         else
1711           obrot_der(1,i-2)=0.0d0
1712           obrot_der(2,i-2)=0.0d0
1713           Ugder(1,1,i-2)=0.0d0
1714           Ugder(1,2,i-2)=0.0d0
1715           Ugder(2,1,i-2)=0.0d0
1716           Ugder(2,2,i-2)=0.0d0
1717           obrot2_der(1,i-2)=0.0d0
1718           obrot2_der(2,i-2)=0.0d0
1719           Ug2der(1,1,i-2)=0.0d0
1720           Ug2der(1,2,i-2)=0.0d0
1721           Ug2der(2,1,i-2)=0.0d0
1722           Ug2der(2,2,i-2)=0.0d0
1723         endif
1724         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1725           iti = itortyp(itype(i-2))
1726         else
1727           iti=ntortyp+1
1728         endif
1729         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1730           iti1 = itortyp(itype(i-1))
1731         else
1732           iti1=ntortyp+1
1733         endif
1734 cd        write (iout,*) '*******i',i,' iti1',iti
1735 cd        write (iout,*) 'b1',b1(:,iti)
1736 cd        write (iout,*) 'b2',b2(:,iti)
1737 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1738         if (i .gt. iatel_s+2) then
1739           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1740           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1741           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1742           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1743           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1744           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1745           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1746         else
1747           do k=1,2
1748             Ub2(k,i-2)=0.0d0
1749             Ctobr(k,i-2)=0.0d0
1750             Dtobr2(k,i-2)=0.0d0
1751             do l=1,2
1752               EUg(l,k,i-2)=0.0d0
1753               CUg(l,k,i-2)=0.0d0
1754               DUg(l,k,i-2)=0.0d0
1755               DtUg2(l,k,i-2)=0.0d0
1756             enddo
1757           enddo
1758         endif
1759         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1760         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1761         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1762         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1763         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1764         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1765         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1766         do k=1,2
1767           muder(k,i-2)=Ub2der(k,i-2)
1768         enddo
1769         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1770           iti1 = itortyp(itype(i-1))
1771         else
1772           iti1=ntortyp+1
1773         endif
1774         do k=1,2
1775           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1776         enddo
1777 C Vectors and matrices dependent on a single virtual-bond dihedral.
1778         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1779         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1780         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1782         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1783         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1784         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1785         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1786         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1787 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1788 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1789       enddo
1790 C Matrices dependent on two consecutive virtual-bond dihedrals.
1791 C The order of matrices is from left to right.
1792       do i=2,nres-1
1793         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1794         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1795         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1796         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1797         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1798         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1799         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1800         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1801       enddo
1802 cd      do i=1,nres
1803 cd        iti = itortyp(itype(i))
1804 cd        write (iout,*) i
1805 cd        do j=1,2
1806 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1807 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1808 cd        enddo
1809 cd      enddo
1810       return
1811       end
1812 C--------------------------------------------------------------------------
1813       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1814 C
1815 C This subroutine calculates the average interaction energy and its gradient
1816 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1817 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1818 C The potential depends both on the distance of peptide-group centers and on
1819 C the orientation of the CA-CA virtual bonds.
1820 C
1821       implicit real*8 (a-h,o-z)
1822       include 'DIMENSIONS'
1823       include 'DIMENSIONS.ZSCOPT'
1824       include 'DIMENSIONS.FREE'
1825       include 'COMMON.CONTROL'
1826       include 'COMMON.IOUNITS'
1827       include 'COMMON.GEO'
1828       include 'COMMON.VAR'
1829       include 'COMMON.LOCAL'
1830       include 'COMMON.CHAIN'
1831       include 'COMMON.DERIV'
1832       include 'COMMON.INTERACT'
1833       include 'COMMON.CONTACTS'
1834       include 'COMMON.TORSION'
1835       include 'COMMON.VECTORS'
1836       include 'COMMON.FFIELD'
1837       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1838      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1839       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1840      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1841       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1842 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1843       double precision scal_el /0.5d0/
1844 C 12/13/98
1845 C 13-go grudnia roku pamietnego...
1846       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1847      &                   0.0d0,1.0d0,0.0d0,
1848      &                   0.0d0,0.0d0,1.0d0/
1849 cd      write(iout,*) 'In EELEC'
1850 cd      do i=1,nloctyp
1851 cd        write(iout,*) 'Type',i
1852 cd        write(iout,*) 'B1',B1(:,i)
1853 cd        write(iout,*) 'B2',B2(:,i)
1854 cd        write(iout,*) 'CC',CC(:,:,i)
1855 cd        write(iout,*) 'DD',DD(:,:,i)
1856 cd        write(iout,*) 'EE',EE(:,:,i)
1857 cd      enddo
1858 cd      call check_vecgrad
1859 cd      stop
1860       if (icheckgrad.eq.1) then
1861         do i=1,nres-1
1862           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1863           do k=1,3
1864             dc_norm(k,i)=dc(k,i)*fac
1865           enddo
1866 c          write (iout,*) 'i',i,' fac',fac
1867         enddo
1868       endif
1869       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1870      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1871      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1872 cd      if (wel_loc.gt.0.0d0) then
1873         if (icheckgrad.eq.1) then
1874         call vec_and_deriv_test
1875         else
1876         call vec_and_deriv
1877         endif
1878         call set_matrices
1879       endif
1880 cd      do i=1,nres-1
1881 cd        write (iout,*) 'i=',i
1882 cd        do k=1,3
1883 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1884 cd        enddo
1885 cd        do k=1,3
1886 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1887 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1888 cd        enddo
1889 cd      enddo
1890       num_conti_hb=0
1891       ees=0.0D0
1892       evdw1=0.0D0
1893       eel_loc=0.0d0
1894       eello_turn3=0.0d0
1895       eello_turn4=0.0d0
1896       ind=0
1897       do i=1,nres
1898         num_cont_hb(i)=0
1899       enddo
1900 cd      print '(a)','Enter EELEC'
1901 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1902       do i=1,nres
1903         gel_loc_loc(i)=0.0d0
1904         gcorr_loc(i)=0.0d0
1905       enddo
1906       do i=iatel_s,iatel_e
1907         if (itel(i).eq.0) goto 1215
1908         dxi=dc(1,i)
1909         dyi=dc(2,i)
1910         dzi=dc(3,i)
1911         dx_normi=dc_norm(1,i)
1912         dy_normi=dc_norm(2,i)
1913         dz_normi=dc_norm(3,i)
1914         xmedi=c(1,i)+0.5d0*dxi
1915         ymedi=c(2,i)+0.5d0*dyi
1916         zmedi=c(3,i)+0.5d0*dzi
1917         num_conti=0
1918 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1919         do j=ielstart(i),ielend(i)
1920           if (itel(j).eq.0) goto 1216
1921           ind=ind+1
1922           iteli=itel(i)
1923           itelj=itel(j)
1924           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1925           aaa=app(iteli,itelj)
1926           bbb=bpp(iteli,itelj)
1927 C Diagnostics only!!!
1928 c         aaa=0.0D0
1929 c         bbb=0.0D0
1930 c         ael6i=0.0D0
1931 c         ael3i=0.0D0
1932 C End diagnostics
1933           ael6i=ael6(iteli,itelj)
1934           ael3i=ael3(iteli,itelj)
1935           dxj=dc(1,j)
1936           dyj=dc(2,j)
1937           dzj=dc(3,j)
1938           dx_normj=dc_norm(1,j)
1939           dy_normj=dc_norm(2,j)
1940           dz_normj=dc_norm(3,j)
1941           xj=c(1,j)+0.5D0*dxj-xmedi
1942           yj=c(2,j)+0.5D0*dyj-ymedi
1943           zj=c(3,j)+0.5D0*dzj-zmedi
1944           rij=xj*xj+yj*yj+zj*zj
1945           rrmij=1.0D0/rij
1946           rij=dsqrt(rij)
1947           rmij=1.0D0/rij
1948           r3ij=rrmij*rmij
1949           r6ij=r3ij*r3ij
1950           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1951           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1952           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1953           fac=cosa-3.0D0*cosb*cosg
1954           ev1=aaa*r6ij*r6ij
1955 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1956           if (j.eq.i+2) ev1=scal_el*ev1
1957           ev2=bbb*r6ij
1958           fac3=ael6i*r6ij
1959           fac4=ael3i*r3ij
1960           evdwij=ev1+ev2
1961           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1962           el2=fac4*fac
1963           eesij=el1+el2
1964 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1965 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1966           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1967           ees=ees+eesij
1968           evdw1=evdw1+evdwij
1969 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1970 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1971 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1972 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1973 C
1974 C Calculate contributions to the Cartesian gradient.
1975 C
1976 #ifdef SPLITELE
1977           facvdw=-6*rrmij*(ev1+evdwij)
1978           facel=-3*rrmij*(el1+eesij)
1979           fac1=fac
1980           erij(1)=xj*rmij
1981           erij(2)=yj*rmij
1982           erij(3)=zj*rmij
1983           if (calc_grad) then
1984 *
1985 * Radial derivatives. First process both termini of the fragment (i,j)
1986 *
1987           ggg(1)=facel*xj
1988           ggg(2)=facel*yj
1989           ggg(3)=facel*zj
1990           do k=1,3
1991             ghalf=0.5D0*ggg(k)
1992             gelc(k,i)=gelc(k,i)+ghalf
1993             gelc(k,j)=gelc(k,j)+ghalf
1994           enddo
1995 *
1996 * Loop over residues i+1 thru j-1.
1997 *
1998           do k=i+1,j-1
1999             do l=1,3
2000               gelc(l,k)=gelc(l,k)+ggg(l)
2001             enddo
2002           enddo
2003           ggg(1)=facvdw*xj
2004           ggg(2)=facvdw*yj
2005           ggg(3)=facvdw*zj
2006           do k=1,3
2007             ghalf=0.5D0*ggg(k)
2008             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2009             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2010           enddo
2011 *
2012 * Loop over residues i+1 thru j-1.
2013 *
2014           do k=i+1,j-1
2015             do l=1,3
2016               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2017             enddo
2018           enddo
2019 #else
2020           facvdw=ev1+evdwij
2021           facel=el1+eesij
2022           fac1=fac
2023           fac=-3*rrmij*(facvdw+facvdw+facel)
2024           erij(1)=xj*rmij
2025           erij(2)=yj*rmij
2026           erij(3)=zj*rmij
2027           if (calc_grad) then
2028 *
2029 * Radial derivatives. First process both termini of the fragment (i,j)
2030 *
2031           ggg(1)=fac*xj
2032           ggg(2)=fac*yj
2033           ggg(3)=fac*zj
2034           do k=1,3
2035             ghalf=0.5D0*ggg(k)
2036             gelc(k,i)=gelc(k,i)+ghalf
2037             gelc(k,j)=gelc(k,j)+ghalf
2038           enddo
2039 *
2040 * Loop over residues i+1 thru j-1.
2041 *
2042           do k=i+1,j-1
2043             do l=1,3
2044               gelc(l,k)=gelc(l,k)+ggg(l)
2045             enddo
2046           enddo
2047 #endif
2048 *
2049 * Angular part
2050 *
2051           ecosa=2.0D0*fac3*fac1+fac4
2052           fac4=-3.0D0*fac4
2053           fac3=-6.0D0*fac3
2054           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2055           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2056           do k=1,3
2057             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2058             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2059           enddo
2060 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2061 cd   &          (dcosg(k),k=1,3)
2062           do k=1,3
2063             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2064           enddo
2065           do k=1,3
2066             ghalf=0.5D0*ggg(k)
2067             gelc(k,i)=gelc(k,i)+ghalf
2068      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2069      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2070             gelc(k,j)=gelc(k,j)+ghalf
2071      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2072      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2073           enddo
2074           do k=i+1,j-1
2075             do l=1,3
2076               gelc(l,k)=gelc(l,k)+ggg(l)
2077             enddo
2078           enddo
2079           endif
2080
2081           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2082      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2083      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2084 C
2085 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2086 C   energy of a peptide unit is assumed in the form of a second-order
2087 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2088 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2089 C   are computed for EVERY pair of non-contiguous peptide groups.
2090 C
2091           if (j.lt.nres-1) then
2092             j1=j+1
2093             j2=j-1
2094           else
2095             j1=j-1
2096             j2=j-2
2097           endif
2098           kkk=0
2099           do k=1,2
2100             do l=1,2
2101               kkk=kkk+1
2102               muij(kkk)=mu(k,i)*mu(l,j)
2103             enddo
2104           enddo
2105 cd         write (iout,*) 'EELEC: i',i,' j',j
2106 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2107 cd          write(iout,*) 'muij',muij
2108           ury=scalar(uy(1,i),erij)
2109           urz=scalar(uz(1,i),erij)
2110           vry=scalar(uy(1,j),erij)
2111           vrz=scalar(uz(1,j),erij)
2112           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2113           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2114           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2115           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2116 C For diagnostics only
2117 cd          a22=1.0d0
2118 cd          a23=1.0d0
2119 cd          a32=1.0d0
2120 cd          a33=1.0d0
2121           fac=dsqrt(-ael6i)*r3ij
2122 cd          write (2,*) 'fac=',fac
2123 C For diagnostics only
2124 cd          fac=1.0d0
2125           a22=a22*fac
2126           a23=a23*fac
2127           a32=a32*fac
2128           a33=a33*fac
2129 cd          write (iout,'(4i5,4f10.5)')
2130 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2131 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2132 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2133 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2134 cd          write (iout,'(4f10.5)')
2135 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2136 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2137 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2138 cd           write (iout,'(2i3,9f10.5/)') i,j,
2139 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2140           if (calc_grad) then
2141 C Derivatives of the elements of A in virtual-bond vectors
2142           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2143 cd          do k=1,3
2144 cd            do l=1,3
2145 cd              erder(k,l)=0.0d0
2146 cd            enddo
2147 cd          enddo
2148           do k=1,3
2149             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2150             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2151             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2152             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2153             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2154             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2155             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2156             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2157             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2158             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2159             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2160             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2161           enddo
2162 cd          do k=1,3
2163 cd            do l=1,3
2164 cd              uryg(k,l)=0.0d0
2165 cd              urzg(k,l)=0.0d0
2166 cd              vryg(k,l)=0.0d0
2167 cd              vrzg(k,l)=0.0d0
2168 cd            enddo
2169 cd          enddo
2170 C Compute radial contributions to the gradient
2171           facr=-3.0d0*rrmij
2172           a22der=a22*facr
2173           a23der=a23*facr
2174           a32der=a32*facr
2175           a33der=a33*facr
2176 cd          a22der=0.0d0
2177 cd          a23der=0.0d0
2178 cd          a32der=0.0d0
2179 cd          a33der=0.0d0
2180           agg(1,1)=a22der*xj
2181           agg(2,1)=a22der*yj
2182           agg(3,1)=a22der*zj
2183           agg(1,2)=a23der*xj
2184           agg(2,2)=a23der*yj
2185           agg(3,2)=a23der*zj
2186           agg(1,3)=a32der*xj
2187           agg(2,3)=a32der*yj
2188           agg(3,3)=a32der*zj
2189           agg(1,4)=a33der*xj
2190           agg(2,4)=a33der*yj
2191           agg(3,4)=a33der*zj
2192 C Add the contributions coming from er
2193           fac3=-3.0d0*fac
2194           do k=1,3
2195             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2196             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2197             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2198             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2199           enddo
2200           do k=1,3
2201 C Derivatives in DC(i)
2202             ghalf1=0.5d0*agg(k,1)
2203             ghalf2=0.5d0*agg(k,2)
2204             ghalf3=0.5d0*agg(k,3)
2205             ghalf4=0.5d0*agg(k,4)
2206             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2207      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2208             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2209      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2210             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2211      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2212             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2213      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2214 C Derivatives in DC(i+1)
2215             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2216      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2217             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2218      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2219             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2220      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2221             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2222      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2223 C Derivatives in DC(j)
2224             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2226             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2227      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2228             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2230             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2231      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2232 C Derivatives in DC(j+1) or DC(nres-1)
2233             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vryg(k,3)*ury)
2235             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2236      &      -3.0d0*vrzg(k,3)*ury)
2237             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vryg(k,3)*urz)
2239             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2240      &      -3.0d0*vrzg(k,3)*urz)
2241 cd            aggi(k,1)=ghalf1
2242 cd            aggi(k,2)=ghalf2
2243 cd            aggi(k,3)=ghalf3
2244 cd            aggi(k,4)=ghalf4
2245 C Derivatives in DC(i+1)
2246 cd            aggi1(k,1)=agg(k,1)
2247 cd            aggi1(k,2)=agg(k,2)
2248 cd            aggi1(k,3)=agg(k,3)
2249 cd            aggi1(k,4)=agg(k,4)
2250 C Derivatives in DC(j)
2251 cd            aggj(k,1)=ghalf1
2252 cd            aggj(k,2)=ghalf2
2253 cd            aggj(k,3)=ghalf3
2254 cd            aggj(k,4)=ghalf4
2255 C Derivatives in DC(j+1)
2256 cd            aggj1(k,1)=0.0d0
2257 cd            aggj1(k,2)=0.0d0
2258 cd            aggj1(k,3)=0.0d0
2259 cd            aggj1(k,4)=0.0d0
2260             if (j.eq.nres-1 .and. i.lt.j-2) then
2261               do l=1,4
2262                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2263 cd                aggj1(k,l)=agg(k,l)
2264               enddo
2265             endif
2266           enddo
2267           endif
2268 c          goto 11111
2269 C Check the loc-el terms by numerical integration
2270           acipa(1,1)=a22
2271           acipa(1,2)=a23
2272           acipa(2,1)=a32
2273           acipa(2,2)=a33
2274           a22=-a22
2275           a23=-a23
2276           do l=1,2
2277             do k=1,3
2278               agg(k,l)=-agg(k,l)
2279               aggi(k,l)=-aggi(k,l)
2280               aggi1(k,l)=-aggi1(k,l)
2281               aggj(k,l)=-aggj(k,l)
2282               aggj1(k,l)=-aggj1(k,l)
2283             enddo
2284           enddo
2285           if (j.lt.nres-1) then
2286             a22=-a22
2287             a32=-a32
2288             do l=1,3,2
2289               do k=1,3
2290                 agg(k,l)=-agg(k,l)
2291                 aggi(k,l)=-aggi(k,l)
2292                 aggi1(k,l)=-aggi1(k,l)
2293                 aggj(k,l)=-aggj(k,l)
2294                 aggj1(k,l)=-aggj1(k,l)
2295               enddo
2296             enddo
2297           else
2298             a22=-a22
2299             a23=-a23
2300             a32=-a32
2301             a33=-a33
2302             do l=1,4
2303               do k=1,3
2304                 agg(k,l)=-agg(k,l)
2305                 aggi(k,l)=-aggi(k,l)
2306                 aggi1(k,l)=-aggi1(k,l)
2307                 aggj(k,l)=-aggj(k,l)
2308                 aggj1(k,l)=-aggj1(k,l)
2309               enddo
2310             enddo
2311           endif
2312           ENDIF ! WCORR
2313 11111     continue
2314           IF (wel_loc.gt.0.0d0) THEN
2315 C Contribution to the local-electrostatic energy coming from the i-j pair
2316           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2317      &     +a33*muij(4)
2318 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2319 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2320           eel_loc=eel_loc+eel_loc_ij
2321 C Partial derivatives in virtual-bond dihedral angles gamma
2322           if (calc_grad) then
2323           if (i.gt.1)
2324      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2325      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2326      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2327           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2328      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2329      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2330 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2331 cd          write(iout,*) 'agg  ',agg
2332 cd          write(iout,*) 'aggi ',aggi
2333 cd          write(iout,*) 'aggi1',aggi1
2334 cd          write(iout,*) 'aggj ',aggj
2335 cd          write(iout,*) 'aggj1',aggj1
2336
2337 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2338           do l=1,3
2339             ggg(l)=agg(l,1)*muij(1)+
2340      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2341           enddo
2342           do k=i+2,j2
2343             do l=1,3
2344               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2345             enddo
2346           enddo
2347 C Remaining derivatives of eello
2348           do l=1,3
2349             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2350      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2351             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2352      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2353             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2354      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2355             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2356      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2357           enddo
2358           endif
2359           ENDIF
2360           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2361 C Contributions from turns
2362             a_temp(1,1)=a22
2363             a_temp(1,2)=a23
2364             a_temp(2,1)=a32
2365             a_temp(2,2)=a33
2366             call eturn34(i,j,eello_turn3,eello_turn4)
2367           endif
2368 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2369           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2370 C
2371 C Calculate the contact function. The ith column of the array JCONT will
2372 C contain the numbers of atoms that make contacts with the atom I (of numbers
2373 C greater than I). The arrays FACONT and GACONT will contain the values of
2374 C the contact function and its derivative.
2375 c           r0ij=1.02D0*rpp(iteli,itelj)
2376 c           r0ij=1.11D0*rpp(iteli,itelj)
2377             r0ij=2.20D0*rpp(iteli,itelj)
2378 c           r0ij=1.55D0*rpp(iteli,itelj)
2379             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2380             if (fcont.gt.0.0D0) then
2381               num_conti=num_conti+1
2382               if (num_conti.gt.maxconts) then
2383                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2384      &                         ' will skip next contacts for this conf.'
2385               else
2386                 jcont_hb(num_conti,i)=j
2387                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2388      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2389 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2390 C  terms.
2391                 d_cont(num_conti,i)=rij
2392 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2393 C     --- Electrostatic-interaction matrix ---
2394                 a_chuj(1,1,num_conti,i)=a22
2395                 a_chuj(1,2,num_conti,i)=a23
2396                 a_chuj(2,1,num_conti,i)=a32
2397                 a_chuj(2,2,num_conti,i)=a33
2398 C     --- Gradient of rij
2399                 do kkk=1,3
2400                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2401                 enddo
2402 c             if (i.eq.1) then
2403 c                a_chuj(1,1,num_conti,i)=-0.61d0
2404 c                a_chuj(1,2,num_conti,i)= 0.4d0
2405 c                a_chuj(2,1,num_conti,i)= 0.65d0
2406 c                a_chuj(2,2,num_conti,i)= 0.50d0
2407 c             else if (i.eq.2) then
2408 c                a_chuj(1,1,num_conti,i)= 0.0d0
2409 c                a_chuj(1,2,num_conti,i)= 0.0d0
2410 c                a_chuj(2,1,num_conti,i)= 0.0d0
2411 c                a_chuj(2,2,num_conti,i)= 0.0d0
2412 c             endif
2413 C     --- and its gradients
2414 cd                write (iout,*) 'i',i,' j',j
2415 cd                do kkk=1,3
2416 cd                write (iout,*) 'iii 1 kkk',kkk
2417 cd                write (iout,*) agg(kkk,:)
2418 cd                enddo
2419 cd                do kkk=1,3
2420 cd                write (iout,*) 'iii 2 kkk',kkk
2421 cd                write (iout,*) aggi(kkk,:)
2422 cd                enddo
2423 cd                do kkk=1,3
2424 cd                write (iout,*) 'iii 3 kkk',kkk
2425 cd                write (iout,*) aggi1(kkk,:)
2426 cd                enddo
2427 cd                do kkk=1,3
2428 cd                write (iout,*) 'iii 4 kkk',kkk
2429 cd                write (iout,*) aggj(kkk,:)
2430 cd                enddo
2431 cd                do kkk=1,3
2432 cd                write (iout,*) 'iii 5 kkk',kkk
2433 cd                write (iout,*) aggj1(kkk,:)
2434 cd                enddo
2435                 kkll=0
2436                 do k=1,2
2437                   do l=1,2
2438                     kkll=kkll+1
2439                     do m=1,3
2440                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2441                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2442                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2443                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2444                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2445 c                      do mm=1,5
2446 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2447 c                      enddo
2448                     enddo
2449                   enddo
2450                 enddo
2451                 ENDIF
2452                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2453 C Calculate contact energies
2454                 cosa4=4.0D0*cosa
2455                 wij=cosa-3.0D0*cosb*cosg
2456                 cosbg1=cosb+cosg
2457                 cosbg2=cosb-cosg
2458 c               fac3=dsqrt(-ael6i)/r0ij**3
2459                 fac3=dsqrt(-ael6i)*r3ij
2460                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2461                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2462 c               ees0mij=0.0D0
2463                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2464                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2465 C Diagnostics. Comment out or remove after debugging!
2466 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2467 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2468 c               ees0m(num_conti,i)=0.0D0
2469 C End diagnostics.
2470 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2471 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2472                 facont_hb(num_conti,i)=fcont
2473                 if (calc_grad) then
2474 C Angular derivatives of the contact function
2475                 ees0pij1=fac3/ees0pij
2476                 ees0mij1=fac3/ees0mij
2477                 fac3p=-3.0D0*fac3*rrmij
2478                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2479                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2480 c               ees0mij1=0.0D0
2481                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2482                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2483                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2484                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2485                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2486                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2487                 ecosap=ecosa1+ecosa2
2488                 ecosbp=ecosb1+ecosb2
2489                 ecosgp=ecosg1+ecosg2
2490                 ecosam=ecosa1-ecosa2
2491                 ecosbm=ecosb1-ecosb2
2492                 ecosgm=ecosg1-ecosg2
2493 C Diagnostics
2494 c               ecosap=ecosa1
2495 c               ecosbp=ecosb1
2496 c               ecosgp=ecosg1
2497 c               ecosam=0.0D0
2498 c               ecosbm=0.0D0
2499 c               ecosgm=0.0D0
2500 C End diagnostics
2501                 fprimcont=fprimcont/rij
2502 cd              facont_hb(num_conti,i)=1.0D0
2503 C Following line is for diagnostics.
2504 cd              fprimcont=0.0D0
2505                 do k=1,3
2506                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2507                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2508                 enddo
2509                 do k=1,3
2510                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2511                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2512                 enddo
2513                 gggp(1)=gggp(1)+ees0pijp*xj
2514                 gggp(2)=gggp(2)+ees0pijp*yj
2515                 gggp(3)=gggp(3)+ees0pijp*zj
2516                 gggm(1)=gggm(1)+ees0mijp*xj
2517                 gggm(2)=gggm(2)+ees0mijp*yj
2518                 gggm(3)=gggm(3)+ees0mijp*zj
2519 C Derivatives due to the contact function
2520                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2521                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2522                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2523                 do k=1,3
2524                   ghalfp=0.5D0*gggp(k)
2525                   ghalfm=0.5D0*gggm(k)
2526                   gacontp_hb1(k,num_conti,i)=ghalfp
2527      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2528      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2529                   gacontp_hb2(k,num_conti,i)=ghalfp
2530      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2531      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2532                   gacontp_hb3(k,num_conti,i)=gggp(k)
2533                   gacontm_hb1(k,num_conti,i)=ghalfm
2534      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2535      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2536                   gacontm_hb2(k,num_conti,i)=ghalfm
2537      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2538      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2539                   gacontm_hb3(k,num_conti,i)=gggm(k)
2540                 enddo
2541                 endif
2542 C Diagnostics. Comment out or remove after debugging!
2543 cdiag           do k=1,3
2544 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2545 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2546 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2548 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2549 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2550 cdiag           enddo
2551               ENDIF ! wcorr
2552               endif  ! num_conti.le.maxconts
2553             endif  ! fcont.gt.0
2554           endif    ! j.gt.i+1
2555  1216     continue
2556         enddo ! j
2557         num_cont_hb(i)=num_conti
2558  1215   continue
2559       enddo   ! i
2560 cd      do i=1,nres
2561 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2562 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2563 cd      enddo
2564 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2565 ccc      eel_loc=eel_loc+eello_turn3
2566       return
2567       end
2568 C-----------------------------------------------------------------------------
2569       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2570 C Third- and fourth-order contributions from turns
2571       implicit real*8 (a-h,o-z)
2572       include 'DIMENSIONS'
2573       include 'DIMENSIONS.ZSCOPT'
2574       include 'COMMON.IOUNITS'
2575       include 'COMMON.GEO'
2576       include 'COMMON.VAR'
2577       include 'COMMON.LOCAL'
2578       include 'COMMON.CHAIN'
2579       include 'COMMON.DERIV'
2580       include 'COMMON.INTERACT'
2581       include 'COMMON.CONTACTS'
2582       include 'COMMON.TORSION'
2583       include 'COMMON.VECTORS'
2584       include 'COMMON.FFIELD'
2585       dimension ggg(3)
2586       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2587      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2588      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2589       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2590      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2591       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2592       if (j.eq.i+2) then
2593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2594 C
2595 C               Third-order contributions
2596 C
2597 C                 (i+2)o----(i+3)
2598 C                      | |
2599 C                      | |
2600 C                 (i+1)o----i
2601 C
2602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2603 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2604         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2605         call transpose2(auxmat(1,1),auxmat1(1,1))
2606         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2607         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2608 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2609 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2610 cd     &    ' eello_turn3_num',4*eello_turn3_num
2611         if (calc_grad) then
2612 C Derivatives in gamma(i)
2613         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2614         call transpose2(auxmat2(1,1),pizda(1,1))
2615         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2616         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2617 C Derivatives in gamma(i+1)
2618         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2619         call transpose2(auxmat2(1,1),pizda(1,1))
2620         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2621         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2622      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2623 C Cartesian derivatives
2624         do l=1,3
2625           a_temp(1,1)=aggi(l,1)
2626           a_temp(1,2)=aggi(l,2)
2627           a_temp(2,1)=aggi(l,3)
2628           a_temp(2,2)=aggi(l,4)
2629           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2630           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2631      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2632           a_temp(1,1)=aggi1(l,1)
2633           a_temp(1,2)=aggi1(l,2)
2634           a_temp(2,1)=aggi1(l,3)
2635           a_temp(2,2)=aggi1(l,4)
2636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2637           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2639           a_temp(1,1)=aggj(l,1)
2640           a_temp(1,2)=aggj(l,2)
2641           a_temp(2,1)=aggj(l,3)
2642           a_temp(2,2)=aggj(l,4)
2643           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2644           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2645      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2646           a_temp(1,1)=aggj1(l,1)
2647           a_temp(1,2)=aggj1(l,2)
2648           a_temp(2,1)=aggj1(l,3)
2649           a_temp(2,2)=aggj1(l,4)
2650           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2651           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2652      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2653         enddo
2654         endif
2655       else if (j.eq.i+3) then
2656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2657 C
2658 C               Fourth-order contributions
2659 C
2660 C                 (i+3)o----(i+4)
2661 C                     /  |
2662 C               (i+2)o   |
2663 C                     \  |
2664 C                 (i+1)o----i
2665 C
2666 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2667 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2668         iti1=itortyp(itype(i+1))
2669         iti2=itortyp(itype(i+2))
2670         iti3=itortyp(itype(i+3))
2671         call transpose2(EUg(1,1,i+1),e1t(1,1))
2672         call transpose2(Eug(1,1,i+2),e2t(1,1))
2673         call transpose2(Eug(1,1,i+3),e3t(1,1))
2674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2676         s1=scalar2(b1(1,iti2),auxvec(1))
2677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2679         s2=scalar2(b1(1,iti1),auxvec(1))
2680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2683         eello_turn4=eello_turn4-(s1+s2+s3)
2684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2685 cd     &    ' eello_turn4_num',8*eello_turn4_num
2686 C Derivatives in gamma(i)
2687         if (calc_grad) then
2688         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2689         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2690         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2691         s1=scalar2(b1(1,iti2),auxvec(1))
2692         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2693         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2694         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2695 C Derivatives in gamma(i+1)
2696         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2697         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2698         s2=scalar2(b1(1,iti1),auxvec(1))
2699         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2700         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2702         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2703 C Derivatives in gamma(i+2)
2704         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2705         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2706         s1=scalar2(b1(1,iti2),auxvec(1))
2707         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2708         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2709         s2=scalar2(b1(1,iti1),auxvec(1))
2710         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2711         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2712         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2713         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2714 C Cartesian derivatives
2715 C Derivatives of this turn contributions in DC(i+2)
2716         if (j.lt.nres-1) then
2717           do l=1,3
2718             a_temp(1,1)=agg(l,1)
2719             a_temp(1,2)=agg(l,2)
2720             a_temp(2,1)=agg(l,3)
2721             a_temp(2,2)=agg(l,4)
2722             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2723             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2724             s1=scalar2(b1(1,iti2),auxvec(1))
2725             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2726             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2727             s2=scalar2(b1(1,iti1),auxvec(1))
2728             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2729             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2730             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2731             ggg(l)=-(s1+s2+s3)
2732             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2733           enddo
2734         endif
2735 C Remaining derivatives of this turn contribution
2736         do l=1,3
2737           a_temp(1,1)=aggi(l,1)
2738           a_temp(1,2)=aggi(l,2)
2739           a_temp(2,1)=aggi(l,3)
2740           a_temp(2,2)=aggi(l,4)
2741           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2742           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2743           s1=scalar2(b1(1,iti2),auxvec(1))
2744           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2745           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2746           s2=scalar2(b1(1,iti1),auxvec(1))
2747           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2748           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2749           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2750           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2751           a_temp(1,1)=aggi1(l,1)
2752           a_temp(1,2)=aggi1(l,2)
2753           a_temp(2,1)=aggi1(l,3)
2754           a_temp(2,2)=aggi1(l,4)
2755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2757           s1=scalar2(b1(1,iti2),auxvec(1))
2758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2760           s2=scalar2(b1(1,iti1),auxvec(1))
2761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2765           a_temp(1,1)=aggj(l,1)
2766           a_temp(1,2)=aggj(l,2)
2767           a_temp(2,1)=aggj(l,3)
2768           a_temp(2,2)=aggj(l,4)
2769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2771           s1=scalar2(b1(1,iti2),auxvec(1))
2772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2774           s2=scalar2(b1(1,iti1),auxvec(1))
2775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2778           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2779           a_temp(1,1)=aggj1(l,1)
2780           a_temp(1,2)=aggj1(l,2)
2781           a_temp(2,1)=aggj1(l,3)
2782           a_temp(2,2)=aggj1(l,4)
2783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2785           s1=scalar2(b1(1,iti2),auxvec(1))
2786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2788           s2=scalar2(b1(1,iti1),auxvec(1))
2789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2792           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2793         enddo
2794         endif
2795       endif
2796       return
2797       end
2798 C-----------------------------------------------------------------------------
2799       subroutine vecpr(u,v,w)
2800       implicit real*8(a-h,o-z)
2801       dimension u(3),v(3),w(3)
2802       w(1)=u(2)*v(3)-u(3)*v(2)
2803       w(2)=-u(1)*v(3)+u(3)*v(1)
2804       w(3)=u(1)*v(2)-u(2)*v(1)
2805       return
2806       end
2807 C-----------------------------------------------------------------------------
2808       subroutine unormderiv(u,ugrad,unorm,ungrad)
2809 C This subroutine computes the derivatives of a normalized vector u, given
2810 C the derivatives computed without normalization conditions, ugrad. Returns
2811 C ungrad.
2812       implicit none
2813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2814       double precision vec(3)
2815       double precision scalar
2816       integer i,j
2817 c      write (2,*) 'ugrad',ugrad
2818 c      write (2,*) 'u',u
2819       do i=1,3
2820         vec(i)=scalar(ugrad(1,i),u(1))
2821       enddo
2822 c      write (2,*) 'vec',vec
2823       do i=1,3
2824         do j=1,3
2825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2826         enddo
2827       enddo
2828 c      write (2,*) 'ungrad',ungrad
2829       return
2830       end
2831 C-----------------------------------------------------------------------------
2832       subroutine escp(evdw2,evdw2_14)
2833 C
2834 C This subroutine calculates the excluded-volume interaction energy between
2835 C peptide-group centers and side chains and its gradient in virtual-bond and
2836 C side-chain vectors.
2837 C
2838       implicit real*8 (a-h,o-z)
2839       include 'DIMENSIONS'
2840       include 'DIMENSIONS.ZSCOPT'
2841       include 'COMMON.GEO'
2842       include 'COMMON.VAR'
2843       include 'COMMON.LOCAL'
2844       include 'COMMON.CHAIN'
2845       include 'COMMON.DERIV'
2846       include 'COMMON.INTERACT'
2847       include 'COMMON.FFIELD'
2848       include 'COMMON.IOUNITS'
2849       dimension ggg(3)
2850       evdw2=0.0D0
2851       evdw2_14=0.0d0
2852 cd    print '(a)','Enter ESCP'
2853 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2854 c     &  ' scal14',scal14
2855       do i=iatscp_s,iatscp_e
2856         iteli=itel(i)
2857 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2858 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2859         if (iteli.eq.0) goto 1225
2860         xi=0.5D0*(c(1,i)+c(1,i+1))
2861         yi=0.5D0*(c(2,i)+c(2,i+1))
2862         zi=0.5D0*(c(3,i)+c(3,i+1))
2863
2864         do iint=1,nscp_gr(i)
2865
2866         do j=iscpstart(i,iint),iscpend(i,iint)
2867           itypj=itype(j)
2868 C Uncomment following three lines for SC-p interactions
2869 c         xj=c(1,nres+j)-xi
2870 c         yj=c(2,nres+j)-yi
2871 c         zj=c(3,nres+j)-zi
2872 C Uncomment following three lines for Ca-p interactions
2873           xj=c(1,j)-xi
2874           yj=c(2,j)-yi
2875           zj=c(3,j)-zi
2876           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2877           fac=rrij**expon2
2878           e1=fac*fac*aad(itypj,iteli)
2879           e2=fac*bad(itypj,iteli)
2880           if (iabs(j-i) .le. 2) then
2881             e1=scal14*e1
2882             e2=scal14*e2
2883             evdw2_14=evdw2_14+e1+e2
2884           endif
2885           evdwij=e1+e2
2886 c          write (iout,*) i,j,evdwij
2887           evdw2=evdw2+evdwij
2888           if (calc_grad) then
2889 C
2890 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2891 C
2892           fac=-(evdwij+e1)*rrij
2893           ggg(1)=xj*fac
2894           ggg(2)=yj*fac
2895           ggg(3)=zj*fac
2896           if (j.lt.i) then
2897 cd          write (iout,*) 'j<i'
2898 C Uncomment following three lines for SC-p interactions
2899 c           do k=1,3
2900 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2901 c           enddo
2902           else
2903 cd          write (iout,*) 'j>i'
2904             do k=1,3
2905               ggg(k)=-ggg(k)
2906 C Uncomment following line for SC-p interactions
2907 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2908             enddo
2909           endif
2910           do k=1,3
2911             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2912           enddo
2913           kstart=min0(i+1,j)
2914           kend=max0(i-1,j-1)
2915 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2916 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2917           do k=kstart,kend
2918             do l=1,3
2919               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2920             enddo
2921           enddo
2922           endif
2923         enddo
2924         enddo ! iint
2925  1225   continue
2926       enddo ! i
2927       do i=1,nct
2928         do j=1,3
2929           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2930           gradx_scp(j,i)=expon*gradx_scp(j,i)
2931         enddo
2932       enddo
2933 C******************************************************************************
2934 C
2935 C                              N O T E !!!
2936 C
2937 C To save time the factor EXPON has been extracted from ALL components
2938 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2939 C use!
2940 C
2941 C******************************************************************************
2942       return
2943       end
2944 C--------------------------------------------------------------------------
2945       subroutine edis(ehpb)
2946 C
2947 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2948 C
2949       implicit real*8 (a-h,o-z)
2950       include 'DIMENSIONS'
2951       include 'DIMENSIONS.FREE'
2952       include 'COMMON.SBRIDGE'
2953       include 'COMMON.CHAIN'
2954       include 'COMMON.DERIV'
2955       include 'COMMON.VAR'
2956       include 'COMMON.INTERACT'
2957       include 'COMMON.CONTROL'
2958       include 'COMMON.IOUNITS'
2959       dimension ggg(3)
2960       ehpb=0.0D0
2961       do i=1,3
2962        ggg(i)=0.0d0
2963       enddo
2964 C      write (iout,*) ,"link_end",link_end,constr_dist
2965 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2966 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
2967 c     &  " constr_dist",constr_dist
2968       if (link_end.eq.0) return
2969       do i=link_start,link_end
2970 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2971 C CA-CA distance used in regularization of structure.
2972         ii=ihpb(i)
2973         jj=jhpb(i)
2974 C iii and jjj point to the residues for which the distance is assigned.
2975         if (ii.gt.nres) then
2976           iii=ii-nres
2977           jjj=jj-nres
2978         else
2979           iii=ii
2980           jjj=jj
2981         endif
2982 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2983 c     &    dhpb(i),dhpb1(i),forcon(i)
2984 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2985 C    distance and angle dependent SS bond potential.
2986 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
2987 C     & iabs(itype(jjj)).eq.1) then
2988 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2989 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
2990         if (.not.dyn_ss .and. i.le.nss) then
2991 C 15/02/13 CC dynamic SSbond - additional check
2992           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
2993      &        iabs(itype(jjj)).eq.1) then
2994            call ssbond_ene(iii,jjj,eij)
2995            ehpb=ehpb+2*eij
2996          endif
2997 cd          write (iout,*) "eij",eij
2998 cd   &   ' waga=',waga,' fac=',fac
2999 !        else if (ii.gt.nres .and. jj.gt.nres) then
3000         else
3001 C Calculate the distance between the two points and its difference from the
3002 C target distance.
3003           dd=dist(ii,jj)
3004           if (irestr_type(i).eq.11) then
3005             ehpb=ehpb+fordepth(i)!**4.0d0
3006      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3007             fac=fordepth(i)!**4.0d0
3008      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3009 c            if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
3010 c     &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3011 c     &        ehpb,irestr_type(i)
3012           else if (irestr_type(i).eq.10) then
3013 c AL 6//19/2018 cross-link restraints
3014             xdis = 0.5d0*(dd/forcon(i))**2
3015             expdis = dexp(-xdis)
3016 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
3017             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
3018 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
3019 c     &          " wboltzd",wboltzd
3020             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
3021 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
3022             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
3023      &           *expdis/(aux*forcon(i)**2)
3024 c            if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
3025 c     &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3026 c     &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
3027           else if (irestr_type(i).eq.2) then
3028 c Quartic restraints
3029             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3030 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3031 c     &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3032 c     &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
3033             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3034           else
3035 c Quadratic restraints
3036             rdis=dd-dhpb(i)
3037 C Get the force constant corresponding to this distance.
3038             waga=forcon(i)
3039 C Calculate the contribution to energy.
3040             ehpb=ehpb+0.5d0*waga*rdis*rdis
3041 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3042 c     &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3043 c     &       0.5d0*waga*rdis*rdis,irestr_type(i)
3044 C
3045 C Evaluate gradient.
3046 C
3047             fac=waga*rdis/dd
3048           endif
3049 c Calculate Cartesian gradient
3050           do j=1,3
3051             ggg(j)=fac*(c(j,jj)-c(j,ii))
3052           enddo
3053 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3054 C If this is a SC-SC distance, we need to calculate the contributions to the
3055 C Cartesian gradient in the SC vectors (ghpbx).
3056           if (iii.lt.ii) then
3057             do j=1,3
3058               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3059               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3060             enddo
3061           endif
3062           do k=1,3
3063             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3064             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3065           enddo
3066         endif
3067       enddo
3068       return
3069       end
3070 C--------------------------------------------------------------------------
3071       subroutine ssbond_ene(i,j,eij)
3072 C
3073 C Calculate the distance and angle dependent SS-bond potential energy
3074 C using a free-energy function derived based on RHF/6-31G** ab initio
3075 C calculations of diethyl disulfide.
3076 C
3077 C A. Liwo and U. Kozlowska, 11/24/03
3078 C
3079       implicit real*8 (a-h,o-z)
3080       include 'DIMENSIONS'
3081       include 'DIMENSIONS.ZSCOPT'
3082       include 'COMMON.SBRIDGE'
3083       include 'COMMON.CHAIN'
3084       include 'COMMON.DERIV'
3085       include 'COMMON.LOCAL'
3086       include 'COMMON.INTERACT'
3087       include 'COMMON.VAR'
3088       include 'COMMON.IOUNITS'
3089       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3090       itypi=itype(i)
3091       xi=c(1,nres+i)
3092       yi=c(2,nres+i)
3093       zi=c(3,nres+i)
3094       dxi=dc_norm(1,nres+i)
3095       dyi=dc_norm(2,nres+i)
3096       dzi=dc_norm(3,nres+i)
3097       dsci_inv=dsc_inv(itypi)
3098       itypj=itype(j)
3099       dscj_inv=dsc_inv(itypj)
3100       xj=c(1,nres+j)-xi
3101       yj=c(2,nres+j)-yi
3102       zj=c(3,nres+j)-zi
3103       dxj=dc_norm(1,nres+j)
3104       dyj=dc_norm(2,nres+j)
3105       dzj=dc_norm(3,nres+j)
3106       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3107       rij=dsqrt(rrij)
3108       erij(1)=xj*rij
3109       erij(2)=yj*rij
3110       erij(3)=zj*rij
3111       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3112       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3113       om12=dxi*dxj+dyi*dyj+dzi*dzj
3114       do k=1,3
3115         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3116         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3117       enddo
3118       rij=1.0d0/rij
3119       deltad=rij-d0cm
3120       deltat1=1.0d0-om1
3121       deltat2=1.0d0+om2
3122       deltat12=om2-om1+2.0d0
3123       cosphi=om12-om1*om2
3124       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3125      &  +akct*deltad*deltat12+ebr
3126 c     &  +akct*deltad*deltat12
3127      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3128       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3129      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3130      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3131       ed=2*akcm*deltad+akct*deltat12
3132       pom1=akct*deltad
3133       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3134       eom1=-2*akth*deltat1-pom1-om2*pom2
3135       eom2= 2*akth*deltat2+pom1-om1*pom2
3136       eom12=pom2
3137       do k=1,3
3138         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3139       enddo
3140       do k=1,3
3141         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3142      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3143         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3144      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3145       enddo
3146 C
3147 C Calculate the components of the gradient in DC and X
3148 C
3149       do k=i,j-1
3150         do l=1,3
3151           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3152         enddo
3153       enddo
3154       return
3155       end
3156 C--------------------------------------------------------------------------
3157 c MODELLER restraint function
3158       subroutine e_modeller(ehomology_constr)
3159       implicit real*8 (a-h,o-z)
3160       include 'DIMENSIONS'
3161       include 'DIMENSIONS.ZSCOPT'
3162       include 'DIMENSIONS.FREE'
3163       integer nnn, i, j, k, ki, irec, l
3164       integer katy, odleglosci, test7
3165       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3166       real*8 distance(max_template),distancek(max_template),
3167      &    min_odl,godl(max_template),dih_diff(max_template)
3168
3169 c
3170 c     FP - 30/10/2014 Temporary specifications for homology restraints
3171 c
3172       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3173      &                 sgtheta
3174       double precision, dimension (maxres) :: guscdiff,usc_diff
3175       double precision, dimension (max_template) ::
3176      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3177      &           theta_diff
3178
3179       include 'COMMON.SBRIDGE'
3180       include 'COMMON.CHAIN'
3181       include 'COMMON.GEO'
3182       include 'COMMON.DERIV'
3183       include 'COMMON.LOCAL'
3184       include 'COMMON.INTERACT'
3185       include 'COMMON.VAR'
3186       include 'COMMON.IOUNITS'
3187       include 'COMMON.CONTROL'
3188       include 'COMMON.HOMRESTR'
3189 c
3190       include 'COMMON.SETUP'
3191       include 'COMMON.NAMES'
3192
3193       do i=1,max_template
3194         distancek(i)=9999999.9
3195       enddo
3196
3197       odleg=0.0d0
3198
3199 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3200 c function)
3201 C AL 5/2/14 - Introduce list of restraints
3202 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3203 #ifdef DEBUG
3204       write(iout,*) "------- dist restrs start -------"
3205 #endif
3206       do ii = link_start_homo,link_end_homo
3207          i = ires_homo(ii)
3208          j = jres_homo(ii)
3209          dij=dist(i,j)
3210 c        write (iout,*) "dij(",i,j,") =",dij
3211          nexl=0
3212          do k=1,constr_homology
3213            if(.not.l_homo(k,ii)) then
3214               nexl=nexl+1
3215               cycle
3216            endif
3217            distance(k)=odl(k,ii)-dij
3218 c          write (iout,*) "distance(",k,") =",distance(k)
3219 c
3220 c          For Gaussian-type Urestr
3221 c
3222            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3223 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3224 c          write (iout,*) "distancek(",k,") =",distancek(k)
3225 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3226 c
3227 c          For Lorentzian-type Urestr
3228 c
3229            if (waga_dist.lt.0.0d0) then
3230               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3231               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3232      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3233            endif
3234          enddo
3235
3236 c         min_odl=minval(distancek)
3237          do kk=1,constr_homology
3238           if(l_homo(kk,ii)) then
3239             min_odl=distancek(kk)
3240             exit
3241           endif
3242          enddo
3243          do kk=1,constr_homology
3244           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3245      &              min_odl=distancek(kk)
3246          enddo
3247 c        write (iout,* )"min_odl",min_odl
3248 #ifdef DEBUG
3249          write (iout,*) "ij dij",i,j,dij
3250          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3251          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3252          write (iout,* )"min_odl",min_odl
3253 #endif
3254 #ifdef OLDRESTR
3255          odleg2=0.0d0
3256 #else
3257          if (waga_dist.ge.0.0d0) then
3258            odleg2=nexl
3259          else
3260            odleg2=0.0d0
3261          endif
3262 #endif
3263          do k=1,constr_homology
3264 c Nie wiem po co to liczycie jeszcze raz!
3265 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3266 c     &              (2*(sigma_odl(i,j,k))**2))
3267            if(.not.l_homo(k,ii)) cycle
3268            if (waga_dist.ge.0.0d0) then
3269 c
3270 c          For Gaussian-type Urestr
3271 c
3272             godl(k)=dexp(-distancek(k)+min_odl)
3273             odleg2=odleg2+godl(k)
3274 c
3275 c          For Lorentzian-type Urestr
3276 c
3277            else
3278             odleg2=odleg2+distancek(k)
3279            endif
3280
3281 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3282 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3283 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3284 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3285
3286          enddo
3287 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3288 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3289 #ifdef DEBUG
3290          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3291          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3292 #endif
3293            if (waga_dist.ge.0.0d0) then
3294 c
3295 c          For Gaussian-type Urestr
3296 c
3297               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3298 c
3299 c          For Lorentzian-type Urestr
3300 c
3301            else
3302               odleg=odleg+odleg2/constr_homology
3303            endif
3304 c
3305 #ifdef GRAD
3306 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3307 c Gradient
3308 c
3309 c          For Gaussian-type Urestr
3310 c
3311          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3312          sum_sgodl=0.0d0
3313          do k=1,constr_homology
3314 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3315 c     &           *waga_dist)+min_odl
3316 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3317 c
3318          if(.not.l_homo(k,ii)) cycle
3319          if (waga_dist.ge.0.0d0) then
3320 c          For Gaussian-type Urestr
3321 c
3322            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3323 c
3324 c          For Lorentzian-type Urestr
3325 c
3326          else
3327            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3328      &           sigma_odlir(k,ii)**2)**2)
3329          endif
3330            sum_sgodl=sum_sgodl+sgodl
3331
3332 c            sgodl2=sgodl2+sgodl
3333 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3334 c      write(iout,*) "constr_homology=",constr_homology
3335 c      write(iout,*) i, j, k, "TEST K"
3336          enddo
3337          if (waga_dist.ge.0.0d0) then
3338 c
3339 c          For Gaussian-type Urestr
3340 c
3341             grad_odl3=waga_homology(iset)*waga_dist
3342      &                *sum_sgodl/(sum_godl*dij)
3343 c
3344 c          For Lorentzian-type Urestr
3345 c
3346          else
3347 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3348 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3349             grad_odl3=-waga_homology(iset)*waga_dist*
3350      &                sum_sgodl/(constr_homology*dij)
3351          endif
3352 c
3353 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3354
3355
3356 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3357 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3358 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3359
3360 ccc      write(iout,*) godl, sgodl, grad_odl3
3361
3362 c          grad_odl=grad_odl+grad_odl3
3363
3364          do jik=1,3
3365             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3366 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3367 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3368 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3369             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3370             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3371 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3372 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3373 c         if (i.eq.25.and.j.eq.27) then
3374 c         write(iout,*) "jik",jik,"i",i,"j",j
3375 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3376 c         write(iout,*) "grad_odl3",grad_odl3
3377 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3378 c         write(iout,*) "ggodl",ggodl
3379 c         write(iout,*) "ghpbc(",jik,i,")",
3380 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3381 c     &                 ghpbc(jik,j)
3382 c         endif
3383          enddo
3384 #endif
3385 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3386 ccc     & dLOG(odleg2),"-odleg=", -odleg
3387
3388       enddo ! ii-loop for dist
3389 #ifdef DEBUG
3390       write(iout,*) "------- dist restrs end -------"
3391 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3392 c    &     waga_d.eq.1.0d0) call sum_gradient
3393 #endif
3394 c Pseudo-energy and gradient from dihedral-angle restraints from
3395 c homology templates
3396 c      write (iout,*) "End of distance loop"
3397 c      call flush(iout)
3398       kat=0.0d0
3399 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3400 #ifdef DEBUG
3401       write(iout,*) "------- dih restrs start -------"
3402       do i=idihconstr_start_homo,idihconstr_end_homo
3403         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3404       enddo
3405 #endif
3406       do i=idihconstr_start_homo,idihconstr_end_homo
3407         kat2=0.0d0
3408 c        betai=beta(i,i+1,i+2,i+3)
3409         betai = phi(i)
3410 c       write (iout,*) "betai =",betai
3411         do k=1,constr_homology
3412           dih_diff(k)=pinorm(dih(k,i)-betai)
3413 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3414 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3415 c     &                                   -(6.28318-dih_diff(i,k))
3416 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3417 c     &                                   6.28318+dih_diff(i,k)
3418 #ifdef OLD_DIHED
3419           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3420 #else
3421           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3422 #endif
3423 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3424           gdih(k)=dexp(kat3)
3425           kat2=kat2+gdih(k)
3426 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3427 c          write(*,*)""
3428         enddo
3429 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3430 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3431 #ifdef DEBUG
3432         write (iout,*) "i",i," betai",betai," kat2",kat2
3433         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3434 #endif
3435         if (kat2.le.1.0d-14) cycle
3436         kat=kat-dLOG(kat2/constr_homology)
3437 c       write (iout,*) "kat",kat ! sum of -ln-s
3438
3439 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3440 ccc     & dLOG(kat2), "-kat=", -kat
3441
3442 #ifdef GRAD
3443 c ----------------------------------------------------------------------
3444 c Gradient
3445 c ----------------------------------------------------------------------
3446
3447         sum_gdih=kat2
3448         sum_sgdih=0.0d0
3449         do k=1,constr_homology
3450 #ifdef OLD_DIHED
3451           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3452 #else
3453           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3454 #endif
3455 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3456           sum_sgdih=sum_sgdih+sgdih
3457         enddo
3458 c       grad_dih3=sum_sgdih/sum_gdih
3459         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3460
3461 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3462 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3463 ccc     & gloc(nphi+i-3,icg)
3464         gloc(i,icg)=gloc(i,icg)+grad_dih3
3465 c        if (i.eq.25) then
3466 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3467 c        endif
3468 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3469 ccc     & gloc(nphi+i-3,icg)
3470 #endif
3471       enddo ! i-loop for dih
3472 #ifdef DEBUG
3473       write(iout,*) "------- dih restrs end -------"
3474 #endif
3475
3476 c Pseudo-energy and gradient for theta angle restraints from
3477 c homology templates
3478 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3479 c adapted
3480
3481 c
3482 c     For constr_homology reference structures (FP)
3483 c
3484 c     Uconst_back_tot=0.0d0
3485       Eval=0.0d0
3486       Erot=0.0d0
3487 c     Econstr_back legacy
3488 #ifdef GRAD
3489       do i=1,nres
3490 c     do i=ithet_start,ithet_end
3491        dutheta(i)=0.0d0
3492 c     enddo
3493 c     do i=loc_start,loc_end
3494         do j=1,3
3495           duscdiff(j,i)=0.0d0
3496           duscdiffx(j,i)=0.0d0
3497         enddo
3498       enddo
3499 #endif
3500 c
3501 c     do iref=1,nref
3502 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3503 c     write (iout,*) "waga_theta",waga_theta
3504       if (waga_theta.gt.0.0d0) then
3505 #ifdef DEBUG
3506       write (iout,*) "usampl",usampl
3507       write(iout,*) "------- theta restrs start -------"
3508 c     do i=ithet_start,ithet_end
3509 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3510 c     enddo
3511 #endif
3512 c     write (iout,*) "maxres",maxres,"nres",nres
3513
3514       do i=ithet_start,ithet_end
3515 c
3516 c     do i=1,nfrag_back
3517 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3518 c
3519 c Deviation of theta angles wrt constr_homology ref structures
3520 c
3521         utheta_i=0.0d0 ! argument of Gaussian for single k
3522         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3523 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3524 c       over residues in a fragment
3525 c       write (iout,*) "theta(",i,")=",theta(i)
3526         do k=1,constr_homology
3527 c
3528 c         dtheta_i=theta(j)-thetaref(j,iref)
3529 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3530           theta_diff(k)=thetatpl(k,i)-theta(i)
3531 c
3532           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3533 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3534           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3535           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3536 c         Gradient for single Gaussian restraint in subr Econstr_back
3537 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3538 c
3539         enddo
3540 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3541 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3542
3543 c
3544 #ifdef GRAD
3545 c         Gradient for multiple Gaussian restraint
3546         sum_gtheta=gutheta_i
3547         sum_sgtheta=0.0d0
3548         do k=1,constr_homology
3549 c        New generalized expr for multiple Gaussian from Econstr_back
3550          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3551 c
3552 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3553           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3554         enddo
3555 c
3556 c       Final value of gradient using same var as in Econstr_back
3557         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3558      &               *waga_homology(iset)
3559 c       dutheta(i)=sum_sgtheta/sum_gtheta
3560 c
3561 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3562 #endif
3563         Eval=Eval-dLOG(gutheta_i/constr_homology)
3564 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3565 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3566 c       Uconst_back=Uconst_back+utheta(i)
3567       enddo ! (i-loop for theta)
3568 #ifdef DEBUG
3569       write(iout,*) "------- theta restrs end -------"
3570 #endif
3571       endif
3572 c
3573 c Deviation of local SC geometry
3574 c
3575 c Separation of two i-loops (instructed by AL - 11/3/2014)
3576 c
3577 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3578 c     write (iout,*) "waga_d",waga_d
3579
3580 #ifdef DEBUG
3581       write(iout,*) "------- SC restrs start -------"
3582       write (iout,*) "Initial duscdiff,duscdiffx"
3583       do i=loc_start,loc_end
3584         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3585      &                 (duscdiffx(jik,i),jik=1,3)
3586       enddo
3587 #endif
3588       do i=loc_start,loc_end
3589         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3590         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3591 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3592 c       write(iout,*) "xxtab, yytab, zztab"
3593 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3594         do k=1,constr_homology
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         write(iout,*) "dxx, dyy, dzz"
3601 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3602 c
3603           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3604 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3605 c         uscdiffk(k)=usc_diff(i)
3606           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3607           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3608 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3609 c     &      xxref(j),yyref(j),zzref(j)
3610         enddo
3611 c
3612 c       Gradient
3613 c
3614 c       Generalized expression for multiple Gaussian acc to that for a single
3615 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3616 c
3617 c       Original implementation
3618 c       sum_guscdiff=guscdiff(i)
3619 c
3620 c       sum_sguscdiff=0.0d0
3621 c       do k=1,constr_homology
3622 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3623 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3624 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3625 c       enddo
3626 c
3627 c       Implementation of new expressions for gradient (Jan. 2015)
3628 c
3629 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3630 #ifdef GRAD
3631         do k=1,constr_homology
3632 c
3633 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3634 c       before. Now the drivatives should be correct
3635 c
3636           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3637 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3638           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3639           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3640 c
3641 c         New implementation
3642 c
3643           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3644      &                 sigma_d(k,i) ! for the grad wrt r'
3645 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3646 c
3647 c
3648 c        New implementation
3649          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3650          do jik=1,3
3651             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3652      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3653      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3654             duscdiff(jik,i)=duscdiff(jik,i)+
3655      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3656      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3657             duscdiffx(jik,i)=duscdiffx(jik,i)+
3658      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3659      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3660 c
3661 #ifdef DEBUG
3662              write(iout,*) "jik",jik,"i",i
3663              write(iout,*) "dxx, dyy, dzz"
3664              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3665              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3666 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3667 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3668 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3669 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3670 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3671 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3672 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3673 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3674 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3675 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3676 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3677 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3678 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3679 c            endif
3680 #endif
3681          enddo
3682         enddo
3683 #endif
3684 c
3685 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3686 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3687 c
3688 c        write (iout,*) i," uscdiff",uscdiff(i)
3689 c
3690 c Put together deviations from local geometry
3691
3692 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3693 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3694         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3695 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3696 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3697 c       Uconst_back=Uconst_back+usc_diff(i)
3698 c
3699 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3700 c
3701 c     New implment: multiplied by sum_sguscdiff
3702 c
3703
3704       enddo ! (i-loop for dscdiff)
3705
3706 c      endif
3707
3708 #ifdef DEBUG
3709       write(iout,*) "------- SC restrs end -------"
3710         write (iout,*) "------ After SC loop in e_modeller ------"
3711         do i=loc_start,loc_end
3712          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3713          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3714         enddo
3715       if (waga_theta.eq.1.0d0) then
3716       write (iout,*) "in e_modeller after SC restr end: dutheta"
3717       do i=ithet_start,ithet_end
3718         write (iout,*) i,dutheta(i)
3719       enddo
3720       endif
3721       if (waga_d.eq.1.0d0) then
3722       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3723       do i=1,nres
3724         write (iout,*) i,(duscdiff(j,i),j=1,3)
3725         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3726       enddo
3727       endif
3728 #endif
3729
3730 c Total energy from homology restraints
3731 #ifdef DEBUG
3732       write (iout,*) "odleg",odleg," kat",kat
3733       write (iout,*) "odleg",odleg," kat",kat
3734       write (iout,*) "Eval",Eval," Erot",Erot
3735       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3736       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3737       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3738 #endif
3739 c
3740 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3741 c
3742 c     ehomology_constr=odleg+kat
3743 c
3744 c     For Lorentzian-type Urestr
3745 c
3746
3747       if (waga_dist.ge.0.0d0) then
3748 c
3749 c          For Gaussian-type Urestr
3750 c
3751 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3752 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3753         ehomology_constr=waga_dist*odleg+waga_angle*kat+
3754      &              waga_theta*Eval+waga_d*Erot
3755 c     write (iout,*) "ehomology_constr=",ehomology_constr
3756       else
3757 c
3758 c          For Lorentzian-type Urestr
3759 c
3760 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3761 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3762         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
3763      &              waga_theta*Eval+waga_d*Erot
3764 c     write (iout,*) "ehomology_constr=",ehomology_constr
3765       endif
3766 #ifdef DEBUG
3767       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3768      & "Eval",waga_theta,eval,
3769      &   "Erot",waga_d,Erot
3770       write (iout,*) "ehomology_constr",ehomology_constr
3771 #endif
3772       return
3773
3774   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3775   747 format(a12,i4,i4,i4,f8.3,f8.3)
3776   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3777   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3778   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3779      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3780       end
3781 c-----------------------------------------------------------------------
3782       subroutine ebond(estr)
3783 c
3784 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3785 c
3786       implicit real*8 (a-h,o-z)
3787       include 'DIMENSIONS'
3788       include 'DIMENSIONS.ZSCOPT'
3789       include 'DIMENSIONS.FREE'
3790       include 'COMMON.LOCAL'
3791       include 'COMMON.GEO'
3792       include 'COMMON.INTERACT'
3793       include 'COMMON.DERIV'
3794       include 'COMMON.VAR'
3795       include 'COMMON.CHAIN'
3796       include 'COMMON.IOUNITS'
3797       include 'COMMON.NAMES'
3798       include 'COMMON.FFIELD'
3799       include 'COMMON.CONTROL'
3800       double precision u(3),ud(3)
3801       logical :: lprn=.false.
3802       estr=0.0d0
3803       do i=nnt+1,nct
3804         diff = vbld(i)-vbldp0
3805 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3806         estr=estr+diff*diff
3807         do j=1,3
3808           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3809         enddo
3810       enddo
3811       estr=0.5d0*AKP*estr
3812 c
3813 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3814 c
3815       do i=nnt,nct
3816         iti=itype(i)
3817         if (iti.ne.10) then
3818           nbi=nbondterm(iti)
3819           if (nbi.eq.1) then
3820             diff=vbld(i+nres)-vbldsc0(1,iti)
3821             if (lprn)
3822      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3823      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3824             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3825             do j=1,3
3826               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3827             enddo
3828           else
3829             do j=1,nbi
3830               diff=vbld(i+nres)-vbldsc0(j,iti)
3831               ud(j)=aksc(j,iti)*diff
3832               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3833             enddo
3834             uprod=u(1)
3835             do j=2,nbi
3836               uprod=uprod*u(j)
3837             enddo
3838             usum=0.0d0
3839             usumsqder=0.0d0
3840             do j=1,nbi
3841               uprod1=1.0d0
3842               uprod2=1.0d0
3843               do k=1,nbi
3844                 if (k.ne.j) then
3845                   uprod1=uprod1*u(k)
3846                   uprod2=uprod2*u(k)*u(k)
3847                 endif
3848               enddo
3849               usum=usum+uprod1
3850               usumsqder=usumsqder+ud(j)*uprod2
3851             enddo
3852             if (lprn)
3853      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3854      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3855             estr=estr+uprod/usum
3856             do j=1,3
3857              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3858             enddo
3859           endif
3860         endif
3861       enddo
3862       return
3863       end
3864 #ifdef CRYST_THETA
3865 C--------------------------------------------------------------------------
3866       subroutine ebend(etheta)
3867 C
3868 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3869 C angles gamma and its derivatives in consecutive thetas and gammas.
3870 C
3871       implicit real*8 (a-h,o-z)
3872       include 'DIMENSIONS'
3873       include 'DIMENSIONS.ZSCOPT'
3874       include 'COMMON.LOCAL'
3875       include 'COMMON.GEO'
3876       include 'COMMON.INTERACT'
3877       include 'COMMON.DERIV'
3878       include 'COMMON.VAR'
3879       include 'COMMON.CHAIN'
3880       include 'COMMON.IOUNITS'
3881       include 'COMMON.NAMES'
3882       include 'COMMON.FFIELD'
3883       common /calcthet/ term1,term2,termm,diffak,ratak,
3884      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3885      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3886       double precision y(2),z(2)
3887       delta=0.02d0*pi
3888       time11=dexp(-2*time)
3889       time12=1.0d0
3890       etheta=0.0D0
3891 c      write (iout,*) "nres",nres
3892 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3893 c      write (iout,*) ithet_start,ithet_end
3894       do i=ithet_start,ithet_end
3895 C Zero the energy function and its derivative at 0 or pi.
3896         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3897         it=itype(i-1)
3898 c        if (i.gt.ithet_start .and.
3899 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3900 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3901 c          phii=phi(i)
3902 c          y(1)=dcos(phii)
3903 c          y(2)=dsin(phii)
3904 c        else
3905 c          y(1)=0.0D0
3906 c          y(2)=0.0D0
3907 c        endif
3908 c        if (i.lt.nres .and. itel(i).ne.0) then
3909 c          phii1=phi(i+1)
3910 c          z(1)=dcos(phii1)
3911 c          z(2)=dsin(phii1)
3912 c        else
3913 c          z(1)=0.0D0
3914 c          z(2)=0.0D0
3915 c        endif
3916         if (i.gt.3) then
3917 #ifdef OSF
3918           phii=phi(i)
3919           icrc=0
3920           call proc_proc(phii,icrc)
3921           if (icrc.eq.1) phii=150.0
3922 #else
3923           phii=phi(i)
3924 #endif
3925           y(1)=dcos(phii)
3926           y(2)=dsin(phii)
3927         else
3928           y(1)=0.0D0
3929           y(2)=0.0D0
3930         endif
3931         if (i.lt.nres) then
3932 #ifdef OSF
3933           phii1=phi(i+1)
3934           icrc=0
3935           call proc_proc(phii1,icrc)
3936           if (icrc.eq.1) phii1=150.0
3937           phii1=pinorm(phii1)
3938           z(1)=cos(phii1)
3939 #else
3940           phii1=phi(i+1)
3941           z(1)=dcos(phii1)
3942 #endif
3943           z(2)=dsin(phii1)
3944         else
3945           z(1)=0.0D0
3946           z(2)=0.0D0
3947         endif
3948 C Calculate the "mean" value of theta from the part of the distribution
3949 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3950 C In following comments this theta will be referred to as t_c.
3951         thet_pred_mean=0.0d0
3952         do k=1,2
3953           athetk=athet(k,it)
3954           bthetk=bthet(k,it)
3955           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3956         enddo
3957 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3958         dthett=thet_pred_mean*ssd
3959         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3960 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3961 C Derivatives of the "mean" values in gamma1 and gamma2.
3962         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3963         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3964         if (theta(i).gt.pi-delta) then
3965           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3966      &         E_tc0)
3967           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3968           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3969           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3970      &        E_theta)
3971           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3972      &        E_tc)
3973         else if (theta(i).lt.delta) then
3974           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3975           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3976           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3977      &        E_theta)
3978           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3979           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3980      &        E_tc)
3981         else
3982           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3983      &        E_theta,E_tc)
3984         endif
3985         etheta=etheta+ethetai
3986 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3987 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3988         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3989         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3990         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3991  1215   continue
3992       enddo
3993 C Ufff.... We've done all this!!!
3994       return
3995       end
3996 C---------------------------------------------------------------------------
3997       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3998      &     E_tc)
3999       implicit real*8 (a-h,o-z)
4000       include 'DIMENSIONS'
4001       include 'COMMON.LOCAL'
4002       include 'COMMON.IOUNITS'
4003       common /calcthet/ term1,term2,termm,diffak,ratak,
4004      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4005      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4006 C Calculate the contributions to both Gaussian lobes.
4007 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4008 C The "polynomial part" of the "standard deviation" of this part of
4009 C the distribution.
4010         sig=polthet(3,it)
4011         do j=2,0,-1
4012           sig=sig*thet_pred_mean+polthet(j,it)
4013         enddo
4014 C Derivative of the "interior part" of the "standard deviation of the"
4015 C gamma-dependent Gaussian lobe in t_c.
4016         sigtc=3*polthet(3,it)
4017         do j=2,1,-1
4018           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4019         enddo
4020         sigtc=sig*sigtc
4021 C Set the parameters of both Gaussian lobes of the distribution.
4022 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4023         fac=sig*sig+sigc0(it)
4024         sigcsq=fac+fac
4025         sigc=1.0D0/sigcsq
4026 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4027         sigsqtc=-4.0D0*sigcsq*sigtc
4028 c       print *,i,sig,sigtc,sigsqtc
4029 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4030         sigtc=-sigtc/(fac*fac)
4031 C Following variable is sigma(t_c)**(-2)
4032         sigcsq=sigcsq*sigcsq
4033         sig0i=sig0(it)
4034         sig0inv=1.0D0/sig0i**2
4035         delthec=thetai-thet_pred_mean
4036         delthe0=thetai-theta0i
4037         term1=-0.5D0*sigcsq*delthec*delthec
4038         term2=-0.5D0*sig0inv*delthe0*delthe0
4039 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4040 C NaNs in taking the logarithm. We extract the largest exponent which is added
4041 C to the energy (this being the log of the distribution) at the end of energy
4042 C term evaluation for this virtual-bond angle.
4043         if (term1.gt.term2) then
4044           termm=term1
4045           term2=dexp(term2-termm)
4046           term1=1.0d0
4047         else
4048           termm=term2
4049           term1=dexp(term1-termm)
4050           term2=1.0d0
4051         endif
4052 C The ratio between the gamma-independent and gamma-dependent lobes of
4053 C the distribution is a Gaussian function of thet_pred_mean too.
4054         diffak=gthet(2,it)-thet_pred_mean
4055         ratak=diffak/gthet(3,it)**2
4056         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4057 C Let's differentiate it in thet_pred_mean NOW.
4058         aktc=ak*ratak
4059 C Now put together the distribution terms to make complete distribution.
4060         termexp=term1+ak*term2
4061         termpre=sigc+ak*sig0i
4062 C Contribution of the bending energy from this theta is just the -log of
4063 C the sum of the contributions from the two lobes and the pre-exponential
4064 C factor. Simple enough, isn't it?
4065         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4066 C NOW the derivatives!!!
4067 C 6/6/97 Take into account the deformation.
4068         E_theta=(delthec*sigcsq*term1
4069      &       +ak*delthe0*sig0inv*term2)/termexp
4070         E_tc=((sigtc+aktc*sig0i)/termpre
4071      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4072      &       aktc*term2)/termexp)
4073       return
4074       end
4075 c-----------------------------------------------------------------------------
4076       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4077       implicit real*8 (a-h,o-z)
4078       include 'DIMENSIONS'
4079       include 'COMMON.LOCAL'
4080       include 'COMMON.IOUNITS'
4081       common /calcthet/ term1,term2,termm,diffak,ratak,
4082      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4083      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4084       delthec=thetai-thet_pred_mean
4085       delthe0=thetai-theta0i
4086 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4087       t3 = thetai-thet_pred_mean
4088       t6 = t3**2
4089       t9 = term1
4090       t12 = t3*sigcsq
4091       t14 = t12+t6*sigsqtc
4092       t16 = 1.0d0
4093       t21 = thetai-theta0i
4094       t23 = t21**2
4095       t26 = term2
4096       t27 = t21*t26
4097       t32 = termexp
4098       t40 = t32**2
4099       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4100      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4101      & *(-t12*t9-ak*sig0inv*t27)
4102       return
4103       end
4104 #else
4105 C--------------------------------------------------------------------------
4106       subroutine ebend(etheta)
4107 C
4108 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4109 C angles gamma and its derivatives in consecutive thetas and gammas.
4110 C ab initio-derived potentials from
4111 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4112 C
4113       implicit real*8 (a-h,o-z)
4114       include 'DIMENSIONS'
4115       include 'DIMENSIONS.ZSCOPT'
4116       include 'DIMENSIONS.FREE'
4117       include 'COMMON.LOCAL'
4118       include 'COMMON.GEO'
4119       include 'COMMON.INTERACT'
4120       include 'COMMON.DERIV'
4121       include 'COMMON.VAR'
4122       include 'COMMON.CHAIN'
4123       include 'COMMON.IOUNITS'
4124       include 'COMMON.NAMES'
4125       include 'COMMON.FFIELD'
4126       include 'COMMON.CONTROL'
4127       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4128      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4129      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4130      & sinph1ph2(maxdouble,maxdouble)
4131       logical lprn /.false./, lprn1 /.false./
4132       etheta=0.0D0
4133 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4134       do i=ithet_start,ithet_end
4135         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4136      &    (itype(i).eq.ntyp1)) cycle
4137         dethetai=0.0d0
4138         dephii=0.0d0
4139         dephii1=0.0d0
4140         theti2=0.5d0*theta(i)
4141         ityp2=ithetyp(itype(i-1))
4142         do k=1,nntheterm
4143           coskt(k)=dcos(k*theti2)
4144           sinkt(k)=dsin(k*theti2)
4145         enddo
4146         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4147 #ifdef OSF
4148           phii=phi(i)
4149           if (phii.ne.phii) phii=150.0
4150 #else
4151           phii=phi(i)
4152 #endif
4153           ityp1=ithetyp(itype(i-2))
4154           do k=1,nsingle
4155             cosph1(k)=dcos(k*phii)
4156             sinph1(k)=dsin(k*phii)
4157           enddo
4158         else
4159           phii=0.0d0
4160           ityp1=ithetyp(itype(i-2))
4161           do k=1,nsingle
4162             cosph1(k)=0.0d0
4163             sinph1(k)=0.0d0
4164           enddo
4165         endif
4166         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4167 #ifdef OSF
4168           phii1=phi(i+1)
4169           if (phii1.ne.phii1) phii1=150.0
4170           phii1=pinorm(phii1)
4171 #else
4172           phii1=phi(i+1)
4173 #endif
4174           ityp3=ithetyp(itype(i))
4175           do k=1,nsingle
4176             cosph2(k)=dcos(k*phii1)
4177             sinph2(k)=dsin(k*phii1)
4178           enddo
4179         else
4180           phii1=0.0d0
4181 c          ityp3=nthetyp+1
4182           ityp3=ithetyp(itype(i))
4183           do k=1,nsingle
4184             cosph2(k)=0.0d0
4185             sinph2(k)=0.0d0
4186           enddo
4187         endif
4188 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4189 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4190 c        call flush(iout)
4191         ethetai=aa0thet(ityp1,ityp2,ityp3)
4192         do k=1,ndouble
4193           do l=1,k-1
4194             ccl=cosph1(l)*cosph2(k-l)
4195             ssl=sinph1(l)*sinph2(k-l)
4196             scl=sinph1(l)*cosph2(k-l)
4197             csl=cosph1(l)*sinph2(k-l)
4198             cosph1ph2(l,k)=ccl-ssl
4199             cosph1ph2(k,l)=ccl+ssl
4200             sinph1ph2(l,k)=scl+csl
4201             sinph1ph2(k,l)=scl-csl
4202           enddo
4203         enddo
4204         if (lprn) then
4205         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4206      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4207         write (iout,*) "coskt and sinkt"
4208         do k=1,nntheterm
4209           write (iout,*) k,coskt(k),sinkt(k)
4210         enddo
4211         endif
4212         do k=1,ntheterm
4213           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4214           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4215      &      *coskt(k)
4216           if (lprn)
4217      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4218      &     " ethetai",ethetai
4219         enddo
4220         if (lprn) then
4221         write (iout,*) "cosph and sinph"
4222         do k=1,nsingle
4223           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4224         enddo
4225         write (iout,*) "cosph1ph2 and sinph2ph2"
4226         do k=2,ndouble
4227           do l=1,k-1
4228             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4229      &         sinph1ph2(l,k),sinph1ph2(k,l)
4230           enddo
4231         enddo
4232         write(iout,*) "ethetai",ethetai
4233         endif
4234         do m=1,ntheterm2
4235           do k=1,nsingle
4236             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4237      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4238      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4239      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4240             ethetai=ethetai+sinkt(m)*aux
4241             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4242             dephii=dephii+k*sinkt(m)*(
4243      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4244      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4245             dephii1=dephii1+k*sinkt(m)*(
4246      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4247      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4248             if (lprn)
4249      &      write (iout,*) "m",m," k",k," bbthet",
4250      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4251      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4252      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4253      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4254           enddo
4255         enddo
4256         if (lprn)
4257      &  write(iout,*) "ethetai",ethetai
4258         do m=1,ntheterm3
4259           do k=2,ndouble
4260             do l=1,k-1
4261               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4262      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4263      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4264      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4265               ethetai=ethetai+sinkt(m)*aux
4266               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4267               dephii=dephii+l*sinkt(m)*(
4268      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4269      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4270      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4271      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4272               dephii1=dephii1+(k-l)*sinkt(m)*(
4273      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4274      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4275      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4276      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4277               if (lprn) then
4278               write (iout,*) "m",m," k",k," l",l," ffthet",
4279      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4280      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4281      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4282      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4283               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4284      &            cosph1ph2(k,l)*sinkt(m),
4285      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4286               endif
4287             enddo
4288           enddo
4289         enddo
4290 10      continue
4291 c        lprn1=.true.
4292         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4293      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4294      &   phii1*rad2deg,ethetai
4295 c        lprn1=.false.
4296         etheta=etheta+ethetai
4297
4298         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4299         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4300         gloc(nphi+i-2,icg)=wang*dethetai
4301       enddo
4302       return
4303       end
4304 #endif
4305 #ifdef CRYST_SC
4306 c-----------------------------------------------------------------------------
4307       subroutine esc(escloc)
4308 C Calculate the local energy of a side chain and its derivatives in the
4309 C corresponding virtual-bond valence angles THETA and the spherical angles
4310 C ALPHA and OMEGA.
4311       implicit real*8 (a-h,o-z)
4312       include 'DIMENSIONS'
4313       include 'DIMENSIONS.ZSCOPT'
4314       include 'COMMON.GEO'
4315       include 'COMMON.LOCAL'
4316       include 'COMMON.VAR'
4317       include 'COMMON.INTERACT'
4318       include 'COMMON.DERIV'
4319       include 'COMMON.CHAIN'
4320       include 'COMMON.IOUNITS'
4321       include 'COMMON.NAMES'
4322       include 'COMMON.FFIELD'
4323       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4324      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4325       common /sccalc/ time11,time12,time112,theti,it,nlobit
4326       delta=0.02d0*pi
4327       escloc=0.0D0
4328 c     write (iout,'(a)') 'ESC'
4329       do i=loc_start,loc_end
4330         it=itype(i)
4331         if (it.eq.10) goto 1
4332         nlobit=nlob(it)
4333 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4334 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4335         theti=theta(i+1)-pipol
4336         x(1)=dtan(theti)
4337         x(2)=alph(i)
4338         x(3)=omeg(i)
4339 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4340
4341         if (x(2).gt.pi-delta) then
4342           xtemp(1)=x(1)
4343           xtemp(2)=pi-delta
4344           xtemp(3)=x(3)
4345           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4346           xtemp(2)=pi
4347           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4348           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4349      &        escloci,dersc(2))
4350           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4351      &        ddersc0(1),dersc(1))
4352           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4353      &        ddersc0(3),dersc(3))
4354           xtemp(2)=pi-delta
4355           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4356           xtemp(2)=pi
4357           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4358           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4359      &            dersc0(2),esclocbi,dersc02)
4360           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4361      &            dersc12,dersc01)
4362           call splinthet(x(2),0.5d0*delta,ss,ssd)
4363           dersc0(1)=dersc01
4364           dersc0(2)=dersc02
4365           dersc0(3)=0.0d0
4366           do k=1,3
4367             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4368           enddo
4369           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4370 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4371 c    &             esclocbi,ss,ssd
4372           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4373 c         escloci=esclocbi
4374 c         write (iout,*) escloci
4375         else if (x(2).lt.delta) then
4376           xtemp(1)=x(1)
4377           xtemp(2)=delta
4378           xtemp(3)=x(3)
4379           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4380           xtemp(2)=0.0d0
4381           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4382           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4383      &        escloci,dersc(2))
4384           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4385      &        ddersc0(1),dersc(1))
4386           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4387      &        ddersc0(3),dersc(3))
4388           xtemp(2)=delta
4389           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4390           xtemp(2)=0.0d0
4391           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4392           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4393      &            dersc0(2),esclocbi,dersc02)
4394           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4395      &            dersc12,dersc01)
4396           dersc0(1)=dersc01
4397           dersc0(2)=dersc02
4398           dersc0(3)=0.0d0
4399           call splinthet(x(2),0.5d0*delta,ss,ssd)
4400           do k=1,3
4401             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4402           enddo
4403           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4404 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4405 c    &             esclocbi,ss,ssd
4406           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4407 c         write (iout,*) escloci
4408         else
4409           call enesc(x,escloci,dersc,ddummy,.false.)
4410         endif
4411
4412         escloc=escloc+escloci
4413 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4414
4415         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4416      &   wscloc*dersc(1)
4417         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4418         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4419     1   continue
4420       enddo
4421       return
4422       end
4423 C---------------------------------------------------------------------------
4424       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4425       implicit real*8 (a-h,o-z)
4426       include 'DIMENSIONS'
4427       include 'COMMON.GEO'
4428       include 'COMMON.LOCAL'
4429       include 'COMMON.IOUNITS'
4430       common /sccalc/ time11,time12,time112,theti,it,nlobit
4431       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4432       double precision contr(maxlob,-1:1)
4433       logical mixed
4434 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4435         escloc_i=0.0D0
4436         do j=1,3
4437           dersc(j)=0.0D0
4438           if (mixed) ddersc(j)=0.0d0
4439         enddo
4440         x3=x(3)
4441
4442 C Because of periodicity of the dependence of the SC energy in omega we have
4443 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4444 C To avoid underflows, first compute & store the exponents.
4445
4446         do iii=-1,1
4447
4448           x(3)=x3+iii*dwapi
4449
4450           do j=1,nlobit
4451             do k=1,3
4452               z(k)=x(k)-censc(k,j,it)
4453             enddo
4454             do k=1,3
4455               Axk=0.0D0
4456               do l=1,3
4457                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4458               enddo
4459               Ax(k,j,iii)=Axk
4460             enddo
4461             expfac=0.0D0
4462             do k=1,3
4463               expfac=expfac+Ax(k,j,iii)*z(k)
4464             enddo
4465             contr(j,iii)=expfac
4466           enddo ! j
4467
4468         enddo ! iii
4469
4470         x(3)=x3
4471 C As in the case of ebend, we want to avoid underflows in exponentiation and
4472 C subsequent NaNs and INFs in energy calculation.
4473 C Find the largest exponent
4474         emin=contr(1,-1)
4475         do iii=-1,1
4476           do j=1,nlobit
4477             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4478           enddo
4479         enddo
4480         emin=0.5D0*emin
4481 cd      print *,'it=',it,' emin=',emin
4482
4483 C Compute the contribution to SC energy and derivatives
4484         do iii=-1,1
4485
4486           do j=1,nlobit
4487             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4488 cd          print *,'j=',j,' expfac=',expfac
4489             escloc_i=escloc_i+expfac
4490             do k=1,3
4491               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4492             enddo
4493             if (mixed) then
4494               do k=1,3,2
4495                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4496      &            +gaussc(k,2,j,it))*expfac
4497               enddo
4498             endif
4499           enddo
4500
4501         enddo ! iii
4502
4503         dersc(1)=dersc(1)/cos(theti)**2
4504         ddersc(1)=ddersc(1)/cos(theti)**2
4505         ddersc(3)=ddersc(3)
4506
4507         escloci=-(dlog(escloc_i)-emin)
4508         do j=1,3
4509           dersc(j)=dersc(j)/escloc_i
4510         enddo
4511         if (mixed) then
4512           do j=1,3,2
4513             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4514           enddo
4515         endif
4516       return
4517       end
4518 C------------------------------------------------------------------------------
4519       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4520       implicit real*8 (a-h,o-z)
4521       include 'DIMENSIONS'
4522       include 'COMMON.GEO'
4523       include 'COMMON.LOCAL'
4524       include 'COMMON.IOUNITS'
4525       common /sccalc/ time11,time12,time112,theti,it,nlobit
4526       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4527       double precision contr(maxlob)
4528       logical mixed
4529
4530       escloc_i=0.0D0
4531
4532       do j=1,3
4533         dersc(j)=0.0D0
4534       enddo
4535
4536       do j=1,nlobit
4537         do k=1,2
4538           z(k)=x(k)-censc(k,j,it)
4539         enddo
4540         z(3)=dwapi
4541         do k=1,3
4542           Axk=0.0D0
4543           do l=1,3
4544             Axk=Axk+gaussc(l,k,j,it)*z(l)
4545           enddo
4546           Ax(k,j)=Axk
4547         enddo
4548         expfac=0.0D0
4549         do k=1,3
4550           expfac=expfac+Ax(k,j)*z(k)
4551         enddo
4552         contr(j)=expfac
4553       enddo ! j
4554
4555 C As in the case of ebend, we want to avoid underflows in exponentiation and
4556 C subsequent NaNs and INFs in energy calculation.
4557 C Find the largest exponent
4558       emin=contr(1)
4559       do j=1,nlobit
4560         if (emin.gt.contr(j)) emin=contr(j)
4561       enddo
4562       emin=0.5D0*emin
4563
4564 C Compute the contribution to SC energy and derivatives
4565
4566       dersc12=0.0d0
4567       do j=1,nlobit
4568         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4569         escloc_i=escloc_i+expfac
4570         do k=1,2
4571           dersc(k)=dersc(k)+Ax(k,j)*expfac
4572         enddo
4573         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4574      &            +gaussc(1,2,j,it))*expfac
4575         dersc(3)=0.0d0
4576       enddo
4577
4578       dersc(1)=dersc(1)/cos(theti)**2
4579       dersc12=dersc12/cos(theti)**2
4580       escloci=-(dlog(escloc_i)-emin)
4581       do j=1,2
4582         dersc(j)=dersc(j)/escloc_i
4583       enddo
4584       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4585       return
4586       end
4587 #else
4588 c----------------------------------------------------------------------------------
4589       subroutine esc(escloc)
4590 C Calculate the local energy of a side chain and its derivatives in the
4591 C corresponding virtual-bond valence angles THETA and the spherical angles
4592 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4593 C added by Urszula Kozlowska. 07/11/2007
4594 C
4595       implicit real*8 (a-h,o-z)
4596       include 'DIMENSIONS'
4597       include 'DIMENSIONS.ZSCOPT'
4598       include 'DIMENSIONS.FREE'
4599       include 'COMMON.GEO'
4600       include 'COMMON.LOCAL'
4601       include 'COMMON.VAR'
4602       include 'COMMON.SCROT'
4603       include 'COMMON.INTERACT'
4604       include 'COMMON.DERIV'
4605       include 'COMMON.CHAIN'
4606       include 'COMMON.IOUNITS'
4607       include 'COMMON.NAMES'
4608       include 'COMMON.FFIELD'
4609       include 'COMMON.CONTROL'
4610       include 'COMMON.VECTORS'
4611       double precision x_prime(3),y_prime(3),z_prime(3)
4612      &    , sumene,dsc_i,dp2_i,x(65),
4613      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4614      &    de_dxx,de_dyy,de_dzz,de_dt
4615       double precision s1_t,s1_6_t,s2_t,s2_6_t
4616       double precision
4617      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4618      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4619      & dt_dCi(3),dt_dCi1(3)
4620       common /sccalc/ time11,time12,time112,theti,it,nlobit
4621       delta=0.02d0*pi
4622       escloc=0.0D0
4623       do i=loc_start,loc_end
4624         costtab(i+1) =dcos(theta(i+1))
4625         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4626         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4627         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4628         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4629         cosfac=dsqrt(cosfac2)
4630         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4631         sinfac=dsqrt(sinfac2)
4632         it=itype(i)
4633         if (it.eq.10) goto 1
4634 c
4635 C  Compute the axes of tghe local cartesian coordinates system; store in
4636 c   x_prime, y_prime and z_prime
4637 c
4638         do j=1,3
4639           x_prime(j) = 0.00
4640           y_prime(j) = 0.00
4641           z_prime(j) = 0.00
4642         enddo
4643 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4644 C     &   dc_norm(3,i+nres)
4645         do j = 1,3
4646           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4647           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4648         enddo
4649         do j = 1,3
4650           z_prime(j) = -uz(j,i-1)
4651         enddo
4652 c       write (2,*) "i",i
4653 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4654 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4655 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4656 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4657 c      & " xy",scalar(x_prime(1),y_prime(1)),
4658 c      & " xz",scalar(x_prime(1),z_prime(1)),
4659 c      & " yy",scalar(y_prime(1),y_prime(1)),
4660 c      & " yz",scalar(y_prime(1),z_prime(1)),
4661 c      & " zz",scalar(z_prime(1),z_prime(1))
4662 c
4663 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4664 C to local coordinate system. Store in xx, yy, zz.
4665 c
4666         xx=0.0d0
4667         yy=0.0d0
4668         zz=0.0d0
4669         do j = 1,3
4670           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4671           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4672           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4673         enddo
4674
4675         xxtab(i)=xx
4676         yytab(i)=yy
4677         zztab(i)=zz
4678 C
4679 C Compute the energy of the ith side cbain
4680 C
4681 c        write (2,*) "xx",xx," yy",yy," zz",zz
4682         it=itype(i)
4683         do j = 1,65
4684           x(j) = sc_parmin(j,it)
4685         enddo
4686 #ifdef CHECK_COORD
4687 Cc diagnostics - remove later
4688         xx1 = dcos(alph(2))
4689         yy1 = dsin(alph(2))*dcos(omeg(2))
4690         zz1 = -dsin(alph(2))*dsin(omeg(2))
4691         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4692      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4693      &    xx1,yy1,zz1
4694 C,"  --- ", xx_w,yy_w,zz_w
4695 c end diagnostics
4696 #endif
4697         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4698      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4699      &   + x(10)*yy*zz
4700         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4701      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4702      & + x(20)*yy*zz
4703         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4704      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4705      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4706      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4707      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4708      &  +x(40)*xx*yy*zz
4709         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4710      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4711      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4712      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4713      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4714      &  +x(60)*xx*yy*zz
4715         dsc_i   = 0.743d0+x(61)
4716         dp2_i   = 1.9d0+x(62)
4717         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4718      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4719         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4720      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4721         s1=(1+x(63))/(0.1d0 + dscp1)
4722         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4723         s2=(1+x(65))/(0.1d0 + dscp2)
4724         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4725         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4726      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4727 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4728 c     &   sumene4,
4729 c     &   dscp1,dscp2,sumene
4730 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4731         escloc = escloc + sumene
4732 c        write (2,*) "escloc",escloc
4733         if (.not. calc_grad) goto 1
4734
4735 #ifdef DEBUG2
4736 C
4737 C This section to check the numerical derivatives of the energy of ith side
4738 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4739 C #define DEBUG in the code to turn it on.
4740 C
4741         write (2,*) "sumene               =",sumene
4742         aincr=1.0d-7
4743         xxsave=xx
4744         xx=xx+aincr
4745         write (2,*) xx,yy,zz
4746         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4747         de_dxx_num=(sumenep-sumene)/aincr
4748         xx=xxsave
4749         write (2,*) "xx+ sumene from enesc=",sumenep
4750         yysave=yy
4751         yy=yy+aincr
4752         write (2,*) xx,yy,zz
4753         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4754         de_dyy_num=(sumenep-sumene)/aincr
4755         yy=yysave
4756         write (2,*) "yy+ sumene from enesc=",sumenep
4757         zzsave=zz
4758         zz=zz+aincr
4759         write (2,*) xx,yy,zz
4760         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4761         de_dzz_num=(sumenep-sumene)/aincr
4762         zz=zzsave
4763         write (2,*) "zz+ sumene from enesc=",sumenep
4764         costsave=cost2tab(i+1)
4765         sintsave=sint2tab(i+1)
4766         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4767         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4768         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4769         de_dt_num=(sumenep-sumene)/aincr
4770         write (2,*) " t+ sumene from enesc=",sumenep
4771         cost2tab(i+1)=costsave
4772         sint2tab(i+1)=sintsave
4773 C End of diagnostics section.
4774 #endif
4775 C
4776 C Compute the gradient of esc
4777 C
4778         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4779         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4780         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4781         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4782         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4783         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4784         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4785         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4786         pom1=(sumene3*sint2tab(i+1)+sumene1)
4787      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4788         pom2=(sumene4*cost2tab(i+1)+sumene2)
4789      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4790         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4791         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4792      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4793      &  +x(40)*yy*zz
4794         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4795         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4796      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4797      &  +x(60)*yy*zz
4798         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4799      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4800      &        +(pom1+pom2)*pom_dx
4801 #ifdef DEBUG
4802         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4803 #endif
4804 C
4805         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4806         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4807      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4808      &  +x(40)*xx*zz
4809         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4810         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4811      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4812      &  +x(59)*zz**2 +x(60)*xx*zz
4813         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4814      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4815      &        +(pom1-pom2)*pom_dy
4816 #ifdef DEBUG
4817         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4818 #endif
4819 C
4820         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4821      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4822      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4823      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4824      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4825      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4826      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4827      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4828 #ifdef DEBUG
4829         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4830 #endif
4831 C
4832         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4833      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4834      &  +pom1*pom_dt1+pom2*pom_dt2
4835 #ifdef DEBUG
4836         write(2,*), "de_dt = ", de_dt,de_dt_num
4837 #endif
4838 c
4839 C
4840        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4841        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4842        cosfac2xx=cosfac2*xx
4843        sinfac2yy=sinfac2*yy
4844        do k = 1,3
4845          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4846      &      vbld_inv(i+1)
4847          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4848      &      vbld_inv(i)
4849          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4850          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4851 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4852 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4853 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4854 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4855          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4856          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4857          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4858          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4859          dZZ_Ci1(k)=0.0d0
4860          dZZ_Ci(k)=0.0d0
4861          do j=1,3
4862            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4863            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4864          enddo
4865
4866          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4867          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4868          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4869 c
4870          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4871          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4872        enddo
4873
4874        do k=1,3
4875          dXX_Ctab(k,i)=dXX_Ci(k)
4876          dXX_C1tab(k,i)=dXX_Ci1(k)
4877          dYY_Ctab(k,i)=dYY_Ci(k)
4878          dYY_C1tab(k,i)=dYY_Ci1(k)
4879          dZZ_Ctab(k,i)=dZZ_Ci(k)
4880          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4881          dXX_XYZtab(k,i)=dXX_XYZ(k)
4882          dYY_XYZtab(k,i)=dYY_XYZ(k)
4883          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4884        enddo
4885
4886        do k = 1,3
4887 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4888 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4889 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4890 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4891 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4892 c     &    dt_dci(k)
4893 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4894 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4895          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4896      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4897          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4898      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4899          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4900      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4901        enddo
4902 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4903 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4904
4905 C to check gradient call subroutine check_grad
4906
4907     1 continue
4908       enddo
4909       return
4910       end
4911 #endif
4912 c------------------------------------------------------------------------------
4913       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4914 C
4915 C This procedure calculates two-body contact function g(rij) and its derivative:
4916 C
4917 C           eps0ij                                     !       x < -1
4918 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4919 C            0                                         !       x > 1
4920 C
4921 C where x=(rij-r0ij)/delta
4922 C
4923 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4924 C
4925       implicit none
4926       double precision rij,r0ij,eps0ij,fcont,fprimcont
4927       double precision x,x2,x4,delta
4928 c     delta=0.02D0*r0ij
4929 c      delta=0.2D0*r0ij
4930       x=(rij-r0ij)/delta
4931       if (x.lt.-1.0D0) then
4932         fcont=eps0ij
4933         fprimcont=0.0D0
4934       else if (x.le.1.0D0) then
4935         x2=x*x
4936         x4=x2*x2
4937         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4938         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4939       else
4940         fcont=0.0D0
4941         fprimcont=0.0D0
4942       endif
4943       return
4944       end
4945 c------------------------------------------------------------------------------
4946       subroutine splinthet(theti,delta,ss,ssder)
4947       implicit real*8 (a-h,o-z)
4948       include 'DIMENSIONS'
4949       include 'DIMENSIONS.ZSCOPT'
4950       include 'COMMON.VAR'
4951       include 'COMMON.GEO'
4952       thetup=pi-delta
4953       thetlow=delta
4954       if (theti.gt.pipol) then
4955         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4956       else
4957         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4958         ssder=-ssder
4959       endif
4960       return
4961       end
4962 c------------------------------------------------------------------------------
4963       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4964       implicit none
4965       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4966       double precision ksi,ksi2,ksi3,a1,a2,a3
4967       a1=fprim0*delta/(f1-f0)
4968       a2=3.0d0-2.0d0*a1
4969       a3=a1-2.0d0
4970       ksi=(x-x0)/delta
4971       ksi2=ksi*ksi
4972       ksi3=ksi2*ksi
4973       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4974       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4975       return
4976       end
4977 c------------------------------------------------------------------------------
4978       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4979       implicit none
4980       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4981       double precision ksi,ksi2,ksi3,a1,a2,a3
4982       ksi=(x-x0)/delta
4983       ksi2=ksi*ksi
4984       ksi3=ksi2*ksi
4985       a1=fprim0x*delta
4986       a2=3*(f1x-f0x)-2*fprim0x*delta
4987       a3=fprim0x*delta-2*(f1x-f0x)
4988       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4989       return
4990       end
4991 C-----------------------------------------------------------------------------
4992 #ifdef CRYST_TOR
4993 C-----------------------------------------------------------------------------
4994       subroutine etor(etors,edihcnstr,fact)
4995       implicit real*8 (a-h,o-z)
4996       include 'DIMENSIONS'
4997       include 'DIMENSIONS.ZSCOPT'
4998       include 'COMMON.VAR'
4999       include 'COMMON.GEO'
5000       include 'COMMON.LOCAL'
5001       include 'COMMON.TORSION'
5002       include 'COMMON.INTERACT'
5003       include 'COMMON.DERIV'
5004       include 'COMMON.CHAIN'
5005       include 'COMMON.NAMES'
5006       include 'COMMON.IOUNITS'
5007       include 'COMMON.FFIELD'
5008       include 'COMMON.TORCNSTR'
5009       logical lprn
5010 C Set lprn=.true. for debugging
5011       lprn=.false.
5012 c      lprn=.true.
5013       etors=0.0D0
5014       do i=iphi_start,iphi_end
5015         itori=itortyp(itype(i-2))
5016         itori1=itortyp(itype(i-1))
5017         phii=phi(i)
5018         gloci=0.0D0
5019 C Proline-Proline pair is a special case...
5020         if (itori.eq.3 .and. itori1.eq.3) then
5021           if (phii.gt.-dwapi3) then
5022             cosphi=dcos(3*phii)
5023             fac=1.0D0/(1.0D0-cosphi)
5024             etorsi=v1(1,3,3)*fac
5025             etorsi=etorsi+etorsi
5026             etors=etors+etorsi-v1(1,3,3)
5027             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5028           endif
5029           do j=1,3
5030             v1ij=v1(j+1,itori,itori1)
5031             v2ij=v2(j+1,itori,itori1)
5032             cosphi=dcos(j*phii)
5033             sinphi=dsin(j*phii)
5034             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5035             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5036           enddo
5037         else
5038           do j=1,nterm_old
5039             v1ij=v1(j,itori,itori1)
5040             v2ij=v2(j,itori,itori1)
5041             cosphi=dcos(j*phii)
5042             sinphi=dsin(j*phii)
5043             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5044             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5045           enddo
5046         endif
5047         if (lprn)
5048      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5049      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5050      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5051         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5052 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5053       enddo
5054 ! 6/20/98 - dihedral angle constraints
5055       edihcnstr=0.0d0
5056       do i=1,ndih_constr
5057         itori=idih_constr(i)
5058         phii=phi(itori)
5059         difi=phii-phi0(i)
5060         if (difi.gt.drange(i)) then
5061           difi=difi-drange(i)
5062           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5063           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5064         else if (difi.lt.-drange(i)) then
5065           difi=difi+drange(i)
5066           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5067           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5068         endif
5069 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5070 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5071       enddo
5072 !      write (iout,*) 'edihcnstr',edihcnstr
5073       return
5074       end
5075 c------------------------------------------------------------------------------
5076 #else
5077       subroutine etor(etors,edihcnstr,fact)
5078       implicit real*8 (a-h,o-z)
5079       include 'DIMENSIONS'
5080       include 'DIMENSIONS.ZSCOPT'
5081       include 'COMMON.VAR'
5082       include 'COMMON.GEO'
5083       include 'COMMON.LOCAL'
5084       include 'COMMON.TORSION'
5085       include 'COMMON.INTERACT'
5086       include 'COMMON.DERIV'
5087       include 'COMMON.CHAIN'
5088       include 'COMMON.NAMES'
5089       include 'COMMON.IOUNITS'
5090       include 'COMMON.FFIELD'
5091       include 'COMMON.TORCNSTR'
5092       logical lprn
5093 C Set lprn=.true. for debugging
5094       lprn=.false.
5095 c      lprn=.true.
5096       etors=0.0D0
5097       do i=iphi_start,iphi_end
5098         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5099         itori=itortyp(itype(i-2))
5100         itori1=itortyp(itype(i-1))
5101         phii=phi(i)
5102         gloci=0.0D0
5103 C Regular cosine and sine terms
5104         do j=1,nterm(itori,itori1)
5105           v1ij=v1(j,itori,itori1)
5106           v2ij=v2(j,itori,itori1)
5107           cosphi=dcos(j*phii)
5108           sinphi=dsin(j*phii)
5109           etors=etors+v1ij*cosphi+v2ij*sinphi
5110           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5111         enddo
5112 C Lorentz terms
5113 C                         v1
5114 C  E = SUM ----------------------------------- - v1
5115 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5116 C
5117         cosphi=dcos(0.5d0*phii)
5118         sinphi=dsin(0.5d0*phii)
5119         do j=1,nlor(itori,itori1)
5120           vl1ij=vlor1(j,itori,itori1)
5121           vl2ij=vlor2(j,itori,itori1)
5122           vl3ij=vlor3(j,itori,itori1)
5123           pom=vl2ij*cosphi+vl3ij*sinphi
5124           pom1=1.0d0/(pom*pom+1.0d0)
5125           etors=etors+vl1ij*pom1
5126           pom=-pom*pom1*pom1
5127           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5128         enddo
5129 C Subtract the constant term
5130         etors=etors-v0(itori,itori1)
5131         if (lprn)
5132      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5133      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5134      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5135         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5136 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5137  1215   continue
5138       enddo
5139 ! 6/20/98 - dihedral angle constraints
5140       edihcnstr=0.0d0
5141       do i=1,ndih_constr
5142         itori=idih_constr(i)
5143         phii=phi(itori)
5144         difi=pinorm(phii-phi0(i))
5145         edihi=0.0d0
5146         if (difi.gt.drange(i)) then
5147           difi=difi-drange(i)
5148           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5149           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5150           edihi=0.25d0*ftors*difi**4
5151         else if (difi.lt.-drange(i)) then
5152           difi=difi+drange(i)
5153           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5154           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5155           edihi=0.25d0*ftors*difi**4
5156         else
5157           difi=0.0d0
5158         endif
5159 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5160 c     &    drange(i),edihi
5161 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5162 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5163       enddo
5164 !      write (iout,*) 'edihcnstr',edihcnstr
5165       return
5166       end
5167 c----------------------------------------------------------------------------
5168       subroutine etor_d(etors_d,fact2)
5169 C 6/23/01 Compute double torsional energy
5170       implicit real*8 (a-h,o-z)
5171       include 'DIMENSIONS'
5172       include 'DIMENSIONS.ZSCOPT'
5173       include 'COMMON.VAR'
5174       include 'COMMON.GEO'
5175       include 'COMMON.LOCAL'
5176       include 'COMMON.TORSION'
5177       include 'COMMON.INTERACT'
5178       include 'COMMON.DERIV'
5179       include 'COMMON.CHAIN'
5180       include 'COMMON.NAMES'
5181       include 'COMMON.IOUNITS'
5182       include 'COMMON.FFIELD'
5183       include 'COMMON.TORCNSTR'
5184       logical lprn
5185 C Set lprn=.true. for debugging
5186       lprn=.false.
5187 c     lprn=.true.
5188       etors_d=0.0D0
5189       do i=iphi_start,iphi_end-1
5190         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5191      &     goto 1215
5192         itori=itortyp(itype(i-2))
5193         itori1=itortyp(itype(i-1))
5194         itori2=itortyp(itype(i))
5195         phii=phi(i)
5196         phii1=phi(i+1)
5197         gloci1=0.0D0
5198         gloci2=0.0D0
5199 C Regular cosine and sine terms
5200         do j=1,ntermd_1(itori,itori1,itori2)
5201           v1cij=v1c(1,j,itori,itori1,itori2)
5202           v1sij=v1s(1,j,itori,itori1,itori2)
5203           v2cij=v1c(2,j,itori,itori1,itori2)
5204           v2sij=v1s(2,j,itori,itori1,itori2)
5205           cosphi1=dcos(j*phii)
5206           sinphi1=dsin(j*phii)
5207           cosphi2=dcos(j*phii1)
5208           sinphi2=dsin(j*phii1)
5209           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5210      &     v2cij*cosphi2+v2sij*sinphi2
5211           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5212           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5213         enddo
5214         do k=2,ntermd_2(itori,itori1,itori2)
5215           do l=1,k-1
5216             v1cdij = v2c(k,l,itori,itori1,itori2)
5217             v2cdij = v2c(l,k,itori,itori1,itori2)
5218             v1sdij = v2s(k,l,itori,itori1,itori2)
5219             v2sdij = v2s(l,k,itori,itori1,itori2)
5220             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5221             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5222             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5223             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5224             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5225      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5226             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5227      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5228             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5229      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5230           enddo
5231         enddo
5232         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5233         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5234  1215   continue
5235       enddo
5236       return
5237       end
5238 #endif
5239 c------------------------------------------------------------------------------
5240       subroutine eback_sc_corr(esccor)
5241 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5242 c        conformational states; temporarily implemented as differences
5243 c        between UNRES torsional potentials (dependent on three types of
5244 c        residues) and the torsional potentials dependent on all 20 types
5245 c        of residues computed from AM1 energy surfaces of terminally-blocked
5246 c        amino-acid residues.
5247       implicit real*8 (a-h,o-z)
5248       include 'DIMENSIONS'
5249       include 'DIMENSIONS.ZSCOPT'
5250       include 'DIMENSIONS.FREE'
5251       include 'COMMON.VAR'
5252       include 'COMMON.GEO'
5253       include 'COMMON.LOCAL'
5254       include 'COMMON.TORSION'
5255       include 'COMMON.SCCOR'
5256       include 'COMMON.INTERACT'
5257       include 'COMMON.DERIV'
5258       include 'COMMON.CHAIN'
5259       include 'COMMON.NAMES'
5260       include 'COMMON.IOUNITS'
5261       include 'COMMON.FFIELD'
5262       include 'COMMON.CONTROL'
5263       logical lprn
5264 C Set lprn=.true. for debugging
5265       lprn=.false.
5266 c      lprn=.true.
5267 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5268       esccor=0.0D0
5269       do i=itau_start,itau_end
5270         esccor_ii=0.0D0
5271         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5272         isccori=isccortyp(itype(i-2))
5273         isccori1=isccortyp(itype(i-1))
5274         phii=phi(i)
5275 cccc  Added 9 May 2012
5276 cc Tauangle is torsional engle depending on the value of first digit
5277 c(see comment below)
5278 cc Omicron is flat angle depending on the value of first digit
5279 c(see comment below)
5280
5281
5282         do intertyp=1,3 !intertyp
5283 cc Added 09 May 2012 (Adasko)
5284 cc  Intertyp means interaction type of backbone mainchain correlation:
5285 c   1 = SC...Ca...Ca...Ca
5286 c   2 = Ca...Ca...Ca...SC
5287 c   3 = SC...Ca...Ca...SCi
5288         gloci=0.0D0
5289         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5290      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5291      &      (itype(i-1).eq.21)))
5292      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5293      &     .or.(itype(i-2).eq.21)))
5294      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5295      &      (itype(i-1).eq.21)))) cycle
5296         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5297         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5298      & cycle
5299         do j=1,nterm_sccor(isccori,isccori1)
5300           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5301           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5302           cosphi=dcos(j*tauangle(intertyp,i))
5303           sinphi=dsin(j*tauangle(intertyp,i))
5304           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5305 #ifdef DEBUG
5306           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5307 #endif
5308           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5309         enddo
5310         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5311 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5312 c     &gloc_sc(intertyp,i-3,icg)
5313         if (lprn)
5314      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5315      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5316      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5317      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5318         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5319        enddo !intertyp
5320 #ifdef DEBUG
5321        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5322 #endif
5323       enddo
5324 c        do i=1,nres
5325 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5326 c        enddo
5327       return
5328       end
5329 c------------------------------------------------------------------------------
5330       subroutine multibody(ecorr)
5331 C This subroutine calculates multi-body contributions to energy following
5332 C the idea of Skolnick et al. If side chains I and J make a contact and
5333 C at the same time side chains I+1 and J+1 make a contact, an extra
5334 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5335       implicit real*8 (a-h,o-z)
5336       include 'DIMENSIONS'
5337       include 'COMMON.IOUNITS'
5338       include 'COMMON.DERIV'
5339       include 'COMMON.INTERACT'
5340       include 'COMMON.CONTACTS'
5341       double precision gx(3),gx1(3)
5342       logical lprn
5343
5344 C Set lprn=.true. for debugging
5345       lprn=.false.
5346
5347       if (lprn) then
5348         write (iout,'(a)') 'Contact function values:'
5349         do i=nnt,nct-2
5350           write (iout,'(i2,20(1x,i2,f10.5))')
5351      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5352         enddo
5353       endif
5354       ecorr=0.0D0
5355       do i=nnt,nct
5356         do j=1,3
5357           gradcorr(j,i)=0.0D0
5358           gradxorr(j,i)=0.0D0
5359         enddo
5360       enddo
5361       do i=nnt,nct-2
5362
5363         DO ISHIFT = 3,4
5364
5365         i1=i+ishift
5366         num_conti=num_cont(i)
5367         num_conti1=num_cont(i1)
5368         do jj=1,num_conti
5369           j=jcont(jj,i)
5370           do kk=1,num_conti1
5371             j1=jcont(kk,i1)
5372             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5373 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5374 cd   &                   ' ishift=',ishift
5375 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5376 C The system gains extra energy.
5377               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5378             endif   ! j1==j+-ishift
5379           enddo     ! kk
5380         enddo       ! jj
5381
5382         ENDDO ! ISHIFT
5383
5384       enddo         ! i
5385       return
5386       end
5387 c------------------------------------------------------------------------------
5388       double precision function esccorr(i,j,k,l,jj,kk)
5389       implicit real*8 (a-h,o-z)
5390       include 'DIMENSIONS'
5391       include 'COMMON.IOUNITS'
5392       include 'COMMON.DERIV'
5393       include 'COMMON.INTERACT'
5394       include 'COMMON.CONTACTS'
5395       double precision gx(3),gx1(3)
5396       logical lprn
5397       lprn=.false.
5398       eij=facont(jj,i)
5399       ekl=facont(kk,k)
5400 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5401 C Calculate the multi-body contribution to energy.
5402 C Calculate multi-body contributions to the gradient.
5403 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5404 cd   & k,l,(gacont(m,kk,k),m=1,3)
5405       do m=1,3
5406         gx(m) =ekl*gacont(m,jj,i)
5407         gx1(m)=eij*gacont(m,kk,k)
5408         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5409         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5410         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5411         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5412       enddo
5413       do m=i,j-1
5414         do ll=1,3
5415           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5416         enddo
5417       enddo
5418       do m=k,l-1
5419         do ll=1,3
5420           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5421         enddo
5422       enddo
5423       esccorr=-eij*ekl
5424       return
5425       end
5426 c------------------------------------------------------------------------------
5427 #ifdef MPL
5428       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5429       implicit real*8 (a-h,o-z)
5430       include 'DIMENSIONS'
5431       integer dimen1,dimen2,atom,indx
5432       double precision buffer(dimen1,dimen2)
5433       double precision zapas
5434       common /contacts_hb/ zapas(3,20,maxres,7),
5435      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5436      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5437       num_kont=num_cont_hb(atom)
5438       do i=1,num_kont
5439         do k=1,7
5440           do j=1,3
5441             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5442           enddo ! j
5443         enddo ! k
5444         buffer(i,indx+22)=facont_hb(i,atom)
5445         buffer(i,indx+23)=ees0p(i,atom)
5446         buffer(i,indx+24)=ees0m(i,atom)
5447         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5448       enddo ! i
5449       buffer(1,indx+26)=dfloat(num_kont)
5450       return
5451       end
5452 c------------------------------------------------------------------------------
5453       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5454       implicit real*8 (a-h,o-z)
5455       include 'DIMENSIONS'
5456       integer dimen1,dimen2,atom,indx
5457       double precision buffer(dimen1,dimen2)
5458       double precision zapas
5459       common /contacts_hb/ zapas(3,20,maxres,7),
5460      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5461      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5462       num_kont=buffer(1,indx+26)
5463       num_kont_old=num_cont_hb(atom)
5464       num_cont_hb(atom)=num_kont+num_kont_old
5465       do i=1,num_kont
5466         ii=i+num_kont_old
5467         do k=1,7
5468           do j=1,3
5469             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5470           enddo ! j
5471         enddo ! k
5472         facont_hb(ii,atom)=buffer(i,indx+22)
5473         ees0p(ii,atom)=buffer(i,indx+23)
5474         ees0m(ii,atom)=buffer(i,indx+24)
5475         jcont_hb(ii,atom)=buffer(i,indx+25)
5476       enddo ! i
5477       return
5478       end
5479 c------------------------------------------------------------------------------
5480 #endif
5481       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5482 C This subroutine calculates multi-body contributions to hydrogen-bonding
5483       implicit real*8 (a-h,o-z)
5484       include 'DIMENSIONS'
5485       include 'DIMENSIONS.ZSCOPT'
5486       include 'COMMON.IOUNITS'
5487 #ifdef MPL
5488       include 'COMMON.INFO'
5489 #endif
5490       include 'COMMON.FFIELD'
5491       include 'COMMON.DERIV'
5492       include 'COMMON.INTERACT'
5493       include 'COMMON.CONTACTS'
5494 #ifdef MPL
5495       parameter (max_cont=maxconts)
5496       parameter (max_dim=2*(8*3+2))
5497       parameter (msglen1=max_cont*max_dim*4)
5498       parameter (msglen2=2*msglen1)
5499       integer source,CorrelType,CorrelID,Error
5500       double precision buffer(max_cont,max_dim)
5501 #endif
5502       double precision gx(3),gx1(3)
5503       logical lprn,ldone
5504
5505 C Set lprn=.true. for debugging
5506       lprn=.false.
5507 #ifdef MPL
5508       n_corr=0
5509       n_corr1=0
5510       if (fgProcs.le.1) goto 30
5511       if (lprn) then
5512         write (iout,'(a)') 'Contact function values:'
5513         do i=nnt,nct-2
5514           write (iout,'(2i3,50(1x,i2,f5.2))')
5515      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5516      &    j=1,num_cont_hb(i))
5517         enddo
5518       endif
5519 C Caution! Following code assumes that electrostatic interactions concerning
5520 C a given atom are split among at most two processors!
5521       CorrelType=477
5522       CorrelID=MyID+1
5523       ldone=.false.
5524       do i=1,max_cont
5525         do j=1,max_dim
5526           buffer(i,j)=0.0D0
5527         enddo
5528       enddo
5529       mm=mod(MyRank,2)
5530 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5531       if (mm) 20,20,10
5532    10 continue
5533 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5534       if (MyRank.gt.0) then
5535 C Send correlation contributions to the preceding processor
5536         msglen=msglen1
5537         nn=num_cont_hb(iatel_s)
5538         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5539 cd      write (iout,*) 'The BUFFER array:'
5540 cd      do i=1,nn
5541 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5542 cd      enddo
5543         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5544           msglen=msglen2
5545             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5546 C Clear the contacts of the atom passed to the neighboring processor
5547         nn=num_cont_hb(iatel_s+1)
5548 cd      do i=1,nn
5549 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5550 cd      enddo
5551             num_cont_hb(iatel_s)=0
5552         endif
5553 cd      write (iout,*) 'Processor ',MyID,MyRank,
5554 cd   & ' is sending correlation contribution to processor',MyID-1,
5555 cd   & ' msglen=',msglen
5556 cd      write (*,*) 'Processor ',MyID,MyRank,
5557 cd   & ' is sending correlation contribution to processor',MyID-1,
5558 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5559         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5560 cd      write (iout,*) 'Processor ',MyID,
5561 cd   & ' has sent correlation contribution to processor',MyID-1,
5562 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5563 cd      write (*,*) 'Processor ',MyID,
5564 cd   & ' has sent correlation contribution to processor',MyID-1,
5565 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5566         msglen=msglen1
5567       endif ! (MyRank.gt.0)
5568       if (ldone) goto 30
5569       ldone=.true.
5570    20 continue
5571 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5572       if (MyRank.lt.fgProcs-1) then
5573 C Receive correlation contributions from the next processor
5574         msglen=msglen1
5575         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5576 cd      write (iout,*) 'Processor',MyID,
5577 cd   & ' is receiving correlation contribution from processor',MyID+1,
5578 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5579 cd      write (*,*) 'Processor',MyID,
5580 cd   & ' is receiving correlation contribution from processor',MyID+1,
5581 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5582         nbytes=-1
5583         do while (nbytes.le.0)
5584           call mp_probe(MyID+1,CorrelType,nbytes)
5585         enddo
5586 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5587         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5588 cd      write (iout,*) 'Processor',MyID,
5589 cd   & ' has received correlation contribution from processor',MyID+1,
5590 cd   & ' msglen=',msglen,' nbytes=',nbytes
5591 cd      write (iout,*) 'The received BUFFER array:'
5592 cd      do i=1,max_cont
5593 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5594 cd      enddo
5595         if (msglen.eq.msglen1) then
5596           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5597         else if (msglen.eq.msglen2)  then
5598           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5599           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5600         else
5601           write (iout,*)
5602      & 'ERROR!!!! message length changed while processing correlations.'
5603           write (*,*)
5604      & 'ERROR!!!! message length changed while processing correlations.'
5605           call mp_stopall(Error)
5606         endif ! msglen.eq.msglen1
5607       endif ! MyRank.lt.fgProcs-1
5608       if (ldone) goto 30
5609       ldone=.true.
5610       goto 10
5611    30 continue
5612 #endif
5613       if (lprn) then
5614         write (iout,'(a)') 'Contact function values:'
5615         do i=nnt,nct-2
5616           write (iout,'(2i3,50(1x,i2,f5.2))')
5617      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5618      &    j=1,num_cont_hb(i))
5619         enddo
5620       endif
5621       ecorr=0.0D0
5622 C Remove the loop below after debugging !!!
5623       do i=nnt,nct
5624         do j=1,3
5625           gradcorr(j,i)=0.0D0
5626           gradxorr(j,i)=0.0D0
5627         enddo
5628       enddo
5629 C Calculate the local-electrostatic correlation terms
5630       do i=iatel_s,iatel_e+1
5631         i1=i+1
5632         num_conti=num_cont_hb(i)
5633         num_conti1=num_cont_hb(i+1)
5634         do jj=1,num_conti
5635           j=jcont_hb(jj,i)
5636           do kk=1,num_conti1
5637             j1=jcont_hb(kk,i1)
5638 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5639 c     &         ' jj=',jj,' kk=',kk
5640             if (j1.eq.j+1 .or. j1.eq.j-1) then
5641 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5642 C The system gains extra energy.
5643               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5644 #ifdef DEBUG
5645               write (iout,*) "ecorr",i,j,i+1,j1,
5646      &               ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5647 #endif
5648               n_corr=n_corr+1
5649             else if (j1.eq.j) then
5650 C Contacts I-J and I-(J+1) occur simultaneously.
5651 C The system loses extra energy.
5652 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5653             endif
5654           enddo ! kk
5655           do kk=1,num_conti
5656             j1=jcont_hb(kk,i)
5657 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5658 c    &         ' jj=',jj,' kk=',kk
5659             if (j1.eq.j+1) then
5660 C Contacts I-J and (I+1)-J occur simultaneously.
5661 C The system loses extra energy.
5662 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5663             endif ! j1==j+1
5664           enddo ! kk
5665         enddo ! jj
5666       enddo ! i
5667       return
5668       end
5669 c------------------------------------------------------------------------------
5670       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5671      &  n_corr1)
5672 C This subroutine calculates multi-body contributions to hydrogen-bonding
5673       implicit real*8 (a-h,o-z)
5674       include 'DIMENSIONS'
5675       include 'DIMENSIONS.ZSCOPT'
5676       include 'COMMON.IOUNITS'
5677 #ifdef MPL
5678       include 'COMMON.INFO'
5679 #endif
5680       include 'COMMON.FFIELD'
5681       include 'COMMON.DERIV'
5682       include 'COMMON.INTERACT'
5683       include 'COMMON.CONTACTS'
5684 #ifdef MPL
5685       parameter (max_cont=maxconts)
5686       parameter (max_dim=2*(8*3+2))
5687       parameter (msglen1=max_cont*max_dim*4)
5688       parameter (msglen2=2*msglen1)
5689       integer source,CorrelType,CorrelID,Error
5690       double precision buffer(max_cont,max_dim)
5691 #endif
5692       double precision gx(3),gx1(3)
5693       logical lprn,ldone
5694
5695 C Set lprn=.true. for debugging
5696       lprn=.false.
5697       eturn6=0.0d0
5698 #ifdef MPL
5699       n_corr=0
5700       n_corr1=0
5701       if (fgProcs.le.1) goto 30
5702       if (lprn) then
5703         write (iout,'(a)') 'Contact function values:'
5704         do i=nnt,nct-2
5705           write (iout,'(2i3,50(1x,i2,f5.2))')
5706      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5707      &    j=1,num_cont_hb(i))
5708         enddo
5709       endif
5710 C Caution! Following code assumes that electrostatic interactions concerning
5711 C a given atom are split among at most two processors!
5712       CorrelType=477
5713       CorrelID=MyID+1
5714       ldone=.false.
5715       do i=1,max_cont
5716         do j=1,max_dim
5717           buffer(i,j)=0.0D0
5718         enddo
5719       enddo
5720       mm=mod(MyRank,2)
5721 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5722       if (mm) 20,20,10
5723    10 continue
5724 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5725       if (MyRank.gt.0) then
5726 C Send correlation contributions to the preceding processor
5727         msglen=msglen1
5728         nn=num_cont_hb(iatel_s)
5729         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5730 cd      write (iout,*) 'The BUFFER array:'
5731 cd      do i=1,nn
5732 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5733 cd      enddo
5734         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5735           msglen=msglen2
5736             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5737 C Clear the contacts of the atom passed to the neighboring processor
5738         nn=num_cont_hb(iatel_s+1)
5739 cd      do i=1,nn
5740 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5741 cd      enddo
5742             num_cont_hb(iatel_s)=0
5743         endif
5744 cd      write (iout,*) 'Processor ',MyID,MyRank,
5745 cd   & ' is sending correlation contribution to processor',MyID-1,
5746 cd   & ' msglen=',msglen
5747 cd      write (*,*) 'Processor ',MyID,MyRank,
5748 cd   & ' is sending correlation contribution to processor',MyID-1,
5749 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5750         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5751 cd      write (iout,*) 'Processor ',MyID,
5752 cd   & ' has sent correlation contribution to processor',MyID-1,
5753 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5754 cd      write (*,*) 'Processor ',MyID,
5755 cd   & ' has sent correlation contribution to processor',MyID-1,
5756 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5757         msglen=msglen1
5758       endif ! (MyRank.gt.0)
5759       if (ldone) goto 30
5760       ldone=.true.
5761    20 continue
5762 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5763       if (MyRank.lt.fgProcs-1) then
5764 C Receive correlation contributions from the next processor
5765         msglen=msglen1
5766         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5767 cd      write (iout,*) 'Processor',MyID,
5768 cd   & ' is receiving correlation contribution from processor',MyID+1,
5769 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5770 cd      write (*,*) 'Processor',MyID,
5771 cd   & ' is receiving correlation contribution from processor',MyID+1,
5772 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5773         nbytes=-1
5774         do while (nbytes.le.0)
5775           call mp_probe(MyID+1,CorrelType,nbytes)
5776         enddo
5777 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5778         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5779 cd      write (iout,*) 'Processor',MyID,
5780 cd   & ' has received correlation contribution from processor',MyID+1,
5781 cd   & ' msglen=',msglen,' nbytes=',nbytes
5782 cd      write (iout,*) 'The received BUFFER array:'
5783 cd      do i=1,max_cont
5784 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5785 cd      enddo
5786         if (msglen.eq.msglen1) then
5787           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5788         else if (msglen.eq.msglen2)  then
5789           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5790           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5791         else
5792           write (iout,*)
5793      & 'ERROR!!!! message length changed while processing correlations.'
5794           write (*,*)
5795      & 'ERROR!!!! message length changed while processing correlations.'
5796           call mp_stopall(Error)
5797         endif ! msglen.eq.msglen1
5798       endif ! MyRank.lt.fgProcs-1
5799       if (ldone) goto 30
5800       ldone=.true.
5801       goto 10
5802    30 continue
5803 #endif
5804       if (lprn) then
5805         write (iout,'(a)') 'Contact function values:'
5806         do i=nnt,nct-2
5807           write (iout,'(2i3,50(1x,i2,f5.2))')
5808      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5809      &    j=1,num_cont_hb(i))
5810         enddo
5811       endif
5812       ecorr=0.0D0
5813       ecorr5=0.0d0
5814       ecorr6=0.0d0
5815 C Remove the loop below after debugging !!!
5816       do i=nnt,nct
5817         do j=1,3
5818           gradcorr(j,i)=0.0D0
5819           gradxorr(j,i)=0.0D0
5820         enddo
5821       enddo
5822 C Calculate the dipole-dipole interaction energies
5823       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5824       do i=iatel_s,iatel_e+1
5825         num_conti=num_cont_hb(i)
5826         do jj=1,num_conti
5827           j=jcont_hb(jj,i)
5828           call dipole(i,j,jj)
5829         enddo
5830       enddo
5831       endif
5832 C Calculate the local-electrostatic correlation terms
5833       do i=iatel_s,iatel_e+1
5834         i1=i+1
5835         num_conti=num_cont_hb(i)
5836         num_conti1=num_cont_hb(i+1)
5837         do jj=1,num_conti
5838           j=jcont_hb(jj,i)
5839           do kk=1,num_conti1
5840             j1=jcont_hb(kk,i1)
5841 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5842 c     &         ' jj=',jj,' kk=',kk
5843             if (j1.eq.j+1 .or. j1.eq.j-1) then
5844 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5845 C The system gains extra energy.
5846               n_corr=n_corr+1
5847               sqd1=dsqrt(d_cont(jj,i))
5848               sqd2=dsqrt(d_cont(kk,i1))
5849               sred_geom = sqd1*sqd2
5850               IF (sred_geom.lt.cutoff_corr) THEN
5851                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5852      &            ekont,fprimcont)
5853 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5854 c     &         ' jj=',jj,' kk=',kk
5855                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5856                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5857                 do l=1,3
5858                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5859                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5860                 enddo
5861                 n_corr1=n_corr1+1
5862 cd               write (iout,*) 'sred_geom=',sred_geom,
5863 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5864                 call calc_eello(i,j,i+1,j1,jj,kk)
5865                 if (wcorr4.gt.0.0d0)
5866      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5867                 if (wcorr5.gt.0.0d0)
5868      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5869 c                print *,"wcorr5",ecorr5
5870 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5871 cd                write(2,*)'ijkl',i,j,i+1,j1
5872                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5873      &               .or. wturn6.eq.0.0d0))then
5874 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5875                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5876 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5877 cd     &            'ecorr6=',ecorr6
5878 cd                write (iout,'(4e15.5)') sred_geom,
5879 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5880 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5881 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5882                 else if (wturn6.gt.0.0d0
5883      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5884 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5885                   eturn6=eturn6+eello_turn6(i,jj,kk)
5886 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5887                 endif
5888               ENDIF
5889 1111          continue
5890             else if (j1.eq.j) then
5891 C Contacts I-J and I-(J+1) occur simultaneously.
5892 C The system loses extra energy.
5893 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5894             endif
5895           enddo ! kk
5896           do kk=1,num_conti
5897             j1=jcont_hb(kk,i)
5898 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5899 c    &         ' jj=',jj,' kk=',kk
5900             if (j1.eq.j+1) then
5901 C Contacts I-J and (I+1)-J occur simultaneously.
5902 C The system loses extra energy.
5903 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5904             endif ! j1==j+1
5905           enddo ! kk
5906         enddo ! jj
5907       enddo ! i
5908       return
5909       end
5910 c------------------------------------------------------------------------------
5911       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5912       implicit real*8 (a-h,o-z)
5913       include 'DIMENSIONS'
5914       include 'COMMON.IOUNITS'
5915       include 'COMMON.DERIV'
5916       include 'COMMON.INTERACT'
5917       include 'COMMON.CONTACTS'
5918       double precision gx(3),gx1(3)
5919       logical lprn
5920       lprn=.false.
5921       eij=facont_hb(jj,i)
5922       ekl=facont_hb(kk,k)
5923       ees0pij=ees0p(jj,i)
5924       ees0pkl=ees0p(kk,k)
5925       ees0mij=ees0m(jj,i)
5926       ees0mkl=ees0m(kk,k)
5927       ekont=eij*ekl
5928       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5929 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5930 C Following 4 lines for diagnostics.
5931 cd    ees0pkl=0.0D0
5932 cd    ees0pij=1.0D0
5933 cd    ees0mkl=0.0D0
5934 cd    ees0mij=1.0D0
5935 cd      write (iout,*)'Contacts have occurred for peptide groups',i,j,
5936 cd     &   ' and',k,l
5937 cd      write (iout,*)'Contacts have occurred for peptide groups',
5938 cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5939 cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5940 C Calculate the multi-body contribution to energy.
5941       ecorr=ecorr+ekont*ees
5942       if (calc_grad) then
5943 C Calculate multi-body contributions to the gradient.
5944       do ll=1,3
5945         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5946         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5947      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5948      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5949         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5950      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5951      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5952         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5953         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5954      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5955      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5956         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5957      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5958      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5959       enddo
5960       do m=i+1,j-1
5961         do ll=1,3
5962           gradcorr(ll,m)=gradcorr(ll,m)+
5963      &     ees*ekl*gacont_hbr(ll,jj,i)-
5964      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5965      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5966         enddo
5967       enddo
5968       do m=k+1,l-1
5969         do ll=1,3
5970           gradcorr(ll,m)=gradcorr(ll,m)+
5971      &     ees*eij*gacont_hbr(ll,kk,k)-
5972      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5973      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5974         enddo
5975       enddo
5976       endif
5977       ehbcorr=ekont*ees
5978       return
5979       end
5980 C---------------------------------------------------------------------------
5981       subroutine dipole(i,j,jj)
5982       implicit real*8 (a-h,o-z)
5983       include 'DIMENSIONS'
5984       include 'DIMENSIONS.ZSCOPT'
5985       include 'COMMON.IOUNITS'
5986       include 'COMMON.CHAIN'
5987       include 'COMMON.FFIELD'
5988       include 'COMMON.DERIV'
5989       include 'COMMON.INTERACT'
5990       include 'COMMON.CONTACTS'
5991       include 'COMMON.TORSION'
5992       include 'COMMON.VAR'
5993       include 'COMMON.GEO'
5994       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5995      &  auxmat(2,2)
5996       iti1 = itortyp(itype(i+1))
5997       if (j.lt.nres-1) then
5998         itj1 = itortyp(itype(j+1))
5999       else
6000         itj1=ntortyp+1
6001       endif
6002       do iii=1,2
6003         dipi(iii,1)=Ub2(iii,i)
6004         dipderi(iii)=Ub2der(iii,i)
6005         dipi(iii,2)=b1(iii,iti1)
6006         dipj(iii,1)=Ub2(iii,j)
6007         dipderj(iii)=Ub2der(iii,j)
6008         dipj(iii,2)=b1(iii,itj1)
6009       enddo
6010       kkk=0
6011       do iii=1,2
6012         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6013         do jjj=1,2
6014           kkk=kkk+1
6015           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6016         enddo
6017       enddo
6018       if (.not.calc_grad) return
6019       do kkk=1,5
6020         do lll=1,3
6021           mmm=0
6022           do iii=1,2
6023             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6024      &        auxvec(1))
6025             do jjj=1,2
6026               mmm=mmm+1
6027               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6028             enddo
6029           enddo
6030         enddo
6031       enddo
6032       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6033       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6034       do iii=1,2
6035         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6036       enddo
6037       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6038       do iii=1,2
6039         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6040       enddo
6041       return
6042       end
6043 C---------------------------------------------------------------------------
6044       subroutine calc_eello(i,j,k,l,jj,kk)
6045 C
6046 C This subroutine computes matrices and vectors needed to calculate
6047 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6048 C
6049       implicit real*8 (a-h,o-z)
6050       include 'DIMENSIONS'
6051       include 'DIMENSIONS.ZSCOPT'
6052       include 'COMMON.IOUNITS'
6053       include 'COMMON.CHAIN'
6054       include 'COMMON.DERIV'
6055       include 'COMMON.INTERACT'
6056       include 'COMMON.CONTACTS'
6057       include 'COMMON.TORSION'
6058       include 'COMMON.VAR'
6059       include 'COMMON.GEO'
6060       include 'COMMON.FFIELD'
6061       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6062      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6063       logical lprn
6064       common /kutas/ lprn
6065 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6066 cd     & ' jj=',jj,' kk=',kk
6067 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6068       do iii=1,2
6069         do jjj=1,2
6070           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6071           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6072         enddo
6073       enddo
6074       call transpose2(aa1(1,1),aa1t(1,1))
6075       call transpose2(aa2(1,1),aa2t(1,1))
6076       do kkk=1,5
6077         do lll=1,3
6078           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6079      &      aa1tder(1,1,lll,kkk))
6080           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6081      &      aa2tder(1,1,lll,kkk))
6082         enddo
6083       enddo
6084       if (l.eq.j+1) then
6085 C parallel orientation of the two CA-CA-CA frames.
6086         if (i.gt.1) then
6087           iti=itortyp(itype(i))
6088         else
6089           iti=ntortyp+1
6090         endif
6091         itk1=itortyp(itype(k+1))
6092         itj=itortyp(itype(j))
6093         if (l.lt.nres-1) then
6094           itl1=itortyp(itype(l+1))
6095         else
6096           itl1=ntortyp+1
6097         endif
6098 C A1 kernel(j+1) A2T
6099 cd        do iii=1,2
6100 cd          write (iout,'(3f10.5,5x,3f10.5)')
6101 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6102 cd        enddo
6103         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6104      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6105      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6106 C Following matrices are needed only for 6-th order cumulants
6107         IF (wcorr6.gt.0.0d0) THEN
6108         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6109      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6110      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6111         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6112      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6113      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6114      &   ADtEAderx(1,1,1,1,1,1))
6115         lprn=.false.
6116         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6117      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6118      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6119      &   ADtEA1derx(1,1,1,1,1,1))
6120         ENDIF
6121 C End 6-th order cumulants
6122 cd        lprn=.false.
6123 cd        if (lprn) then
6124 cd        write (2,*) 'In calc_eello6'
6125 cd        do iii=1,2
6126 cd          write (2,*) 'iii=',iii
6127 cd          do kkk=1,5
6128 cd            write (2,*) 'kkk=',kkk
6129 cd            do jjj=1,2
6130 cd              write (2,'(3(2f10.5),5x)')
6131 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6132 cd            enddo
6133 cd          enddo
6134 cd        enddo
6135 cd        endif
6136         call transpose2(EUgder(1,1,k),auxmat(1,1))
6137         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6138         call transpose2(EUg(1,1,k),auxmat(1,1))
6139         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6140         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6141         do iii=1,2
6142           do kkk=1,5
6143             do lll=1,3
6144               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6145      &          EAEAderx(1,1,lll,kkk,iii,1))
6146             enddo
6147           enddo
6148         enddo
6149 C A1T kernel(i+1) A2
6150         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6151      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6152      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6153 C Following matrices are needed only for 6-th order cumulants
6154         IF (wcorr6.gt.0.0d0) THEN
6155         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6156      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6157      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6158         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6159      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6160      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6161      &   ADtEAderx(1,1,1,1,1,2))
6162         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6163      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6164      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6165      &   ADtEA1derx(1,1,1,1,1,2))
6166         ENDIF
6167 C End 6-th order cumulants
6168         call transpose2(EUgder(1,1,l),auxmat(1,1))
6169         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6170         call transpose2(EUg(1,1,l),auxmat(1,1))
6171         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6172         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6173         do iii=1,2
6174           do kkk=1,5
6175             do lll=1,3
6176               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6177      &          EAEAderx(1,1,lll,kkk,iii,2))
6178             enddo
6179           enddo
6180         enddo
6181 C AEAb1 and AEAb2
6182 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6183 C They are needed only when the fifth- or the sixth-order cumulants are
6184 C indluded.
6185         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6186         call transpose2(AEA(1,1,1),auxmat(1,1))
6187         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6188         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6189         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6190         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6191         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6192         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6193         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6194         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6195         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6196         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6197         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6198         call transpose2(AEA(1,1,2),auxmat(1,1))
6199         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6200         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6201         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6202         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6203         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6204         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6205         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6206         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6207         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6208         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6209         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6210 C Calculate the Cartesian derivatives of the vectors.
6211         do iii=1,2
6212           do kkk=1,5
6213             do lll=1,3
6214               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6215               call matvec2(auxmat(1,1),b1(1,iti),
6216      &          AEAb1derx(1,lll,kkk,iii,1,1))
6217               call matvec2(auxmat(1,1),Ub2(1,i),
6218      &          AEAb2derx(1,lll,kkk,iii,1,1))
6219               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6220      &          AEAb1derx(1,lll,kkk,iii,2,1))
6221               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6222      &          AEAb2derx(1,lll,kkk,iii,2,1))
6223               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6224               call matvec2(auxmat(1,1),b1(1,itj),
6225      &          AEAb1derx(1,lll,kkk,iii,1,2))
6226               call matvec2(auxmat(1,1),Ub2(1,j),
6227      &          AEAb2derx(1,lll,kkk,iii,1,2))
6228               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6229      &          AEAb1derx(1,lll,kkk,iii,2,2))
6230               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6231      &          AEAb2derx(1,lll,kkk,iii,2,2))
6232             enddo
6233           enddo
6234         enddo
6235         ENDIF
6236 C End vectors
6237       else
6238 C Antiparallel orientation of the two CA-CA-CA frames.
6239         if (i.gt.1) then
6240           iti=itortyp(itype(i))
6241         else
6242           iti=ntortyp+1
6243         endif
6244         itk1=itortyp(itype(k+1))
6245         itl=itortyp(itype(l))
6246         itj=itortyp(itype(j))
6247         if (j.lt.nres-1) then
6248           itj1=itortyp(itype(j+1))
6249         else
6250           itj1=ntortyp+1
6251         endif
6252 C A2 kernel(j-1)T A1T
6253         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6254      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6255      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6256 C Following matrices are needed only for 6-th order cumulants
6257         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6258      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6259         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6260      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6261      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6262         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6263      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6264      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6265      &   ADtEAderx(1,1,1,1,1,1))
6266         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6267      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6268      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6269      &   ADtEA1derx(1,1,1,1,1,1))
6270         ENDIF
6271 C End 6-th order cumulants
6272         call transpose2(EUgder(1,1,k),auxmat(1,1))
6273         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6274         call transpose2(EUg(1,1,k),auxmat(1,1))
6275         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6276         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6277         do iii=1,2
6278           do kkk=1,5
6279             do lll=1,3
6280               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6281      &          EAEAderx(1,1,lll,kkk,iii,1))
6282             enddo
6283           enddo
6284         enddo
6285 C A2T kernel(i+1)T A1
6286         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6287      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6288      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6289 C Following matrices are needed only for 6-th order cumulants
6290         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6291      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6292         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6293      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6294      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6295         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6296      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6297      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6298      &   ADtEAderx(1,1,1,1,1,2))
6299         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6300      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6301      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6302      &   ADtEA1derx(1,1,1,1,1,2))
6303         ENDIF
6304 C End 6-th order cumulants
6305         call transpose2(EUgder(1,1,j),auxmat(1,1))
6306         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6307         call transpose2(EUg(1,1,j),auxmat(1,1))
6308         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6309         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6310         do iii=1,2
6311           do kkk=1,5
6312             do lll=1,3
6313               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6314      &          EAEAderx(1,1,lll,kkk,iii,2))
6315             enddo
6316           enddo
6317         enddo
6318 C AEAb1 and AEAb2
6319 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6320 C They are needed only when the fifth- or the sixth-order cumulants are
6321 C indluded.
6322         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6323      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6324         call transpose2(AEA(1,1,1),auxmat(1,1))
6325         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6326         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6327         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6328         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6329         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6330         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6331         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6332         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6333         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6334         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6335         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6336         call transpose2(AEA(1,1,2),auxmat(1,1))
6337         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6338         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6339         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6340         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6341         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6342         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6343         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6344         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6345         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6346         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6347         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6348 C Calculate the Cartesian derivatives of the vectors.
6349         do iii=1,2
6350           do kkk=1,5
6351             do lll=1,3
6352               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6353               call matvec2(auxmat(1,1),b1(1,iti),
6354      &          AEAb1derx(1,lll,kkk,iii,1,1))
6355               call matvec2(auxmat(1,1),Ub2(1,i),
6356      &          AEAb2derx(1,lll,kkk,iii,1,1))
6357               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6358      &          AEAb1derx(1,lll,kkk,iii,2,1))
6359               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6360      &          AEAb2derx(1,lll,kkk,iii,2,1))
6361               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6362               call matvec2(auxmat(1,1),b1(1,itl),
6363      &          AEAb1derx(1,lll,kkk,iii,1,2))
6364               call matvec2(auxmat(1,1),Ub2(1,l),
6365      &          AEAb2derx(1,lll,kkk,iii,1,2))
6366               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6367      &          AEAb1derx(1,lll,kkk,iii,2,2))
6368               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6369      &          AEAb2derx(1,lll,kkk,iii,2,2))
6370             enddo
6371           enddo
6372         enddo
6373         ENDIF
6374 C End vectors
6375       endif
6376       return
6377       end
6378 C---------------------------------------------------------------------------
6379       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6380      &  KK,KKderg,AKA,AKAderg,AKAderx)
6381       implicit none
6382       integer nderg
6383       logical transp
6384       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6385      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6386      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6387       integer iii,kkk,lll
6388       integer jjj,mmm
6389       logical lprn
6390       common /kutas/ lprn
6391       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6392       do iii=1,nderg
6393         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6394      &    AKAderg(1,1,iii))
6395       enddo
6396 cd      if (lprn) write (2,*) 'In kernel'
6397       do kkk=1,5
6398 cd        if (lprn) write (2,*) 'kkk=',kkk
6399         do lll=1,3
6400           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6401      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6402 cd          if (lprn) then
6403 cd            write (2,*) 'lll=',lll
6404 cd            write (2,*) 'iii=1'
6405 cd            do jjj=1,2
6406 cd              write (2,'(3(2f10.5),5x)')
6407 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6408 cd            enddo
6409 cd          endif
6410           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6411      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6412 cd          if (lprn) then
6413 cd            write (2,*) 'lll=',lll
6414 cd            write (2,*) 'iii=2'
6415 cd            do jjj=1,2
6416 cd              write (2,'(3(2f10.5),5x)')
6417 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6418 cd            enddo
6419 cd          endif
6420         enddo
6421       enddo
6422       return
6423       end
6424 C---------------------------------------------------------------------------
6425       double precision function eello4(i,j,k,l,jj,kk)
6426       implicit real*8 (a-h,o-z)
6427       include 'DIMENSIONS'
6428       include 'DIMENSIONS.ZSCOPT'
6429       include 'COMMON.IOUNITS'
6430       include 'COMMON.CHAIN'
6431       include 'COMMON.DERIV'
6432       include 'COMMON.INTERACT'
6433       include 'COMMON.CONTACTS'
6434       include 'COMMON.TORSION'
6435       include 'COMMON.VAR'
6436       include 'COMMON.GEO'
6437       double precision pizda(2,2),ggg1(3),ggg2(3)
6438 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6439 cd        eello4=0.0d0
6440 cd        return
6441 cd      endif
6442 cd      print *,'eello4:',i,j,k,l,jj,kk
6443 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6444 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6445 cold      eij=facont_hb(jj,i)
6446 cold      ekl=facont_hb(kk,k)
6447 cold      ekont=eij*ekl
6448       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6449       if (calc_grad) then
6450 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6451       gcorr_loc(k-1)=gcorr_loc(k-1)
6452      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6453       if (l.eq.j+1) then
6454         gcorr_loc(l-1)=gcorr_loc(l-1)
6455      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6456       else
6457         gcorr_loc(j-1)=gcorr_loc(j-1)
6458      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6459       endif
6460       do iii=1,2
6461         do kkk=1,5
6462           do lll=1,3
6463             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6464      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6465 cd            derx(lll,kkk,iii)=0.0d0
6466           enddo
6467         enddo
6468       enddo
6469 cd      gcorr_loc(l-1)=0.0d0
6470 cd      gcorr_loc(j-1)=0.0d0
6471 cd      gcorr_loc(k-1)=0.0d0
6472 cd      eel4=1.0d0
6473 cd      write (iout,*)'Contacts have occurred for peptide groups',
6474 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6475 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6476       if (j.lt.nres-1) then
6477         j1=j+1
6478         j2=j-1
6479       else
6480         j1=j-1
6481         j2=j-2
6482       endif
6483       if (l.lt.nres-1) then
6484         l1=l+1
6485         l2=l-1
6486       else
6487         l1=l-1
6488         l2=l-2
6489       endif
6490       do ll=1,3
6491 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6492         ggg1(ll)=eel4*g_contij(ll,1)
6493         ggg2(ll)=eel4*g_contij(ll,2)
6494         ghalf=0.5d0*ggg1(ll)
6495 cd        ghalf=0.0d0
6496         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6497         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6498         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6499         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6500 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6501         ghalf=0.5d0*ggg2(ll)
6502 cd        ghalf=0.0d0
6503         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6504         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6505         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6506         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6507       enddo
6508 cd      goto 1112
6509       do m=i+1,j-1
6510         do ll=1,3
6511 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6512           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6513         enddo
6514       enddo
6515       do m=k+1,l-1
6516         do ll=1,3
6517 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6518           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6519         enddo
6520       enddo
6521 1112  continue
6522       do m=i+2,j2
6523         do ll=1,3
6524           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6525         enddo
6526       enddo
6527       do m=k+2,l2
6528         do ll=1,3
6529           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6530         enddo
6531       enddo
6532 cd      do iii=1,nres-3
6533 cd        write (2,*) iii,gcorr_loc(iii)
6534 cd      enddo
6535       endif
6536       eello4=ekont*eel4
6537 cd      write (2,*) 'ekont',ekont
6538 cd      write (iout,*) 'eello4',ekont*eel4
6539       return
6540       end
6541 C---------------------------------------------------------------------------
6542       double precision function eello5(i,j,k,l,jj,kk)
6543       implicit real*8 (a-h,o-z)
6544       include 'DIMENSIONS'
6545       include 'DIMENSIONS.ZSCOPT'
6546       include 'COMMON.IOUNITS'
6547       include 'COMMON.CHAIN'
6548       include 'COMMON.DERIV'
6549       include 'COMMON.INTERACT'
6550       include 'COMMON.CONTACTS'
6551       include 'COMMON.TORSION'
6552       include 'COMMON.VAR'
6553       include 'COMMON.GEO'
6554       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6555       double precision ggg1(3),ggg2(3)
6556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6557 C                                                                              C
6558 C                            Parallel chains                                   C
6559 C                                                                              C
6560 C          o             o                   o             o                   C
6561 C         /l\           / \             \   / \           / \   /              C
6562 C        /   \         /   \             \ /   \         /   \ /               C
6563 C       j| o |l1       | o |              o| o |         | o |o                C
6564 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6565 C      \i/   \         /   \ /             /   \         /   \                 C
6566 C       o    k1             o                                                  C
6567 C         (I)          (II)                (III)          (IV)                 C
6568 C                                                                              C
6569 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6570 C                                                                              C
6571 C                            Antiparallel chains                               C
6572 C                                                                              C
6573 C          o             o                   o             o                   C
6574 C         /j\           / \             \   / \           / \   /              C
6575 C        /   \         /   \             \ /   \         /   \ /               C
6576 C      j1| o |l        | o |              o| o |         | o |o                C
6577 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6578 C      \i/   \         /   \ /             /   \         /   \                 C
6579 C       o     k1            o                                                  C
6580 C         (I)          (II)                (III)          (IV)                 C
6581 C                                                                              C
6582 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6583 C                                                                              C
6584 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6585 C                                                                              C
6586 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6587 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6588 cd        eello5=0.0d0
6589 cd        return
6590 cd      endif
6591 cd      write (iout,*)
6592 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6593 cd     &   ' and',k,l
6594       itk=itortyp(itype(k))
6595       itl=itortyp(itype(l))
6596       itj=itortyp(itype(j))
6597       eello5_1=0.0d0
6598       eello5_2=0.0d0
6599       eello5_3=0.0d0
6600       eello5_4=0.0d0
6601 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6602 cd     &   eel5_3_num,eel5_4_num)
6603       do iii=1,2
6604         do kkk=1,5
6605           do lll=1,3
6606             derx(lll,kkk,iii)=0.0d0
6607           enddo
6608         enddo
6609       enddo
6610 cd      eij=facont_hb(jj,i)
6611 cd      ekl=facont_hb(kk,k)
6612 cd      ekont=eij*ekl
6613 cd      write (iout,*)'Contacts have occurred for peptide groups',
6614 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6615 cd      goto 1111
6616 C Contribution from the graph I.
6617 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6618 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6619       call transpose2(EUg(1,1,k),auxmat(1,1))
6620       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6621       vv(1)=pizda(1,1)-pizda(2,2)
6622       vv(2)=pizda(1,2)+pizda(2,1)
6623       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6624      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6625       if (calc_grad) then
6626 C Explicit gradient in virtual-dihedral angles.
6627       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6628      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6629      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6630       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6631       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6632       vv(1)=pizda(1,1)-pizda(2,2)
6633       vv(2)=pizda(1,2)+pizda(2,1)
6634       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6635      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6636      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6637       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6638       vv(1)=pizda(1,1)-pizda(2,2)
6639       vv(2)=pizda(1,2)+pizda(2,1)
6640       if (l.eq.j+1) then
6641         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6642      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6644       else
6645         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6646      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6647      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6648       endif
6649 C Cartesian gradient
6650       do iii=1,2
6651         do kkk=1,5
6652           do lll=1,3
6653             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6654      &        pizda(1,1))
6655             vv(1)=pizda(1,1)-pizda(2,2)
6656             vv(2)=pizda(1,2)+pizda(2,1)
6657             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6658      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6659      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6660           enddo
6661         enddo
6662       enddo
6663 c      goto 1112
6664       endif
6665 c1111  continue
6666 C Contribution from graph II
6667       call transpose2(EE(1,1,itk),auxmat(1,1))
6668       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6669       vv(1)=pizda(1,1)+pizda(2,2)
6670       vv(2)=pizda(2,1)-pizda(1,2)
6671       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6672      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6673       if (calc_grad) then
6674 C Explicit gradient in virtual-dihedral angles.
6675       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6676      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6677       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6678       vv(1)=pizda(1,1)+pizda(2,2)
6679       vv(2)=pizda(2,1)-pizda(1,2)
6680       if (l.eq.j+1) then
6681         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6682      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6683      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6684       else
6685         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6686      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6687      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6688       endif
6689 C Cartesian gradient
6690       do iii=1,2
6691         do kkk=1,5
6692           do lll=1,3
6693             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6694      &        pizda(1,1))
6695             vv(1)=pizda(1,1)+pizda(2,2)
6696             vv(2)=pizda(2,1)-pizda(1,2)
6697             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6698      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6699      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6700           enddo
6701         enddo
6702       enddo
6703 cd      goto 1112
6704       endif
6705 cd1111  continue
6706       if (l.eq.j+1) then
6707 cd        goto 1110
6708 C Parallel orientation
6709 C Contribution from graph III
6710         call transpose2(EUg(1,1,l),auxmat(1,1))
6711         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6712         vv(1)=pizda(1,1)-pizda(2,2)
6713         vv(2)=pizda(1,2)+pizda(2,1)
6714         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6715      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6716         if (calc_grad) then
6717 C Explicit gradient in virtual-dihedral angles.
6718         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6719      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6720      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6721         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6722         vv(1)=pizda(1,1)-pizda(2,2)
6723         vv(2)=pizda(1,2)+pizda(2,1)
6724         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6725      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6727         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6728         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6729         vv(1)=pizda(1,1)-pizda(2,2)
6730         vv(2)=pizda(1,2)+pizda(2,1)
6731         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6732      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6734 C Cartesian gradient
6735         do iii=1,2
6736           do kkk=1,5
6737             do lll=1,3
6738               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6739      &          pizda(1,1))
6740               vv(1)=pizda(1,1)-pizda(2,2)
6741               vv(2)=pizda(1,2)+pizda(2,1)
6742               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6743      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6744      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6745             enddo
6746           enddo
6747         enddo
6748 cd        goto 1112
6749         endif
6750 C Contribution from graph IV
6751 cd1110    continue
6752         call transpose2(EE(1,1,itl),auxmat(1,1))
6753         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6754         vv(1)=pizda(1,1)+pizda(2,2)
6755         vv(2)=pizda(2,1)-pizda(1,2)
6756         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6757      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6758         if (calc_grad) then
6759 C Explicit gradient in virtual-dihedral angles.
6760         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6761      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6762         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6763         vv(1)=pizda(1,1)+pizda(2,2)
6764         vv(2)=pizda(2,1)-pizda(1,2)
6765         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6766      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6767      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6768 C Cartesian gradient
6769         do iii=1,2
6770           do kkk=1,5
6771             do lll=1,3
6772               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6773      &          pizda(1,1))
6774               vv(1)=pizda(1,1)+pizda(2,2)
6775               vv(2)=pizda(2,1)-pizda(1,2)
6776               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6777      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6778      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6779             enddo
6780           enddo
6781         enddo
6782         endif
6783       else
6784 C Antiparallel orientation
6785 C Contribution from graph III
6786 c        goto 1110
6787         call transpose2(EUg(1,1,j),auxmat(1,1))
6788         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6789         vv(1)=pizda(1,1)-pizda(2,2)
6790         vv(2)=pizda(1,2)+pizda(2,1)
6791         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6792      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6793         if (calc_grad) then
6794 C Explicit gradient in virtual-dihedral angles.
6795         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6796      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6797      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6798         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6799         vv(1)=pizda(1,1)-pizda(2,2)
6800         vv(2)=pizda(1,2)+pizda(2,1)
6801         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6802      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6803      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6804         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6805         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6806         vv(1)=pizda(1,1)-pizda(2,2)
6807         vv(2)=pizda(1,2)+pizda(2,1)
6808         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6809      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6810      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6811 C Cartesian gradient
6812         do iii=1,2
6813           do kkk=1,5
6814             do lll=1,3
6815               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6816      &          pizda(1,1))
6817               vv(1)=pizda(1,1)-pizda(2,2)
6818               vv(2)=pizda(1,2)+pizda(2,1)
6819               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6820      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6821      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6822             enddo
6823           enddo
6824         enddo
6825 cd        goto 1112
6826         endif
6827 C Contribution from graph IV
6828 1110    continue
6829         call transpose2(EE(1,1,itj),auxmat(1,1))
6830         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6831         vv(1)=pizda(1,1)+pizda(2,2)
6832         vv(2)=pizda(2,1)-pizda(1,2)
6833         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6834      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6835         if (calc_grad) then
6836 C Explicit gradient in virtual-dihedral angles.
6837         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6838      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6839         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6840         vv(1)=pizda(1,1)+pizda(2,2)
6841         vv(2)=pizda(2,1)-pizda(1,2)
6842         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6843      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6844      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6845 C Cartesian gradient
6846         do iii=1,2
6847           do kkk=1,5
6848             do lll=1,3
6849               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6850      &          pizda(1,1))
6851               vv(1)=pizda(1,1)+pizda(2,2)
6852               vv(2)=pizda(2,1)-pizda(1,2)
6853               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6854      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6855      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6856             enddo
6857           enddo
6858         enddo
6859       endif
6860       endif
6861 1112  continue
6862       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6863 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6864 cd        write (2,*) 'ijkl',i,j,k,l
6865 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6866 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6867 cd      endif
6868 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6869 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6870 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6871 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6872       if (calc_grad) then
6873       if (j.lt.nres-1) then
6874         j1=j+1
6875         j2=j-1
6876       else
6877         j1=j-1
6878         j2=j-2
6879       endif
6880       if (l.lt.nres-1) then
6881         l1=l+1
6882         l2=l-1
6883       else
6884         l1=l-1
6885         l2=l-2
6886       endif
6887 cd      eij=1.0d0
6888 cd      ekl=1.0d0
6889 cd      ekont=1.0d0
6890 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6891       do ll=1,3
6892         ggg1(ll)=eel5*g_contij(ll,1)
6893         ggg2(ll)=eel5*g_contij(ll,2)
6894 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6895         ghalf=0.5d0*ggg1(ll)
6896 cd        ghalf=0.0d0
6897         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6898         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6899         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6900         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6901 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6902         ghalf=0.5d0*ggg2(ll)
6903 cd        ghalf=0.0d0
6904         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6905         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6906         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6907         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6908       enddo
6909 cd      goto 1112
6910       do m=i+1,j-1
6911         do ll=1,3
6912 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6913           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6914         enddo
6915       enddo
6916       do m=k+1,l-1
6917         do ll=1,3
6918 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6919           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6920         enddo
6921       enddo
6922 c1112  continue
6923       do m=i+2,j2
6924         do ll=1,3
6925           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6926         enddo
6927       enddo
6928       do m=k+2,l2
6929         do ll=1,3
6930           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6931         enddo
6932       enddo
6933 cd      do iii=1,nres-3
6934 cd        write (2,*) iii,g_corr5_loc(iii)
6935 cd      enddo
6936       endif
6937       eello5=ekont*eel5
6938 cd      write (2,*) 'ekont',ekont
6939 cd      write (iout,*) 'eello5',ekont*eel5
6940       return
6941       end
6942 c--------------------------------------------------------------------------
6943       double precision function eello6(i,j,k,l,jj,kk)
6944       implicit real*8 (a-h,o-z)
6945       include 'DIMENSIONS'
6946       include 'DIMENSIONS.ZSCOPT'
6947       include 'COMMON.IOUNITS'
6948       include 'COMMON.CHAIN'
6949       include 'COMMON.DERIV'
6950       include 'COMMON.INTERACT'
6951       include 'COMMON.CONTACTS'
6952       include 'COMMON.TORSION'
6953       include 'COMMON.VAR'
6954       include 'COMMON.GEO'
6955       include 'COMMON.FFIELD'
6956       double precision ggg1(3),ggg2(3)
6957 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6958 cd        eello6=0.0d0
6959 cd        return
6960 cd      endif
6961 cd      write (iout,*)
6962 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6963 cd     &   ' and',k,l
6964       eello6_1=0.0d0
6965       eello6_2=0.0d0
6966       eello6_3=0.0d0
6967       eello6_4=0.0d0
6968       eello6_5=0.0d0
6969       eello6_6=0.0d0
6970 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6971 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6972       do iii=1,2
6973         do kkk=1,5
6974           do lll=1,3
6975             derx(lll,kkk,iii)=0.0d0
6976           enddo
6977         enddo
6978       enddo
6979 cd      eij=facont_hb(jj,i)
6980 cd      ekl=facont_hb(kk,k)
6981 cd      ekont=eij*ekl
6982 cd      eij=1.0d0
6983 cd      ekl=1.0d0
6984 cd      ekont=1.0d0
6985       if (l.eq.j+1) then
6986         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6987         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6988         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6989         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6990         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6991         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6992       else
6993         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6994         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6995         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6996         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6997         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6998           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6999         else
7000           eello6_5=0.0d0
7001         endif
7002         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7003       endif
7004 C If turn contributions are considered, they will be handled separately.
7005       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7006 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7007 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7008 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7009 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7010 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7011 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7012 cd      goto 1112
7013       if (calc_grad) then
7014       if (j.lt.nres-1) then
7015         j1=j+1
7016         j2=j-1
7017       else
7018         j1=j-1
7019         j2=j-2
7020       endif
7021       if (l.lt.nres-1) then
7022         l1=l+1
7023         l2=l-1
7024       else
7025         l1=l-1
7026         l2=l-2
7027       endif
7028       do ll=1,3
7029         ggg1(ll)=eel6*g_contij(ll,1)
7030         ggg2(ll)=eel6*g_contij(ll,2)
7031 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7032         ghalf=0.5d0*ggg1(ll)
7033 cd        ghalf=0.0d0
7034         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7035         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7036         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7037         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7038         ghalf=0.5d0*ggg2(ll)
7039 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7040 cd        ghalf=0.0d0
7041         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7042         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7043         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7044         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7045       enddo
7046 cd      goto 1112
7047       do m=i+1,j-1
7048         do ll=1,3
7049 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7050           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7051         enddo
7052       enddo
7053       do m=k+1,l-1
7054         do ll=1,3
7055 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7056           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7057         enddo
7058       enddo
7059 1112  continue
7060       do m=i+2,j2
7061         do ll=1,3
7062           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7063         enddo
7064       enddo
7065       do m=k+2,l2
7066         do ll=1,3
7067           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7068         enddo
7069       enddo
7070 cd      do iii=1,nres-3
7071 cd        write (2,*) iii,g_corr6_loc(iii)
7072 cd      enddo
7073       endif
7074       eello6=ekont*eel6
7075 cd      write (2,*) 'ekont',ekont
7076 cd      write (iout,*) 'eello6',ekont*eel6
7077       return
7078       end
7079 c--------------------------------------------------------------------------
7080       double precision function eello6_graph1(i,j,k,l,imat,swap)
7081       implicit real*8 (a-h,o-z)
7082       include 'DIMENSIONS'
7083       include 'DIMENSIONS.ZSCOPT'
7084       include 'COMMON.IOUNITS'
7085       include 'COMMON.CHAIN'
7086       include 'COMMON.DERIV'
7087       include 'COMMON.INTERACT'
7088       include 'COMMON.CONTACTS'
7089       include 'COMMON.TORSION'
7090       include 'COMMON.VAR'
7091       include 'COMMON.GEO'
7092       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7093       logical swap
7094       logical lprn
7095       common /kutas/ lprn
7096 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7097 C                                                                              C
7098 C      Parallel       Antiparallel                                             C
7099 C                                                                              C
7100 C          o             o                                                     C
7101 C         /l\           /j\                                                    C
7102 C        /   \         /   \                                                   C
7103 C       /| o |         | o |\                                                  C
7104 C     \ j|/k\|  /   \  |/k\|l /                                                C
7105 C      \ /   \ /     \ /   \ /                                                 C
7106 C       o     o       o     o                                                  C
7107 C       i             i                                                        C
7108 C                                                                              C
7109 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7110       itk=itortyp(itype(k))
7111       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7112       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7113       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7114       call transpose2(EUgC(1,1,k),auxmat(1,1))
7115       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7116       vv1(1)=pizda1(1,1)-pizda1(2,2)
7117       vv1(2)=pizda1(1,2)+pizda1(2,1)
7118       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7119       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7120       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7121       s5=scalar2(vv(1),Dtobr2(1,i))
7122 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7123       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7124       if (.not. calc_grad) return
7125       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7126      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7127      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7128      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7129      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7130      & +scalar2(vv(1),Dtobr2der(1,i)))
7131       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7132       vv1(1)=pizda1(1,1)-pizda1(2,2)
7133       vv1(2)=pizda1(1,2)+pizda1(2,1)
7134       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7135       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7136       if (l.eq.j+1) then
7137         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7138      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7139      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7140      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7141      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7142       else
7143         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7144      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7145      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7146      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7147      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7148       endif
7149       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7150       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7151       vv1(1)=pizda1(1,1)-pizda1(2,2)
7152       vv1(2)=pizda1(1,2)+pizda1(2,1)
7153       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7154      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7155      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7156      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7157       do iii=1,2
7158         if (swap) then
7159           ind=3-iii
7160         else
7161           ind=iii
7162         endif
7163         do kkk=1,5
7164           do lll=1,3
7165             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7166             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7167             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7168             call transpose2(EUgC(1,1,k),auxmat(1,1))
7169             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7170      &        pizda1(1,1))
7171             vv1(1)=pizda1(1,1)-pizda1(2,2)
7172             vv1(2)=pizda1(1,2)+pizda1(2,1)
7173             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7174             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7175      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7176             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7177      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7178             s5=scalar2(vv(1),Dtobr2(1,i))
7179             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7180           enddo
7181         enddo
7182       enddo
7183       return
7184       end
7185 c----------------------------------------------------------------------------
7186       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7187       implicit real*8 (a-h,o-z)
7188       include 'DIMENSIONS'
7189       include 'DIMENSIONS.ZSCOPT'
7190       include 'COMMON.IOUNITS'
7191       include 'COMMON.CHAIN'
7192       include 'COMMON.DERIV'
7193       include 'COMMON.INTERACT'
7194       include 'COMMON.CONTACTS'
7195       include 'COMMON.TORSION'
7196       include 'COMMON.VAR'
7197       include 'COMMON.GEO'
7198       logical swap
7199       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7200      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7201       logical lprn
7202       common /kutas/ lprn
7203 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7204 C                                                                              C
7205 C      Parallel       Antiparallel                                             C
7206 C                                                                              C
7207 C          o             o                                                     C
7208 C     \   /l\           /j\   /                                                C
7209 C      \ /   \         /   \ /                                                 C
7210 C       o| o |         | o |o                                                  C
7211 C     \ j|/k\|      \  |/k\|l                                                  C
7212 C      \ /   \       \ /   \                                                   C
7213 C       o             o                                                        C
7214 C       i             i                                                        C
7215 C                                                                              C
7216 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7217 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7218 C AL 7/4/01 s1 would occur in the sixth-order moment,
7219 C           but not in a cluster cumulant
7220 #ifdef MOMENT
7221       s1=dip(1,jj,i)*dip(1,kk,k)
7222 #endif
7223       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7224       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7225       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7226       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7227       call transpose2(EUg(1,1,k),auxmat(1,1))
7228       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7229       vv(1)=pizda(1,1)-pizda(2,2)
7230       vv(2)=pizda(1,2)+pizda(2,1)
7231       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7232 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7233 #ifdef MOMENT
7234       eello6_graph2=-(s1+s2+s3+s4)
7235 #else
7236       eello6_graph2=-(s2+s3+s4)
7237 #endif
7238 c      eello6_graph2=-s3
7239       if (.not. calc_grad) return
7240 C Derivatives in gamma(i-1)
7241       if (i.gt.1) then
7242 #ifdef MOMENT
7243         s1=dipderg(1,jj,i)*dip(1,kk,k)
7244 #endif
7245         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7246         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7247         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7248         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7249 #ifdef MOMENT
7250         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7251 #else
7252         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7253 #endif
7254 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7255       endif
7256 C Derivatives in gamma(k-1)
7257 #ifdef MOMENT
7258       s1=dip(1,jj,i)*dipderg(1,kk,k)
7259 #endif
7260       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7261       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7262       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7263       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7264       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7265       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7266       vv(1)=pizda(1,1)-pizda(2,2)
7267       vv(2)=pizda(1,2)+pizda(2,1)
7268       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7269 #ifdef MOMENT
7270       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7271 #else
7272       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7273 #endif
7274 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7275 C Derivatives in gamma(j-1) or gamma(l-1)
7276       if (j.gt.1) then
7277 #ifdef MOMENT
7278         s1=dipderg(3,jj,i)*dip(1,kk,k)
7279 #endif
7280         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7281         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7282         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7283         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7284         vv(1)=pizda(1,1)-pizda(2,2)
7285         vv(2)=pizda(1,2)+pizda(2,1)
7286         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7287 #ifdef MOMENT
7288         if (swap) then
7289           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7290         else
7291           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7292         endif
7293 #endif
7294         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7295 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7296       endif
7297 C Derivatives in gamma(l-1) or gamma(j-1)
7298       if (l.gt.1) then
7299 #ifdef MOMENT
7300         s1=dip(1,jj,i)*dipderg(3,kk,k)
7301 #endif
7302         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7303         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7304         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7305         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7306         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7307         vv(1)=pizda(1,1)-pizda(2,2)
7308         vv(2)=pizda(1,2)+pizda(2,1)
7309         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7310 #ifdef MOMENT
7311         if (swap) then
7312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7313         else
7314           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7315         endif
7316 #endif
7317         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7318 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7319       endif
7320 C Cartesian derivatives.
7321       if (lprn) then
7322         write (2,*) 'In eello6_graph2'
7323         do iii=1,2
7324           write (2,*) 'iii=',iii
7325           do kkk=1,5
7326             write (2,*) 'kkk=',kkk
7327             do jjj=1,2
7328               write (2,'(3(2f10.5),5x)')
7329      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7330             enddo
7331           enddo
7332         enddo
7333       endif
7334       do iii=1,2
7335         do kkk=1,5
7336           do lll=1,3
7337 #ifdef MOMENT
7338             if (iii.eq.1) then
7339               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7340             else
7341               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7342             endif
7343 #endif
7344             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7345      &        auxvec(1))
7346             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7347             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7348      &        auxvec(1))
7349             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7350             call transpose2(EUg(1,1,k),auxmat(1,1))
7351             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7352      &        pizda(1,1))
7353             vv(1)=pizda(1,1)-pizda(2,2)
7354             vv(2)=pizda(1,2)+pizda(2,1)
7355             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7356 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7357 #ifdef MOMENT
7358             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7359 #else
7360             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7361 #endif
7362             if (swap) then
7363               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7364             else
7365               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7366             endif
7367           enddo
7368         enddo
7369       enddo
7370       return
7371       end
7372 c----------------------------------------------------------------------------
7373       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7374       implicit real*8 (a-h,o-z)
7375       include 'DIMENSIONS'
7376       include 'DIMENSIONS.ZSCOPT'
7377       include 'COMMON.IOUNITS'
7378       include 'COMMON.CHAIN'
7379       include 'COMMON.DERIV'
7380       include 'COMMON.INTERACT'
7381       include 'COMMON.CONTACTS'
7382       include 'COMMON.TORSION'
7383       include 'COMMON.VAR'
7384       include 'COMMON.GEO'
7385       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7386       logical swap
7387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7388 C                                                                              C
7389 C      Parallel       Antiparallel                                             C
7390 C                                                                              C
7391 C          o             o                                                     C
7392 C         /l\   /   \   /j\                                                    C
7393 C        /   \ /     \ /   \                                                   C
7394 C       /| o |o       o| o |\                                                  C
7395 C       j|/k\|  /      |/k\|l /                                                C
7396 C        /   \ /       /   \ /                                                 C
7397 C       /     o       /     o                                                  C
7398 C       i             i                                                        C
7399 C                                                                              C
7400 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7401 C
7402 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7403 C           energy moment and not to the cluster cumulant.
7404       iti=itortyp(itype(i))
7405       if (j.lt.nres-1) then
7406         itj1=itortyp(itype(j+1))
7407       else
7408         itj1=ntortyp+1
7409       endif
7410       itk=itortyp(itype(k))
7411       itk1=itortyp(itype(k+1))
7412       if (l.lt.nres-1) then
7413         itl1=itortyp(itype(l+1))
7414       else
7415         itl1=ntortyp+1
7416       endif
7417 #ifdef MOMENT
7418       s1=dip(4,jj,i)*dip(4,kk,k)
7419 #endif
7420       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7421       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7422       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7423       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7424       call transpose2(EE(1,1,itk),auxmat(1,1))
7425       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7426       vv(1)=pizda(1,1)+pizda(2,2)
7427       vv(2)=pizda(2,1)-pizda(1,2)
7428       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7429 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7430 #ifdef MOMENT
7431       eello6_graph3=-(s1+s2+s3+s4)
7432 #else
7433       eello6_graph3=-(s2+s3+s4)
7434 #endif
7435 c      eello6_graph3=-s4
7436       if (.not. calc_grad) return
7437 C Derivatives in gamma(k-1)
7438       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7439       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7440       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7441       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7442 C Derivatives in gamma(l-1)
7443       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7444       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7445       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7446       vv(1)=pizda(1,1)+pizda(2,2)
7447       vv(2)=pizda(2,1)-pizda(1,2)
7448       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7449       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7450 C Cartesian derivatives.
7451       do iii=1,2
7452         do kkk=1,5
7453           do lll=1,3
7454 #ifdef MOMENT
7455             if (iii.eq.1) then
7456               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7457             else
7458               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7459             endif
7460 #endif
7461             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7462      &        auxvec(1))
7463             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7464             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7465      &        auxvec(1))
7466             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7467             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7468      &        pizda(1,1))
7469             vv(1)=pizda(1,1)+pizda(2,2)
7470             vv(2)=pizda(2,1)-pizda(1,2)
7471             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7472 #ifdef MOMENT
7473             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7474 #else
7475             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7476 #endif
7477             if (swap) then
7478               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7479             else
7480               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7481             endif
7482 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7483           enddo
7484         enddo
7485       enddo
7486       return
7487       end
7488 c----------------------------------------------------------------------------
7489       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7490       implicit real*8 (a-h,o-z)
7491       include 'DIMENSIONS'
7492       include 'DIMENSIONS.ZSCOPT'
7493       include 'COMMON.IOUNITS'
7494       include 'COMMON.CHAIN'
7495       include 'COMMON.DERIV'
7496       include 'COMMON.INTERACT'
7497       include 'COMMON.CONTACTS'
7498       include 'COMMON.TORSION'
7499       include 'COMMON.VAR'
7500       include 'COMMON.GEO'
7501       include 'COMMON.FFIELD'
7502       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7503      & auxvec1(2),auxmat1(2,2)
7504       logical swap
7505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7506 C                                                                              C
7507 C      Parallel       Antiparallel                                             C
7508 C                                                                              C
7509 C          o             o                                                     C
7510 C         /l\   /   \   /j\                                                    C
7511 C        /   \ /     \ /   \                                                   C
7512 C       /| o |o       o| o |\                                                  C
7513 C     \ j|/k\|      \  |/k\|l                                                  C
7514 C      \ /   \       \ /   \                                                   C
7515 C       o     \       o     \                                                  C
7516 C       i             i                                                        C
7517 C                                                                              C
7518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7519 C
7520 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7521 C           energy moment and not to the cluster cumulant.
7522 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7523       iti=itortyp(itype(i))
7524       itj=itortyp(itype(j))
7525       if (j.lt.nres-1) then
7526         itj1=itortyp(itype(j+1))
7527       else
7528         itj1=ntortyp+1
7529       endif
7530       itk=itortyp(itype(k))
7531       if (k.lt.nres-1) then
7532         itk1=itortyp(itype(k+1))
7533       else
7534         itk1=ntortyp+1
7535       endif
7536       itl=itortyp(itype(l))
7537       if (l.lt.nres-1) then
7538         itl1=itortyp(itype(l+1))
7539       else
7540         itl1=ntortyp+1
7541       endif
7542 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7543 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7544 cd     & ' itl',itl,' itl1',itl1
7545 #ifdef MOMENT
7546       if (imat.eq.1) then
7547         s1=dip(3,jj,i)*dip(3,kk,k)
7548       else
7549         s1=dip(2,jj,j)*dip(2,kk,l)
7550       endif
7551 #endif
7552       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7553       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7554       if (j.eq.l+1) then
7555         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7556         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7557       else
7558         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7559         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7560       endif
7561       call transpose2(EUg(1,1,k),auxmat(1,1))
7562       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7563       vv(1)=pizda(1,1)-pizda(2,2)
7564       vv(2)=pizda(2,1)+pizda(1,2)
7565       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7566 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7567 #ifdef MOMENT
7568       eello6_graph4=-(s1+s2+s3+s4)
7569 #else
7570       eello6_graph4=-(s2+s3+s4)
7571 #endif
7572       if (.not. calc_grad) return
7573 C Derivatives in gamma(i-1)
7574       if (i.gt.1) then
7575 #ifdef MOMENT
7576         if (imat.eq.1) then
7577           s1=dipderg(2,jj,i)*dip(3,kk,k)
7578         else
7579           s1=dipderg(4,jj,j)*dip(2,kk,l)
7580         endif
7581 #endif
7582         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7583         if (j.eq.l+1) then
7584           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7585           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7586         else
7587           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7588           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7589         endif
7590         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7591         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7592 cd          write (2,*) 'turn6 derivatives'
7593 #ifdef MOMENT
7594           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7595 #else
7596           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7597 #endif
7598         else
7599 #ifdef MOMENT
7600           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7601 #else
7602           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7603 #endif
7604         endif
7605       endif
7606 C Derivatives in gamma(k-1)
7607 #ifdef MOMENT
7608       if (imat.eq.1) then
7609         s1=dip(3,jj,i)*dipderg(2,kk,k)
7610       else
7611         s1=dip(2,jj,j)*dipderg(4,kk,l)
7612       endif
7613 #endif
7614       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7615       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7616       if (j.eq.l+1) then
7617         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7618         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7619       else
7620         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7621         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7622       endif
7623       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7624       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7625       vv(1)=pizda(1,1)-pizda(2,2)
7626       vv(2)=pizda(2,1)+pizda(1,2)
7627       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7628       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7629 #ifdef MOMENT
7630         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7631 #else
7632         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7633 #endif
7634       else
7635 #ifdef MOMENT
7636         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7637 #else
7638         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7639 #endif
7640       endif
7641 C Derivatives in gamma(j-1) or gamma(l-1)
7642       if (l.eq.j+1 .and. l.gt.1) then
7643         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7644         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7645         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7646         vv(1)=pizda(1,1)-pizda(2,2)
7647         vv(2)=pizda(2,1)+pizda(1,2)
7648         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7649         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7650       else if (j.gt.1) then
7651         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7652         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7653         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7654         vv(1)=pizda(1,1)-pizda(2,2)
7655         vv(2)=pizda(2,1)+pizda(1,2)
7656         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7657         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7658           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7659         else
7660           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7661         endif
7662       endif
7663 C Cartesian derivatives.
7664       do iii=1,2
7665         do kkk=1,5
7666           do lll=1,3
7667 #ifdef MOMENT
7668             if (iii.eq.1) then
7669               if (imat.eq.1) then
7670                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7671               else
7672                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7673               endif
7674             else
7675               if (imat.eq.1) then
7676                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7677               else
7678                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7679               endif
7680             endif
7681 #endif
7682             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7683      &        auxvec(1))
7684             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7685             if (j.eq.l+1) then
7686               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7687      &          b1(1,itj1),auxvec(1))
7688               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7689             else
7690               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7691      &          b1(1,itl1),auxvec(1))
7692               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7693             endif
7694             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7695      &        pizda(1,1))
7696             vv(1)=pizda(1,1)-pizda(2,2)
7697             vv(2)=pizda(2,1)+pizda(1,2)
7698             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7699             if (swap) then
7700               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7701 #ifdef MOMENT
7702                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7703      &             -(s1+s2+s4)
7704 #else
7705                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7706      &             -(s2+s4)
7707 #endif
7708                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7709               else
7710 #ifdef MOMENT
7711                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7712 #else
7713                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7714 #endif
7715                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7716               endif
7717             else
7718 #ifdef MOMENT
7719               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7720 #else
7721               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7722 #endif
7723               if (l.eq.j+1) then
7724                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7725               else
7726                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7727               endif
7728             endif
7729           enddo
7730         enddo
7731       enddo
7732       return
7733       end
7734 c----------------------------------------------------------------------------
7735       double precision function eello_turn6(i,jj,kk)
7736       implicit real*8 (a-h,o-z)
7737       include 'DIMENSIONS'
7738       include 'DIMENSIONS.ZSCOPT'
7739       include 'COMMON.IOUNITS'
7740       include 'COMMON.CHAIN'
7741       include 'COMMON.DERIV'
7742       include 'COMMON.INTERACT'
7743       include 'COMMON.CONTACTS'
7744       include 'COMMON.TORSION'
7745       include 'COMMON.VAR'
7746       include 'COMMON.GEO'
7747       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7748      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7749      &  ggg1(3),ggg2(3)
7750       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7751      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7752 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7753 C           the respective energy moment and not to the cluster cumulant.
7754       eello_turn6=0.0d0
7755       j=i+4
7756       k=i+1
7757       l=i+3
7758       iti=itortyp(itype(i))
7759       itk=itortyp(itype(k))
7760       itk1=itortyp(itype(k+1))
7761       itl=itortyp(itype(l))
7762       itj=itortyp(itype(j))
7763 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7764 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7765 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7766 cd        eello6=0.0d0
7767 cd        return
7768 cd      endif
7769 cd      write (iout,*)
7770 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7771 cd     &   ' and',k,l
7772 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7773       do iii=1,2
7774         do kkk=1,5
7775           do lll=1,3
7776             derx_turn(lll,kkk,iii)=0.0d0
7777           enddo
7778         enddo
7779       enddo
7780 cd      eij=1.0d0
7781 cd      ekl=1.0d0
7782 cd      ekont=1.0d0
7783       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7784 cd      eello6_5=0.0d0
7785 cd      write (2,*) 'eello6_5',eello6_5
7786 #ifdef MOMENT
7787       call transpose2(AEA(1,1,1),auxmat(1,1))
7788       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7789       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7790       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7791 #else
7792       s1 = 0.0d0
7793 #endif
7794       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7795       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7796       s2 = scalar2(b1(1,itk),vtemp1(1))
7797 #ifdef MOMENT
7798       call transpose2(AEA(1,1,2),atemp(1,1))
7799       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7800       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7801       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7802 #else
7803       s8=0.0d0
7804 #endif
7805       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7806       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7807       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7808 #ifdef MOMENT
7809       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7810       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7811       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7812       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7813       ss13 = scalar2(b1(1,itk),vtemp4(1))
7814       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7815 #else
7816       s13=0.0d0
7817 #endif
7818 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7819 c      s1=0.0d0
7820 c      s2=0.0d0
7821 c      s8=0.0d0
7822 c      s12=0.0d0
7823 c      s13=0.0d0
7824       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7825       if (calc_grad) then
7826 C Derivatives in gamma(i+2)
7827 #ifdef MOMENT
7828       call transpose2(AEA(1,1,1),auxmatd(1,1))
7829       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7830       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7831       call transpose2(AEAderg(1,1,2),atempd(1,1))
7832       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7833       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7834 #else
7835       s8d=0.0d0
7836 #endif
7837       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7838       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7839       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7840 c      s1d=0.0d0
7841 c      s2d=0.0d0
7842 c      s8d=0.0d0
7843 c      s12d=0.0d0
7844 c      s13d=0.0d0
7845       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7846 C Derivatives in gamma(i+3)
7847 #ifdef MOMENT
7848       call transpose2(AEA(1,1,1),auxmatd(1,1))
7849       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7850       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7851       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7852 #else
7853       s1d=0.0d0
7854 #endif
7855       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7856       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7857       s2d = scalar2(b1(1,itk),vtemp1d(1))
7858 #ifdef MOMENT
7859       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7860       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7861 #endif
7862       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7863 #ifdef MOMENT
7864       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7865       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7866       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7867 #else
7868       s13d=0.0d0
7869 #endif
7870 c      s1d=0.0d0
7871 c      s2d=0.0d0
7872 c      s8d=0.0d0
7873 c      s12d=0.0d0
7874 c      s13d=0.0d0
7875 #ifdef MOMENT
7876       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7877      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7878 #else
7879       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7880      &               -0.5d0*ekont*(s2d+s12d)
7881 #endif
7882 C Derivatives in gamma(i+4)
7883       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7884       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7885       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7886 #ifdef MOMENT
7887       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7888       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7889       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7890 #else
7891       s13d = 0.0d0
7892 #endif
7893 c      s1d=0.0d0
7894 c      s2d=0.0d0
7895 c      s8d=0.0d0
7896 C      s12d=0.0d0
7897 c      s13d=0.0d0
7898 #ifdef MOMENT
7899       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7900 #else
7901       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7902 #endif
7903 C Derivatives in gamma(i+5)
7904 #ifdef MOMENT
7905       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7906       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7907       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7908 #else
7909       s1d = 0.0d0
7910 #endif
7911       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7912       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7913       s2d = scalar2(b1(1,itk),vtemp1d(1))
7914 #ifdef MOMENT
7915       call transpose2(AEA(1,1,2),atempd(1,1))
7916       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7917       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7918 #else
7919       s8d = 0.0d0
7920 #endif
7921       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7922       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7923 #ifdef MOMENT
7924       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7925       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7926       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7927 #else
7928       s13d = 0.0d0
7929 #endif
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       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7937      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7938 #else
7939       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7940      &               -0.5d0*ekont*(s2d+s12d)
7941 #endif
7942 C Cartesian derivatives
7943       do iii=1,2
7944         do kkk=1,5
7945           do lll=1,3
7946 #ifdef MOMENT
7947             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7948             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7949             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7950 #else
7951             s1d = 0.0d0
7952 #endif
7953             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7954             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7955      &          vtemp1d(1))
7956             s2d = scalar2(b1(1,itk),vtemp1d(1))
7957 #ifdef MOMENT
7958             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7959             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7960             s8d = -(atempd(1,1)+atempd(2,2))*
7961      &           scalar2(cc(1,1,itl),vtemp2(1))
7962 #else
7963             s8d = 0.0d0
7964 #endif
7965             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7966      &           auxmatd(1,1))
7967             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7968             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7969 c      s1d=0.0d0
7970 c      s2d=0.0d0
7971 c      s8d=0.0d0
7972 c      s12d=0.0d0
7973 c      s13d=0.0d0
7974 #ifdef MOMENT
7975             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7976      &        - 0.5d0*(s1d+s2d)
7977 #else
7978             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7979      &        - 0.5d0*s2d
7980 #endif
7981 #ifdef MOMENT
7982             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7983      &        - 0.5d0*(s8d+s12d)
7984 #else
7985             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7986      &        - 0.5d0*s12d
7987 #endif
7988           enddo
7989         enddo
7990       enddo
7991 #ifdef MOMENT
7992       do kkk=1,5
7993         do lll=1,3
7994           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7995      &      achuj_tempd(1,1))
7996           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7997           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7998           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7999           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8000           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8001      &      vtemp4d(1))
8002           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8003           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8004           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8005         enddo
8006       enddo
8007 #endif
8008 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8009 cd     &  16*eel_turn6_num
8010 cd      goto 1112
8011       if (j.lt.nres-1) then
8012         j1=j+1
8013         j2=j-1
8014       else
8015         j1=j-1
8016         j2=j-2
8017       endif
8018       if (l.lt.nres-1) then
8019         l1=l+1
8020         l2=l-1
8021       else
8022         l1=l-1
8023         l2=l-2
8024       endif
8025       do ll=1,3
8026         ggg1(ll)=eel_turn6*g_contij(ll,1)
8027         ggg2(ll)=eel_turn6*g_contij(ll,2)
8028         ghalf=0.5d0*ggg1(ll)
8029 cd        ghalf=0.0d0
8030         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8031      &    +ekont*derx_turn(ll,2,1)
8032         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8033         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8034      &    +ekont*derx_turn(ll,4,1)
8035         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8036         ghalf=0.5d0*ggg2(ll)
8037 cd        ghalf=0.0d0
8038         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8039      &    +ekont*derx_turn(ll,2,2)
8040         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8041         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8042      &    +ekont*derx_turn(ll,4,2)
8043         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8044       enddo
8045 cd      goto 1112
8046       do m=i+1,j-1
8047         do ll=1,3
8048           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8049         enddo
8050       enddo
8051       do m=k+1,l-1
8052         do ll=1,3
8053           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8054         enddo
8055       enddo
8056 1112  continue
8057       do m=i+2,j2
8058         do ll=1,3
8059           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8060         enddo
8061       enddo
8062       do m=k+2,l2
8063         do ll=1,3
8064           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8065         enddo
8066       enddo
8067 cd      do iii=1,nres-3
8068 cd        write (2,*) iii,g_corr6_loc(iii)
8069 cd      enddo
8070       endif
8071       eello_turn6=ekont*eel_turn6
8072 cd      write (2,*) 'ekont',ekont
8073 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8074       return
8075       end
8076 crc-------------------------------------------------
8077       SUBROUTINE MATVEC2(A1,V1,V2)
8078       implicit real*8 (a-h,o-z)
8079       include 'DIMENSIONS'
8080       DIMENSION A1(2,2),V1(2),V2(2)
8081 c      DO 1 I=1,2
8082 c        VI=0.0
8083 c        DO 3 K=1,2
8084 c    3     VI=VI+A1(I,K)*V1(K)
8085 c        Vaux(I)=VI
8086 c    1 CONTINUE
8087
8088       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8089       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8090
8091       v2(1)=vaux1
8092       v2(2)=vaux2
8093       END
8094 C---------------------------------------
8095       SUBROUTINE MATMAT2(A1,A2,A3)
8096       implicit real*8 (a-h,o-z)
8097       include 'DIMENSIONS'
8098       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8099 c      DIMENSION AI3(2,2)
8100 c        DO  J=1,2
8101 c          A3IJ=0.0
8102 c          DO K=1,2
8103 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8104 c          enddo
8105 c          A3(I,J)=A3IJ
8106 c       enddo
8107 c      enddo
8108
8109       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8110       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8111       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8112       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8113
8114       A3(1,1)=AI3_11
8115       A3(2,1)=AI3_21
8116       A3(1,2)=AI3_12
8117       A3(2,2)=AI3_22
8118       END
8119
8120 c-------------------------------------------------------------------------
8121       double precision function scalar2(u,v)
8122       implicit none
8123       double precision u(2),v(2)
8124       double precision sc
8125       integer i
8126       scalar2=u(1)*v(1)+u(2)*v(2)
8127       return
8128       end
8129
8130 C-----------------------------------------------------------------------------
8131
8132       subroutine transpose2(a,at)
8133       implicit none
8134       double precision a(2,2),at(2,2)
8135       at(1,1)=a(1,1)
8136       at(1,2)=a(2,1)
8137       at(2,1)=a(1,2)
8138       at(2,2)=a(2,2)
8139       return
8140       end
8141 c--------------------------------------------------------------------------
8142       subroutine transpose(n,a,at)
8143       implicit none
8144       integer n,i,j
8145       double precision a(n,n),at(n,n)
8146       do i=1,n
8147         do j=1,n
8148           at(j,i)=a(i,j)
8149         enddo
8150       enddo
8151       return
8152       end
8153 C---------------------------------------------------------------------------
8154       subroutine prodmat3(a1,a2,kk,transp,prod)
8155       implicit none
8156       integer i,j
8157       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8158       logical transp
8159 crc      double precision auxmat(2,2),prod_(2,2)
8160
8161       if (transp) then
8162 crc        call transpose2(kk(1,1),auxmat(1,1))
8163 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8164 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8165
8166            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8167      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8168            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8169      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8170            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8171      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8172            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8173      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8174
8175       else
8176 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8177 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8178
8179            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8180      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8181            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8182      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8183            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8184      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8185            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8186      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8187
8188       endif
8189 c      call transpose2(a2(1,1),a2t(1,1))
8190
8191 crc      print *,transp
8192 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8193 crc      print *,((prod(i,j),i=1,2),j=1,2)
8194
8195       return
8196       end
8197 C-----------------------------------------------------------------------------
8198       double precision function scalar(u,v)
8199       implicit none
8200       double precision u(3),v(3)
8201       double precision sc
8202       integer i
8203       sc=0.0d0
8204       do i=1,3
8205         sc=sc+u(i)*v(i)
8206       enddo
8207       scalar=sc
8208       return
8209       end
8210