source/wham/src/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       endif
 104       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 105          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 106       endif
 107
 108
 109 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 110       if (constr_homology.ge.1) then
 111         call e_modeller(ehomology_constr)
 112       else
 113         ehomology_constr=0.0d0
 114       endif
 115
 116 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 117
 118 C     BARTEK for dfa test!
 119       if (wdfa_dist.gt.0) call edfad(edfadis)
 120 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 121       if (wdfa_tor.gt.0) call edfat(edfator)
 122 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 123       if (wdfa_nei.gt.0) call edfan(edfanei)
 124 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 125       if (wdfa_beta.gt.0) call edfab(edfabet)
 126 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 127
 128 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 129 #ifdef SPLITELE
 130       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 131      & +wvdwpp*evdw1
 132      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 133      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 134      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 135      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 136      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 137      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 138      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 139      & +wdfa_beta*edfabet
 140 #else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 142      & +welec*fact(1)*(ees+evdw1)
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor!+ehomology_constr
 149      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 150      & +wdfa_beta*edfabet
 151 #endif
 152       energia(0)=etot
 153       energia(1)=evdw
 154 #ifdef SCP14
 155       energia(2)=evdw2-evdw2_14
 156       energia(17)=evdw2_14
 157 #else
 158       energia(2)=evdw2
 159       energia(17)=0.0d0
 160 #endif
 161 #ifdef SPLITELE
 162       energia(3)=ees
 163       energia(16)=evdw1
 164 #else
 165       energia(3)=ees+evdw1
 166       energia(16)=0.0d0
 167 #endif
 168       energia(4)=ecorr
 169       energia(5)=ecorr5
 170       energia(6)=ecorr6
 171       energia(7)=eel_loc
 172       energia(8)=eello_turn3
 173       energia(9)=eello_turn4
 174       energia(10)=eturn6
 175       energia(11)=ebe
 176       energia(12)=escloc
 177       energia(13)=etors
 178       energia(14)=etors_d
 179       energia(15)=ehpb
 180       energia(18)=estr
 181       energia(19)=esccor
 182       energia(20)=edihcnstr
 183       energia(21)=evdw_t
 184       energia(22)=ehomology_constr
 185       energia(23)=edfadis
 186       energia(24)=edfator
 187       energia(25)=edfanei
 188       energia(26)=edfabet
 189 c      if (dyn_ss) call dyn_set_nss
 190 c detecting NaNQ
 191 #ifdef ISNAN
 192 #ifdef AIX
 193       if (isnan(etot).ne.0) energia(0)=1.0d+99
 194 #else
 195       if (isnan(etot)) energia(0)=1.0d+99
 196 #endif
 197 #else
 198       i=0
 199 #ifdef WINPGI
 200       idumm=proc_proc(etot,i)
 201 #else
 202       call proc_proc(etot,i)
 203 #endif
 204       if(i.eq.1)energia(0)=1.0d+99
 205 #endif
 206 #ifdef MPL
 207 c     endif
 208 #endif
 209       if (calc_grad) then
 210 C
 211 C Sum up the components of the Cartesian gradient.
 212 C
 213 #ifdef SPLITELE
 214       do i=1,nct
 215         do j=1,3
 216           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 217      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 218      &                wbond*gradb(j,i)+
 219      &                wstrain*ghpbc(j,i)+
 220      &                wcorr*fact(3)*gradcorr(j,i)+
 221      &                wel_loc*fact(2)*gel_loc(j,i)+
 222      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 223      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 224      &                wcorr5*fact(4)*gradcorr5(j,i)+
 225      &                wcorr6*fact(5)*gradcorr6(j,i)+
 226      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 227      &                wsccor*fact(2)*gsccorc(j,i)+
 228      &                wdfa_dist*gdfad(j,i)+
 229      &                wdfa_tor*gdfat(j,i)+
 230      &                wdfa_nei*gdfan(j,i)+
 231      &                wdfa_beta*gdfab(j,i)
 232           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 233      &                  wbond*gradbx(j,i)+
 234      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 235      &                  wsccor*fact(2)*gsccorx(j,i)
 236         enddo
 237 #else
 238       do i=1,nct
 239         do j=1,3
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wcorr*fact(3)*gradcorr(j,i)+
 244      &                wel_loc*fact(2)*gel_loc(j,i)+
 245      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 246      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 247      &                wcorr5*fact(4)*gradcorr5(j,i)+
 248      &                wcorr6*fact(5)*gradcorr6(j,i)+
 249      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 250      &                wsccor*fact(2)*gsccorc(j,i)+
 251      &                wdfa_dist*gdfad(j,i)+
 252      &                wdfa_tor*gdfat(j,i)+
 253      &                wdfa_nei*gdfan(j,i)+
 254      &                wdfa_beta*gdfab(j,i)
 255           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 256      &                  wbond*gradbx(j,i)+
 257      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 258      &                  wsccor*fact(1)*gsccorx(j,i)
 259         enddo
 260 #endif
 261       enddo
 262
 263
 264       do i=1,nres-3
 265         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 266      &   +wcorr5*fact(4)*g_corr5_loc(i)
 267      &   +wcorr6*fact(5)*g_corr6_loc(i)
 268      &   +wturn4*fact(3)*gel_loc_turn4(i)
 269      &   +wturn3*fact(2)*gel_loc_turn3(i)
 270      &   +wturn6*fact(5)*gel_loc_turn6(i)
 271      &   +wel_loc*fact(2)*gel_loc_loc(i)
 272      &   +wsccor*fact(1)*gsccor_loc(i)
 273       enddo
 274       endif
 275       return
 276       end
 277 C------------------------------------------------------------------------
 278       subroutine enerprint(energia,fact)
 279       implicit real*8 (a-h,o-z)
 280       include 'DIMENSIONS'
 281       include 'DIMENSIONS.ZSCOPT'
 282       include 'COMMON.IOUNITS'
 283       include 'COMMON.FFIELD'
 284       include 'COMMON.SBRIDGE'
 285       double precision energia(0:max_ene),fact(6)
 286       etot=energia(0)
 287       evdw=energia(1)+fact(6)*energia(21)
 288 #ifdef SCP14
 289       evdw2=energia(2)+energia(17)
 290 #else
 291       evdw2=energia(2)
 292 #endif
 293       ees=energia(3)
 294 #ifdef SPLITELE
 295       evdw1=energia(16)
 296 #endif
 297       ecorr=energia(4)
 298       ecorr5=energia(5)
 299       ecorr6=energia(6)
 300       eel_loc=energia(7)
 301       eello_turn3=energia(8)
 302       eello_turn4=energia(9)
 303       eello_turn6=energia(10)
 304       ebe=energia(11)
 305       escloc=energia(12)
 306       etors=energia(13)
 307       etors_d=energia(14)
 308       ehpb=energia(15)
 309       esccor=energia(19)
 310       edihcnstr=energia(20)
 311       estr=energia(18)
 312       ehomology_constr=energia(22)
 313       edfadis=energia(23)
 314       edfator=energia(24)
 315       edfanei=energia(25)
 316       edfabet=energia(26)
 317 #ifdef SPLITELE
 318       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 319      &  wvdwpp,
 320      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 321      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 322      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 323      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 324      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 325      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 326      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 327      &  wdfa_beta,etot
 328    10 format (/'Virtual-chain energies:'//
 329      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 330      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 331      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 332      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 333      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 334      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 335      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 336      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 337      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 338      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 339      & ' (SS bridges & dist. cnstr.)'/
 340      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 343      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 344      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 345      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 346      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 347      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 348      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 349      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 350      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 351      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 352      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 353      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 354      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 355      & 'ETOT=  ',1pE16.6,' (total)')
 356 #else
 357       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 358      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 359      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 360      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 361      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 362      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 363      &  edihcnstr,ehomology_constr,ebr*nss,
 364      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 365      &  wdfa_beta,etot
 366    10 format (/'Virtual-chain energies:'//
 367      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 368      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 369      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 370      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 371      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 372      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 373      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 374      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 375      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 376      & ' (SS bridges & dist. cnstr.)'/
 377      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 380      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 381      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 382      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 383      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 384      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 385      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 386      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 387      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 388      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 389      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 390      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 391      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 392      & 'ETOT=  ',1pE16.6,' (total)')
 393 #endif
 394       return
 395       end
 396 C-----------------------------------------------------------------------
 397       subroutine elj(evdw,evdw_t)
 398 C
 399 C This subroutine calculates the interaction energy of nonbonded side chains
 400 C assuming the LJ potential of interaction.
 401 C
 402       implicit real*8 (a-h,o-z)
 403       include 'DIMENSIONS'
 404       include 'DIMENSIONS.ZSCOPT'
 405       include "DIMENSIONS.COMPAR"
 406       parameter (accur=1.0d-10)
 407       include 'COMMON.GEO'
 408       include 'COMMON.VAR'
 409       include 'COMMON.LOCAL'
 410       include 'COMMON.CHAIN'
 411       include 'COMMON.DERIV'
 412       include 'COMMON.INTERACT'
 413       include 'COMMON.TORSION'
 414       include 'COMMON.ENEPS'
 415       include 'COMMON.SBRIDGE'
 416       include 'COMMON.NAMES'
 417       include 'COMMON.IOUNITS'
 418       include 'COMMON.CONTACTS'
 419       dimension gg(3)
 420       integer icant
 421       external icant
 422 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 423       do i=1,210
 424         do j=1,2
 425           eneps_temp(j,i)=0.0d0
 426         enddo
 427       enddo
 428       evdw=0.0D0
 429       evdw_t=0.0d0
 430       do i=iatsc_s,iatsc_e
 431         itypi=itype(i)
 432         itypi1=itype(i+1)
 433         xi=c(1,nres+i)
 434         yi=c(2,nres+i)
 435         zi=c(3,nres+i)
 436 C Change 12/1/95
 437         num_conti=0
 438 C
 439 C Calculate SC interaction energy.
 440 C
 441         do iint=1,nint_gr(i)
 442 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 443 cd   &                  'iend=',iend(i,iint)
 444           do j=istart(i,iint),iend(i,iint)
 445             itypj=itype(j)
 446             xj=c(1,nres+j)-xi
 447             yj=c(2,nres+j)-yi
 448             zj=c(3,nres+j)-zi
 449 C Change 12/1/95 to calculate four-body interactions
 450             rij=xj*xj+yj*yj+zj*zj
 451             rrij=1.0D0/rij
 452 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 453             eps0ij=eps(itypi,itypj)
 454             fac=rrij**expon2
 455             e1=fac*fac*aa(itypi,itypj)
 456             e2=fac*bb(itypi,itypj)
 457             evdwij=e1+e2
 458             ij=icant(itypi,itypj)
 459             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 460             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 461 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 462 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 463 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 464 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 465 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 466 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 467             if (bb(itypi,itypj).gt.0.0d0) then
 468               evdw=evdw+evdwij
 469             else
 470               evdw_t=evdw_t+evdwij
 471             endif
 472             if (calc_grad) then
 473 C
 474 C Calculate the components of the gradient in DC and X
 475 C
 476             fac=-rrij*(e1+evdwij)
 477             gg(1)=xj*fac
 478             gg(2)=yj*fac
 479             gg(3)=zj*fac
 480             do k=1,3
 481               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 482               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 483             enddo
 484             do k=i,j-1
 485               do l=1,3
 486                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 487               enddo
 488             enddo
 489             endif
 490 C
 491 C 12/1/95, revised on 5/20/97
 492 C
 493 C Calculate the contact function. The ith column of the array JCONT will
 494 C contain the numbers of atoms that make contacts with the atom I (of numbers
 495 C greater than I). The arrays FACONT and GACONT will contain the values of
 496 C the contact function and its derivative.
 497 C
 498 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 499 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 500 C Uncomment next line, if the correlation interactions are contact function only
 501             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 502               rij=dsqrt(rij)
 503               sigij=sigma(itypi,itypj)
 504               r0ij=rs0(itypi,itypj)
 505 C
 506 C Check whether the SC's are not too far to make a contact.
 507 C
 508               rcut=1.5d0*r0ij
 509               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 510 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 511 C
 512               if (fcont.gt.0.0D0) then
 513 C If the SC-SC distance if close to sigma, apply spline.
 514 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 515 cAdam &             fcont1,fprimcont1)
 516 cAdam           fcont1=1.0d0-fcont1
 517 cAdam           if (fcont1.gt.0.0d0) then
 518 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 519 cAdam             fcont=fcont*fcont1
 520 cAdam           endif
 521 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 522 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 523 cga             do k=1,3
 524 cga               gg(k)=gg(k)*eps0ij
 525 cga             enddo
 526 cga             eps0ij=-evdwij*eps0ij
 527 C Uncomment for AL's type of SC correlation interactions.
 528 cadam           eps0ij=-evdwij
 529                 num_conti=num_conti+1
 530                 jcont(num_conti,i)=j
 531                 facont(num_conti,i)=fcont*eps0ij
 532                 fprimcont=eps0ij*fprimcont/rij
 533                 fcont=expon*fcont
 534 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 535 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 536 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 537 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 538                 gacont(1,num_conti,i)=-fprimcont*xj
 539                 gacont(2,num_conti,i)=-fprimcont*yj
 540                 gacont(3,num_conti,i)=-fprimcont*zj
 541 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 542 cd              write (iout,'(2i3,3f10.5)')
 543 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 544               endif
 545             endif
 546           enddo      ! j
 547         enddo        ! iint
 548 C Change 12/1/95
 549         num_cont(i)=num_conti
 550       enddo          ! i
 551       if (calc_grad) then
 552       do i=1,nct
 553         do j=1,3
 554           gvdwc(j,i)=expon*gvdwc(j,i)
 555           gvdwx(j,i)=expon*gvdwx(j,i)
 556         enddo
 557       enddo
 558       endif
 559 C******************************************************************************
 560 C
 561 C                              N O T E !!!
 562 C
 563 C To save time, the factor of EXPON has been extracted from ALL components
 564 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 565 C use!
 566 C
 567 C******************************************************************************
 568       return
 569       end
 570 C-----------------------------------------------------------------------------
 571       subroutine eljk(evdw,evdw_t)
 572 C
 573 C This subroutine calculates the interaction energy of nonbonded side chains
 574 C assuming the LJK potential of interaction.
 575 C
 576       implicit real*8 (a-h,o-z)
 577       include 'DIMENSIONS'
 578       include 'DIMENSIONS.ZSCOPT'
 579       include "DIMENSIONS.COMPAR"
 580       include 'COMMON.GEO'
 581       include 'COMMON.VAR'
 582       include 'COMMON.LOCAL'
 583       include 'COMMON.CHAIN'
 584       include 'COMMON.DERIV'
 585       include 'COMMON.INTERACT'
 586       include 'COMMON.ENEPS'
 587       include 'COMMON.IOUNITS'
 588       include 'COMMON.NAMES'
 589       dimension gg(3)
 590       logical scheck
 591       integer icant
 592       external icant
 593 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 594       do i=1,210
 595         do j=1,2
 596           eneps_temp(j,i)=0.0d0
 597         enddo
 598       enddo
 599       evdw=0.0D0
 600       evdw_t=0.0d0
 601       do i=iatsc_s,iatsc_e
 602         itypi=itype(i)
 603         itypi1=itype(i+1)
 604         xi=c(1,nres+i)
 605         yi=c(2,nres+i)
 606         zi=c(3,nres+i)
 607 C
 608 C Calculate SC interaction energy.
 609 C
 610         do iint=1,nint_gr(i)
 611           do j=istart(i,iint),iend(i,iint)
 612             itypj=itype(j)
 613             xj=c(1,nres+j)-xi
 614             yj=c(2,nres+j)-yi
 615             zj=c(3,nres+j)-zi
 616             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 617             fac_augm=rrij**expon
 618             e_augm=augm(itypi,itypj)*fac_augm
 619             r_inv_ij=dsqrt(rrij)
 620             rij=1.0D0/r_inv_ij
 621             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 622             fac=r_shift_inv**expon
 623             e1=fac*fac*aa(itypi,itypj)
 624             e2=fac*bb(itypi,itypj)
 625             evdwij=e_augm+e1+e2
 626             ij=icant(itypi,itypj)
 627             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 628      &        /dabs(eps(itypi,itypj))
 629             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 630 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 631 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 632 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 633 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 634 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 635 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 636 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 637             if (bb(itypi,itypj).gt.0.0d0) then
 638               evdw=evdw+evdwij
 639             else
 640               evdw_t=evdw_t+evdwij
 641             endif
 642             if (calc_grad) then
 643 C
 644 C Calculate the components of the gradient in DC and X
 645 C
 646             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 647             gg(1)=xj*fac
 648             gg(2)=yj*fac
 649             gg(3)=zj*fac
 650             do k=1,3
 651               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 652               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 653             enddo
 654             do k=i,j-1
 655               do l=1,3
 656                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 657               enddo
 658             enddo
 659             endif
 660           enddo      ! j
 661         enddo        ! iint
 662       enddo          ! i
 663       if (calc_grad) then
 664       do i=1,nct
 665         do j=1,3
 666           gvdwc(j,i)=expon*gvdwc(j,i)
 667           gvdwx(j,i)=expon*gvdwx(j,i)
 668         enddo
 669       enddo
 670       endif
 671       return
 672       end
 673 C-----------------------------------------------------------------------------
 674       subroutine ebp(evdw,evdw_t)
 675 C
 676 C This subroutine calculates the interaction energy of nonbonded side chains
 677 C assuming the Berne-Pechukas potential of interaction.
 678 C
 679       implicit real*8 (a-h,o-z)
 680       include 'DIMENSIONS'
 681       include 'DIMENSIONS.ZSCOPT'
 682       include "DIMENSIONS.COMPAR"
 683       include 'COMMON.GEO'
 684       include 'COMMON.VAR'
 685       include 'COMMON.LOCAL'
 686       include 'COMMON.CHAIN'
 687       include 'COMMON.DERIV'
 688       include 'COMMON.NAMES'
 689       include 'COMMON.INTERACT'
 690       include 'COMMON.ENEPS'
 691       include 'COMMON.IOUNITS'
 692       include 'COMMON.CALC'
 693       common /srutu/ icall
 694 c     double precision rrsave(maxdim)
 695       logical lprn
 696       integer icant
 697       external icant
 698       do i=1,210
 699         do j=1,2
 700           eneps_temp(j,i)=0.0d0
 701         enddo
 702       enddo
 703       evdw=0.0D0
 704       evdw_t=0.0d0
 705 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 706 c     if (icall.eq.0) then
 707 c       lprn=.true.
 708 c     else
 709         lprn=.false.
 710 c     endif
 711       ind=0
 712       do i=iatsc_s,iatsc_e
 713         itypi=itype(i)
 714         itypi1=itype(i+1)
 715         xi=c(1,nres+i)
 716         yi=c(2,nres+i)
 717         zi=c(3,nres+i)
 718         dxi=dc_norm(1,nres+i)
 719         dyi=dc_norm(2,nres+i)
 720         dzi=dc_norm(3,nres+i)
 721         dsci_inv=vbld_inv(i+nres)
 722 C
 723 C Calculate SC interaction energy.
 724 C
 725         do iint=1,nint_gr(i)
 726           do j=istart(i,iint),iend(i,iint)
 727             ind=ind+1
 728             itypj=itype(j)
 729             dscj_inv=vbld_inv(j+nres)
 730             chi1=chi(itypi,itypj)
 731             chi2=chi(itypj,itypi)
 732             chi12=chi1*chi2
 733             chip1=chip(itypi)
 734             chip2=chip(itypj)
 735             chip12=chip1*chip2
 736             alf1=alp(itypi)
 737             alf2=alp(itypj)
 738             alf12=0.5D0*(alf1+alf2)
 739 C For diagnostics only!!!
 740 c           chi1=0.0D0
 741 c           chi2=0.0D0
 742 c           chi12=0.0D0
 743 c           chip1=0.0D0
 744 c           chip2=0.0D0
 745 c           chip12=0.0D0
 746 c           alf1=0.0D0
 747 c           alf2=0.0D0
 748 c           alf12=0.0D0
 749             xj=c(1,nres+j)-xi
 750             yj=c(2,nres+j)-yi
 751             zj=c(3,nres+j)-zi
 752             dxj=dc_norm(1,nres+j)
 753             dyj=dc_norm(2,nres+j)
 754             dzj=dc_norm(3,nres+j)
 755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 756 cd          if (icall.eq.0) then
 757 cd            rrsave(ind)=rrij
 758 cd          else
 759 cd            rrij=rrsave(ind)
 760 cd          endif
 761             rij=dsqrt(rrij)
 762 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 763             call sc_angular
 764 C Calculate whole angle-dependent part of epsilon and contributions
 765 C to its derivatives
 766             fac=(rrij*sigsq)**expon2
 767             e1=fac*fac*aa(itypi,itypj)
 768             e2=fac*bb(itypi,itypj)
 769             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 770             eps2der=evdwij*eps3rt
 771             eps3der=evdwij*eps2rt
 772             evdwij=evdwij*eps2rt*eps3rt
 773             ij=icant(itypi,itypj)
 774             aux=eps1*eps2rt**2*eps3rt**2
 775             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 776      &        /dabs(eps(itypi,itypj))
 777             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 778             if (bb(itypi,itypj).gt.0.0d0) then
 779               evdw=evdw+evdwij
 780             else
 781               evdw_t=evdw_t+evdwij
 782             endif
 783             if (calc_grad) then
 784             if (lprn) then
 785             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 786             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 787 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 788 cd     &        restyp(itypi),i,restyp(itypj),j,
 789 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 790 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 791 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 792 cd     &        evdwij
 793             endif
 794 C Calculate gradient components.
 795             e1=e1*eps1*eps2rt**2*eps3rt**2
 796             fac=-expon*(e1+evdwij)
 797             sigder=fac/sigsq
 798             fac=rrij*fac
 799 C Calculate radial part of the gradient
 800             gg(1)=xj*fac
 801             gg(2)=yj*fac
 802             gg(3)=zj*fac
 803 C Calculate the angular part of the gradient and sum add the contributions
 804 C to the appropriate components of the Cartesian gradient.
 805             call sc_grad
 806             endif
 807           enddo      ! j
 808         enddo        ! iint
 809       enddo          ! i
 810 c     stop
 811       return
 812       end
 813 C-----------------------------------------------------------------------------
 814       subroutine egb(evdw,evdw_t)
 815 C
 816 C This subroutine calculates the interaction energy of nonbonded side chains
 817 C assuming the Gay-Berne potential of interaction.
 818 C
 819       implicit real*8 (a-h,o-z)
 820       include 'DIMENSIONS'
 821       include 'DIMENSIONS.ZSCOPT'
 822       include "DIMENSIONS.COMPAR"
 823       include 'COMMON.GEO'
 824       include 'COMMON.VAR'
 825       include 'COMMON.LOCAL'
 826       include 'COMMON.CHAIN'
 827       include 'COMMON.DERIV'
 828       include 'COMMON.NAMES'
 829       include 'COMMON.INTERACT'
 830       include 'COMMON.ENEPS'
 831       include 'COMMON.IOUNITS'
 832       include 'COMMON.CALC'
 833       include 'COMMON.SBRIDGE'
 834       logical lprn
 835       common /srutu/icall
 836       integer icant
 837       external icant
 838       do i=1,210
 839         do j=1,2
 840           eneps_temp(j,i)=0.0d0
 841         enddo
 842       enddo
 843 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 844       evdw=0.0D0
 845       evdw_t=0.0d0
 846       lprn=.false.
 847 c      if (icall.gt.0) lprn=.true.
 848       ind=0
 849       do i=iatsc_s,iatsc_e
 850         itypi=itype(i)
 851         itypi1=itype(i+1)
 852         xi=c(1,nres+i)
 853         yi=c(2,nres+i)
 854         zi=c(3,nres+i)
 855         dxi=dc_norm(1,nres+i)
 856         dyi=dc_norm(2,nres+i)
 857         dzi=dc_norm(3,nres+i)
 858         dsci_inv=vbld_inv(i+nres)
 859 C
 860 C Calculate SC interaction energy.
 861 C
 862         do iint=1,nint_gr(i)
 863           do j=istart(i,iint),iend(i,iint)
 864 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 865 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 866 C formation no electrostatic interactions should be calculated. If it
 867 C would be allowed NaN would appear
 868             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 869 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 870 C residue can or cannot form disulfide bond. There is still bug allowing
 871 C Cys...Cys...Cys bond formation
 872               call dyn_ssbond_ene(i,j,evdwij)
 873 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 874 C function in ssMD.F
 875               evdw=evdw+evdwij
 876 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 877 c     &                        'evdw',i,j,evdwij,' ss'
 878             ELSE
 879             ind=ind+1
 880             itypj=itype(j)
 881             dscj_inv=vbld_inv(j+nres)
 882             sig0ij=sigma(itypi,itypj)
 883             chi1=chi(itypi,itypj)
 884             chi2=chi(itypj,itypi)
 885             chi12=chi1*chi2
 886             chip1=chip(itypi)
 887             chip2=chip(itypj)
 888             chip12=chip1*chip2
 889             alf1=alp(itypi)
 890             alf2=alp(itypj)
 891             alf12=0.5D0*(alf1+alf2)
 892 C For diagnostics only!!!
 893 c           chi1=0.0D0
 894 c           chi2=0.0D0
 895 c           chi12=0.0D0
 896 c           chip1=0.0D0
 897 c           chip2=0.0D0
 898 c           chip12=0.0D0
 899 c           alf1=0.0D0
 900 c           alf2=0.0D0
 901 c           alf12=0.0D0
 902             xj=c(1,nres+j)-xi
 903             yj=c(2,nres+j)-yi
 904             zj=c(3,nres+j)-zi
 905             dxj=dc_norm(1,nres+j)
 906             dyj=dc_norm(2,nres+j)
 907             dzj=dc_norm(3,nres+j)
 908 c            write (iout,*) i,j,xj,yj,zj
 909             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 910             rij=dsqrt(rrij)
 911 C Calculate angle-dependent terms of energy and contributions to their
 912 C derivatives.
 913             call sc_angular
 914             sigsq=1.0D0/sigsq
 915             sig=sig0ij*dsqrt(sigsq)
 916             rij_shift=1.0D0/rij-sig+sig0ij
 917 C I hate to put IF's in the loops, but here don't have another choice!!!!
 918             if (rij_shift.le.0.0D0) then
 919               evdw=1.0D20
 920               return
 921             endif
 922             sigder=-sig*sigsq
 923 c---------------------------------------------------------------
 924             rij_shift=1.0D0/rij_shift
 925             fac=rij_shift**expon
 926             e1=fac*fac*aa(itypi,itypj)
 927             e2=fac*bb(itypi,itypj)
 928             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 929             eps2der=evdwij*eps3rt
 930             eps3der=evdwij*eps2rt
 931             evdwij=evdwij*eps2rt*eps3rt
 932             if (bb(itypi,itypj).gt.0) then
 933               evdw=evdw+evdwij
 934             else
 935               evdw_t=evdw_t+evdwij
 936             endif
 937             ij=icant(itypi,itypj)
 938             aux=eps1*eps2rt**2*eps3rt**2
 939             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 940      &        /dabs(eps(itypi,itypj))
 941             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 942 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 943 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 944 c     &         aux*e2/eps(itypi,itypj)
 945 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 946             if (lprn) then
 947             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 948             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 949             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 950      &        restyp(itypi),i,restyp(itypj),j,
 951      &        epsi,sigm,chi1,chi2,chip1,chip2,
 952      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 953      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 954      &        evdwij
 955             endif
 956             if (calc_grad) then
 957 C Calculate gradient components.
 958             e1=e1*eps1*eps2rt**2*eps3rt**2
 959             fac=-expon*(e1+evdwij)*rij_shift
 960             sigder=fac*sigder
 961             fac=rij*fac
 962 C Calculate the radial part of the gradient
 963             gg(1)=xj*fac
 964             gg(2)=yj*fac
 965             gg(3)=zj*fac
 966 C Calculate angular part of the gradient.
 967             call sc_grad
 968             endif
 969             ENDIF    ! dyn_ss
 970           enddo      ! j
 971         enddo        ! iint
 972       enddo          ! i
 973       return
 974       end
 975 C-----------------------------------------------------------------------------
 976       subroutine egbv(evdw,evdw_t)
 977 C
 978 C This subroutine calculates the interaction energy of nonbonded side chains
 979 C assuming the Gay-Berne-Vorobjev potential of interaction.
 980 C
 981       implicit real*8 (a-h,o-z)
 982       include 'DIMENSIONS'
 983       include 'DIMENSIONS.ZSCOPT'
 984       include "DIMENSIONS.COMPAR"
 985       include 'COMMON.GEO'
 986       include 'COMMON.VAR'
 987       include 'COMMON.LOCAL'
 988       include 'COMMON.CHAIN'
 989       include 'COMMON.DERIV'
 990       include 'COMMON.NAMES'
 991       include 'COMMON.INTERACT'
 992       include 'COMMON.ENEPS'
 993       include 'COMMON.IOUNITS'
 994       include 'COMMON.CALC'
 995       common /srutu/ icall
 996       logical lprn
 997       integer icant
 998       external icant
 999       do i=1,210
1000         do j=1,2
1001           eneps_temp(j,i)=0.0d0
1002         enddo
1003       enddo
1004       evdw=0.0D0
1005       evdw_t=0.0d0
1006 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1007       evdw=0.0D0
1008       lprn=.false.
1009 c      if (icall.gt.0) lprn=.true.
1010       ind=0
1011       do i=iatsc_s,iatsc_e
1012         itypi=itype(i)
1013         itypi1=itype(i+1)
1014         xi=c(1,nres+i)
1015         yi=c(2,nres+i)
1016         zi=c(3,nres+i)
1017         dxi=dc_norm(1,nres+i)
1018         dyi=dc_norm(2,nres+i)
1019         dzi=dc_norm(3,nres+i)
1020         dsci_inv=vbld_inv(i+nres)
1021 C
1022 C Calculate SC interaction energy.
1023 C
1024         do iint=1,nint_gr(i)
1025           do j=istart(i,iint),iend(i,iint)
1026             ind=ind+1
1027             itypj=itype(j)
1028             dscj_inv=vbld_inv(j+nres)
1029             sig0ij=sigma(itypi,itypj)
1030             r0ij=r0(itypi,itypj)
1031             chi1=chi(itypi,itypj)
1032             chi2=chi(itypj,itypi)
1033             chi12=chi1*chi2
1034             chip1=chip(itypi)
1035             chip2=chip(itypj)
1036             chip12=chip1*chip2
1037             alf1=alp(itypi)
1038             alf2=alp(itypj)
1039             alf12=0.5D0*(alf1+alf2)
1040 C For diagnostics only!!!
1041 c           chi1=0.0D0
1042 c           chi2=0.0D0
1043 c           chi12=0.0D0
1044 c           chip1=0.0D0
1045 c           chip2=0.0D0
1046 c           chip12=0.0D0
1047 c           alf1=0.0D0
1048 c           alf2=0.0D0
1049 c           alf12=0.0D0
1050             xj=c(1,nres+j)-xi
1051             yj=c(2,nres+j)-yi
1052             zj=c(3,nres+j)-zi
1053             dxj=dc_norm(1,nres+j)
1054             dyj=dc_norm(2,nres+j)
1055             dzj=dc_norm(3,nres+j)
1056             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1057             rij=dsqrt(rrij)
1058 C Calculate angle-dependent terms of energy and contributions to their
1059 C derivatives.
1060             call sc_angular
1061             sigsq=1.0D0/sigsq
1062             sig=sig0ij*dsqrt(sigsq)
1063             rij_shift=1.0D0/rij-sig+r0ij
1064 C I hate to put IF's in the loops, but here don't have another choice!!!!
1065             if (rij_shift.le.0.0D0) then
1066               evdw=1.0D20
1067               return
1068             endif
1069             sigder=-sig*sigsq
1070 c---------------------------------------------------------------
1071             rij_shift=1.0D0/rij_shift
1072             fac=rij_shift**expon
1073             e1=fac*fac*aa(itypi,itypj)
1074             e2=fac*bb(itypi,itypj)
1075             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1076             eps2der=evdwij*eps3rt
1077             eps3der=evdwij*eps2rt
1078             fac_augm=rrij**expon
1079             e_augm=augm(itypi,itypj)*fac_augm
1080             evdwij=evdwij*eps2rt*eps3rt
1081             if (bb(itypi,itypj).gt.0.0d0) then
1082               evdw=evdw+evdwij+e_augm
1083             else
1084               evdw_t=evdw_t+evdwij+e_augm
1085             endif
1086             ij=icant(itypi,itypj)
1087             aux=eps1*eps2rt**2*eps3rt**2
1088             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1089      &        /dabs(eps(itypi,itypj))
1090             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1091 c            eneps_temp(ij)=eneps_temp(ij)
1092 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1093 c            if (lprn) then
1094 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1095 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1096 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1097 c     &        restyp(itypi),i,restyp(itypj),j,
1098 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1099 c     &        chi1,chi2,chip1,chip2,
1100 c     &        eps1,eps2rt**2,eps3rt**2,
1101 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1102 c     &        evdwij+e_augm
1103 c            endif
1104             if (calc_grad) then
1105 C Calculate gradient components.
1106             e1=e1*eps1*eps2rt**2*eps3rt**2
1107             fac=-expon*(e1+evdwij)*rij_shift
1108             sigder=fac*sigder
1109             fac=rij*fac-2*expon*rrij*e_augm
1110 C Calculate the radial part of the gradient
1111             gg(1)=xj*fac
1112             gg(2)=yj*fac
1113             gg(3)=zj*fac
1114 C Calculate angular part of the gradient.
1115             call sc_grad
1116             endif
1117           enddo      ! j
1118         enddo        ! iint
1119       enddo          ! i
1120       return
1121       end
1122 C-----------------------------------------------------------------------------
1123       subroutine sc_angular
1124 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1125 C om12. Called by ebp, egb, and egbv.
1126       implicit none
1127       include 'COMMON.CALC'
1128       erij(1)=xj*rij
1129       erij(2)=yj*rij
1130       erij(3)=zj*rij
1131       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1132       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1133       om12=dxi*dxj+dyi*dyj+dzi*dzj
1134       chiom12=chi12*om12
1135 C Calculate eps1(om12) and its derivative in om12
1136       faceps1=1.0D0-om12*chiom12
1137       faceps1_inv=1.0D0/faceps1
1138       eps1=dsqrt(faceps1_inv)
1139 C Following variable is eps1*deps1/dom12
1140       eps1_om12=faceps1_inv*chiom12
1141 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1142 C and om12.
1143       om1om2=om1*om2
1144       chiom1=chi1*om1
1145       chiom2=chi2*om2
1146       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1147       sigsq=1.0D0-facsig*faceps1_inv
1148       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1149       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1150       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1151 C Calculate eps2 and its derivatives in om1, om2, and om12.
1152       chipom1=chip1*om1
1153       chipom2=chip2*om2
1154       chipom12=chip12*om12
1155       facp=1.0D0-om12*chipom12
1156       facp_inv=1.0D0/facp
1157       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1158 C Following variable is the square root of eps2
1159       eps2rt=1.0D0-facp1*facp_inv
1160 C Following three variables are the derivatives of the square root of eps
1161 C in om1, om2, and om12.
1162       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1163       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1164       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1165 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1166       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1167 C Calculate whole angle-dependent part of epsilon and contributions
1168 C to its derivatives
1169       return
1170       end
1171 C----------------------------------------------------------------------------
1172       subroutine sc_grad
1173       implicit real*8 (a-h,o-z)
1174       include 'DIMENSIONS'
1175       include 'DIMENSIONS.ZSCOPT'
1176       include 'COMMON.CHAIN'
1177       include 'COMMON.DERIV'
1178       include 'COMMON.CALC'
1179       double precision dcosom1(3),dcosom2(3)
1180       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1181       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1182       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1183      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1184       do k=1,3
1185         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1186         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1187       enddo
1188       do k=1,3
1189         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1190       enddo
1191       do k=1,3
1192         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1193      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1194      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1195         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1197      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1198       enddo
1199 C
1200 C Calculate the components of the gradient in DC and X
1201 C
1202       do k=i,j-1
1203         do l=1,3
1204           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1205         enddo
1206       enddo
1207       return
1208       end
1209 c------------------------------------------------------------------------------
1210       subroutine vec_and_deriv
1211       implicit real*8 (a-h,o-z)
1212       include 'DIMENSIONS'
1213       include 'DIMENSIONS.ZSCOPT'
1214       include 'COMMON.IOUNITS'
1215       include 'COMMON.GEO'
1216       include 'COMMON.VAR'
1217       include 'COMMON.LOCAL'
1218       include 'COMMON.CHAIN'
1219       include 'COMMON.VECTORS'
1220       include 'COMMON.DERIV'
1221       include 'COMMON.INTERACT'
1222       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1223 C Compute the local reference systems. For reference system (i), the
1224 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1225 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1226       do i=1,nres-1
1227 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1228           if (i.eq.nres-1) then
1229 C Case of the last full residue
1230 C Compute the Z-axis
1231             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1232             costh=dcos(pi-theta(nres))
1233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1234             do k=1,3
1235               uz(k,i)=fac*uz(k,i)
1236             enddo
1237             if (calc_grad) then
1238 C Compute the derivatives of uz
1239             uzder(1,1,1)= 0.0d0
1240             uzder(2,1,1)=-dc_norm(3,i-1)
1241             uzder(3,1,1)= dc_norm(2,i-1)
1242             uzder(1,2,1)= dc_norm(3,i-1)
1243             uzder(2,2,1)= 0.0d0
1244             uzder(3,2,1)=-dc_norm(1,i-1)
1245             uzder(1,3,1)=-dc_norm(2,i-1)
1246             uzder(2,3,1)= dc_norm(1,i-1)
1247             uzder(3,3,1)= 0.0d0
1248             uzder(1,1,2)= 0.0d0
1249             uzder(2,1,2)= dc_norm(3,i)
1250             uzder(3,1,2)=-dc_norm(2,i)
1251             uzder(1,2,2)=-dc_norm(3,i)
1252             uzder(2,2,2)= 0.0d0
1253             uzder(3,2,2)= dc_norm(1,i)
1254             uzder(1,3,2)= dc_norm(2,i)
1255             uzder(2,3,2)=-dc_norm(1,i)
1256             uzder(3,3,2)= 0.0d0
1257             endif
1258 C Compute the Y-axis
1259             facy=fac
1260             do k=1,3
1261               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1262             enddo
1263             if (calc_grad) then
1264 C Compute the derivatives of uy
1265             do j=1,3
1266               do k=1,3
1267                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1268      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1269                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1270               enddo
1271               uyder(j,j,1)=uyder(j,j,1)-costh
1272               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1273             enddo
1274             do j=1,2
1275               do k=1,3
1276                 do l=1,3
1277                   uygrad(l,k,j,i)=uyder(l,k,j)
1278                   uzgrad(l,k,j,i)=uzder(l,k,j)
1279                 enddo
1280               enddo
1281             enddo
1282             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1283             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1284             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1285             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1286             endif
1287           else
1288 C Other residues
1289 C Compute the Z-axis
1290             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1291             costh=dcos(pi-theta(i+2))
1292             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1293             do k=1,3
1294               uz(k,i)=fac*uz(k,i)
1295             enddo
1296             if (calc_grad) then
1297 C Compute the derivatives of uz
1298             uzder(1,1,1)= 0.0d0
1299             uzder(2,1,1)=-dc_norm(3,i+1)
1300             uzder(3,1,1)= dc_norm(2,i+1)
1301             uzder(1,2,1)= dc_norm(3,i+1)
1302             uzder(2,2,1)= 0.0d0
1303             uzder(3,2,1)=-dc_norm(1,i+1)
1304             uzder(1,3,1)=-dc_norm(2,i+1)
1305             uzder(2,3,1)= dc_norm(1,i+1)
1306             uzder(3,3,1)= 0.0d0
1307             uzder(1,1,2)= 0.0d0
1308             uzder(2,1,2)= dc_norm(3,i)
1309             uzder(3,1,2)=-dc_norm(2,i)
1310             uzder(1,2,2)=-dc_norm(3,i)
1311             uzder(2,2,2)= 0.0d0
1312             uzder(3,2,2)= dc_norm(1,i)
1313             uzder(1,3,2)= dc_norm(2,i)
1314             uzder(2,3,2)=-dc_norm(1,i)
1315             uzder(3,3,2)= 0.0d0
1316             endif
1317 C Compute the Y-axis
1318             facy=fac
1319             do k=1,3
1320               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1321             enddo
1322             if (calc_grad) then
1323 C Compute the derivatives of uy
1324             do j=1,3
1325               do k=1,3
1326                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1327      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1328                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1329               enddo
1330               uyder(j,j,1)=uyder(j,j,1)-costh
1331               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1332             enddo
1333             do j=1,2
1334               do k=1,3
1335                 do l=1,3
1336                   uygrad(l,k,j,i)=uyder(l,k,j)
1337                   uzgrad(l,k,j,i)=uzder(l,k,j)
1338                 enddo
1339               enddo
1340             enddo
1341             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1342             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1343             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1344             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1345           endif
1346           endif
1347       enddo
1348       if (calc_grad) then
1349       do i=1,nres-1
1350         vbld_inv_temp(1)=vbld_inv(i+1)
1351         if (i.lt.nres-1) then
1352           vbld_inv_temp(2)=vbld_inv(i+2)
1353         else
1354           vbld_inv_temp(2)=vbld_inv(i)
1355         endif
1356         do j=1,2
1357           do k=1,3
1358             do l=1,3
1359               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1360               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1361             enddo
1362           enddo
1363         enddo
1364       enddo
1365       endif
1366       return
1367       end
1368 C-----------------------------------------------------------------------------
1369       subroutine vec_and_deriv_test
1370       implicit real*8 (a-h,o-z)
1371       include 'DIMENSIONS'
1372       include 'DIMENSIONS.ZSCOPT'
1373       include 'COMMON.IOUNITS'
1374       include 'COMMON.GEO'
1375       include 'COMMON.VAR'
1376       include 'COMMON.LOCAL'
1377       include 'COMMON.CHAIN'
1378       include 'COMMON.VECTORS'
1379       dimension uyder(3,3,2),uzder(3,3,2)
1380 C Compute the local reference systems. For reference system (i), the
1381 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1382 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1383       do i=1,nres-1
1384           if (i.eq.nres-1) then
1385 C Case of the last full residue
1386 C Compute the Z-axis
1387             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1388             costh=dcos(pi-theta(nres))
1389             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1390 c            write (iout,*) 'fac',fac,
1391 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396 C Compute the derivatives of uz
1397             uzder(1,1,1)= 0.0d0
1398             uzder(2,1,1)=-dc_norm(3,i-1)
1399             uzder(3,1,1)= dc_norm(2,i-1)
1400             uzder(1,2,1)= dc_norm(3,i-1)
1401             uzder(2,2,1)= 0.0d0
1402             uzder(3,2,1)=-dc_norm(1,i-1)
1403             uzder(1,3,1)=-dc_norm(2,i-1)
1404             uzder(2,3,1)= dc_norm(1,i-1)
1405             uzder(3,3,1)= 0.0d0
1406             uzder(1,1,2)= 0.0d0
1407             uzder(2,1,2)= dc_norm(3,i)
1408             uzder(3,1,2)=-dc_norm(2,i)
1409             uzder(1,2,2)=-dc_norm(3,i)
1410             uzder(2,2,2)= 0.0d0
1411             uzder(3,2,2)= dc_norm(1,i)
1412             uzder(1,3,2)= dc_norm(2,i)
1413             uzder(2,3,2)=-dc_norm(1,i)
1414             uzder(3,3,2)= 0.0d0
1415 C Compute the Y-axis
1416             do k=1,3
1417               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1418             enddo
1419             facy=fac
1420             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1421      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1422      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1423             do k=1,3
1424 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1425               uy(k,i)=
1426 c     &        facy*(
1427      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1428      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1429 c     &        )
1430             enddo
1431 c            write (iout,*) 'facy',facy,
1432 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1434             do k=1,3
1435               uy(k,i)=facy*uy(k,i)
1436             enddo
1437 C Compute the derivatives of uy
1438             do j=1,3
1439               do k=1,3
1440                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1441      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1442                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1443               enddo
1444 c              uyder(j,j,1)=uyder(j,j,1)-costh
1445 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1446               uyder(j,j,1)=uyder(j,j,1)
1447      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1448               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1449      &          +uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463           else
1464 C Other residues
1465 C Compute the Z-axis
1466             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1467             costh=dcos(pi-theta(i+2))
1468             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1469             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1470             do k=1,3
1471               uz(k,i)=fac*uz(k,i)
1472             enddo
1473 C Compute the derivatives of uz
1474             uzder(1,1,1)= 0.0d0
1475             uzder(2,1,1)=-dc_norm(3,i+1)
1476             uzder(3,1,1)= dc_norm(2,i+1)
1477             uzder(1,2,1)= dc_norm(3,i+1)
1478             uzder(2,2,1)= 0.0d0
1479             uzder(3,2,1)=-dc_norm(1,i+1)
1480             uzder(1,3,1)=-dc_norm(2,i+1)
1481             uzder(2,3,1)= dc_norm(1,i+1)
1482             uzder(3,3,1)= 0.0d0
1483             uzder(1,1,2)= 0.0d0
1484             uzder(2,1,2)= dc_norm(3,i)
1485             uzder(3,1,2)=-dc_norm(2,i)
1486             uzder(1,2,2)=-dc_norm(3,i)
1487             uzder(2,2,2)= 0.0d0
1488             uzder(3,2,2)= dc_norm(1,i)
1489             uzder(1,3,2)= dc_norm(2,i)
1490             uzder(2,3,2)=-dc_norm(1,i)
1491             uzder(3,3,2)= 0.0d0
1492 C Compute the Y-axis
1493             facy=fac
1494             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1495      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1496      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1497             do k=1,3
1498 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1499               uy(k,i)=
1500 c     &        facy*(
1501      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1502      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1503 c     &        )
1504             enddo
1505 c            write (iout,*) 'facy',facy,
1506 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1508             do k=1,3
1509               uy(k,i)=facy*uy(k,i)
1510             enddo
1511 C Compute the derivatives of uy
1512             do j=1,3
1513               do k=1,3
1514                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1515      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1516                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1517               enddo
1518 c              uyder(j,j,1)=uyder(j,j,1)-costh
1519 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1520               uyder(j,j,1)=uyder(j,j,1)
1521      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1522               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1523      &          +uyder(j,j,2)
1524             enddo
1525             do j=1,2
1526               do k=1,3
1527                 do l=1,3
1528                   uygrad(l,k,j,i)=uyder(l,k,j)
1529                   uzgrad(l,k,j,i)=uzder(l,k,j)
1530                 enddo
1531               enddo
1532             enddo
1533             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1534             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1535             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1536             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1537           endif
1538       enddo
1539       do i=1,nres-1
1540         do j=1,2
1541           do k=1,3
1542             do l=1,3
1543               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1544               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1545             enddo
1546           enddo
1547         enddo
1548       enddo
1549       return
1550       end
1551 C-----------------------------------------------------------------------------
1552       subroutine check_vecgrad
1553       implicit real*8 (a-h,o-z)
1554       include 'DIMENSIONS'
1555       include 'DIMENSIONS.ZSCOPT'
1556       include 'COMMON.IOUNITS'
1557       include 'COMMON.GEO'
1558       include 'COMMON.VAR'
1559       include 'COMMON.LOCAL'
1560       include 'COMMON.CHAIN'
1561       include 'COMMON.VECTORS'
1562       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1563       dimension uyt(3,maxres),uzt(3,maxres)
1564       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1565       double precision delta /1.0d-7/
1566       call vec_and_deriv
1567 cd      do i=1,nres
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1570 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1571 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1572 cd     &     (dc_norm(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1574 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1575 cd          write(iout,'(a)')
1576 cd      enddo
1577       do i=1,nres
1578         do j=1,2
1579           do k=1,3
1580             do l=1,3
1581               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1582               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1583             enddo
1584           enddo
1585         enddo
1586       enddo
1587       call vec_and_deriv
1588       do i=1,nres
1589         do j=1,3
1590           uyt(j,i)=uy(j,i)
1591           uzt(j,i)=uz(j,i)
1592         enddo
1593       enddo
1594       do i=1,nres
1595 cd        write (iout,*) 'i=',i
1596         do k=1,3
1597           erij(k)=dc_norm(k,i)
1598         enddo
1599         do j=1,3
1600           do k=1,3
1601             dc_norm(k,i)=erij(k)
1602           enddo
1603           dc_norm(j,i)=dc_norm(j,i)+delta
1604 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1605 c          do k=1,3
1606 c            dc_norm(k,i)=dc_norm(k,i)/fac
1607 c          enddo
1608 c          write (iout,*) (dc_norm(k,i),k=1,3)
1609 c          write (iout,*) (erij(k),k=1,3)
1610           call vec_and_deriv
1611           do k=1,3
1612             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1613             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1614             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1615             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1616           enddo
1617 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1618 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1619 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1620         enddo
1621         do k=1,3
1622           dc_norm(k,i)=erij(k)
1623         enddo
1624 cd        do k=1,3
1625 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1626 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1627 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1628 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1629 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1630 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1631 cd          write (iout,'(a)')
1632 cd        enddo
1633       enddo
1634       return
1635       end
1636 C--------------------------------------------------------------------------
1637       subroutine set_matrices
1638       implicit real*8 (a-h,o-z)
1639       include 'DIMENSIONS'
1640       include 'DIMENSIONS.ZSCOPT'
1641       include 'COMMON.IOUNITS'
1642       include 'COMMON.GEO'
1643       include 'COMMON.VAR'
1644       include 'COMMON.LOCAL'
1645       include 'COMMON.CHAIN'
1646       include 'COMMON.DERIV'
1647       include 'COMMON.INTERACT'
1648       include 'COMMON.CONTACTS'
1649       include 'COMMON.TORSION'
1650       include 'COMMON.VECTORS'
1651       include 'COMMON.FFIELD'
1652       double precision auxvec(2),auxmat(2,2)
1653 C
1654 C Compute the virtual-bond-torsional-angle dependent quantities needed
1655 C to calculate the el-loc multibody terms of various order.
1656 C
1657       do i=3,nres+1
1658         if (i .lt. nres+1) then
1659           sin1=dsin(phi(i))
1660           cos1=dcos(phi(i))
1661           sintab(i-2)=sin1
1662           costab(i-2)=cos1
1663           obrot(1,i-2)=cos1
1664           obrot(2,i-2)=sin1
1665           sin2=dsin(2*phi(i))
1666           cos2=dcos(2*phi(i))
1667           sintab2(i-2)=sin2
1668           costab2(i-2)=cos2
1669           obrot2(1,i-2)=cos2
1670           obrot2(2,i-2)=sin2
1671           Ug(1,1,i-2)=-cos1
1672           Ug(1,2,i-2)=-sin1
1673           Ug(2,1,i-2)=-sin1
1674           Ug(2,2,i-2)= cos1
1675           Ug2(1,1,i-2)=-cos2
1676           Ug2(1,2,i-2)=-sin2
1677           Ug2(2,1,i-2)=-sin2
1678           Ug2(2,2,i-2)= cos2
1679         else
1680           costab(i-2)=1.0d0
1681           sintab(i-2)=0.0d0
1682           obrot(1,i-2)=1.0d0
1683           obrot(2,i-2)=0.0d0
1684           obrot2(1,i-2)=0.0d0
1685           obrot2(2,i-2)=0.0d0
1686           Ug(1,1,i-2)=1.0d0
1687           Ug(1,2,i-2)=0.0d0
1688           Ug(2,1,i-2)=0.0d0
1689           Ug(2,2,i-2)=1.0d0
1690           Ug2(1,1,i-2)=0.0d0
1691           Ug2(1,2,i-2)=0.0d0
1692           Ug2(2,1,i-2)=0.0d0
1693           Ug2(2,2,i-2)=0.0d0
1694         endif
1695         if (i .gt. 3 .and. i .lt. nres+1) then
1696           obrot_der(1,i-2)=-sin1
1697           obrot_der(2,i-2)= cos1
1698           Ugder(1,1,i-2)= sin1
1699           Ugder(1,2,i-2)=-cos1
1700           Ugder(2,1,i-2)=-cos1
1701           Ugder(2,2,i-2)=-sin1
1702           dwacos2=cos2+cos2
1703           dwasin2=sin2+sin2
1704           obrot2_der(1,i-2)=-dwasin2
1705           obrot2_der(2,i-2)= dwacos2
1706           Ug2der(1,1,i-2)= dwasin2
1707           Ug2der(1,2,i-2)=-dwacos2
1708           Ug2der(2,1,i-2)=-dwacos2
1709           Ug2der(2,2,i-2)=-dwasin2
1710         else
1711           obrot_der(1,i-2)=0.0d0
1712           obrot_der(2,i-2)=0.0d0
1713           Ugder(1,1,i-2)=0.0d0
1714           Ugder(1,2,i-2)=0.0d0
1715           Ugder(2,1,i-2)=0.0d0
1716           Ugder(2,2,i-2)=0.0d0
1717           obrot2_der(1,i-2)=0.0d0
1718           obrot2_der(2,i-2)=0.0d0
1719           Ug2der(1,1,i-2)=0.0d0
1720           Ug2der(1,2,i-2)=0.0d0
1721           Ug2der(2,1,i-2)=0.0d0
1722           Ug2der(2,2,i-2)=0.0d0
1723         endif
1724         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1725           iti = itortyp(itype(i-2))
1726         else
1727           iti=ntortyp+1
1728         endif
1729         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1730           iti1 = itortyp(itype(i-1))
1731         else
1732           iti1=ntortyp+1
1733         endif
1734 cd        write (iout,*) '*******i',i,' iti1',iti
1735 cd        write (iout,*) 'b1',b1(:,iti)
1736 cd        write (iout,*) 'b2',b2(:,iti)
1737 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1738         if (i .gt. iatel_s+2) then
1739           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1740           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1741           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1742           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1743           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1744           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1745           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1746         else
1747           do k=1,2
1748             Ub2(k,i-2)=0.0d0
1749             Ctobr(k,i-2)=0.0d0
1750             Dtobr2(k,i-2)=0.0d0
1751             do l=1,2
1752               EUg(l,k,i-2)=0.0d0
1753               CUg(l,k,i-2)=0.0d0
1754               DUg(l,k,i-2)=0.0d0
1755               DtUg2(l,k,i-2)=0.0d0
1756             enddo
1757           enddo
1758         endif
1759         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1760         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1761         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1762         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1763         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1764         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1765         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1766         do k=1,2
1767           muder(k,i-2)=Ub2der(k,i-2)
1768         enddo
1769         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1770           iti1 = itortyp(itype(i-1))
1771         else
1772           iti1=ntortyp+1
1773         endif
1774         do k=1,2
1775           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1776         enddo
1777 C Vectors and matrices dependent on a single virtual-bond dihedral.
1778         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1779         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1780         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1782         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1783         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1784         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1785         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1786         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1787 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1788 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1789       enddo
1790 C Matrices dependent on two consecutive virtual-bond dihedrals.
1791 C The order of matrices is from left to right.
1792       do i=2,nres-1
1793         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1794         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1795         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1796         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1797         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1798         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1799         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1800         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1801       enddo
1802 cd      do i=1,nres
1803 cd        iti = itortyp(itype(i))
1804 cd        write (iout,*) i
1805 cd        do j=1,2
1806 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1807 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1808 cd        enddo
1809 cd      enddo
1810       return
1811       end
1812 C--------------------------------------------------------------------------
1813       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1814 C
1815 C This subroutine calculates the average interaction energy and its gradient
1816 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1817 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1818 C The potential depends both on the distance of peptide-group centers and on
1819 C the orientation of the CA-CA virtual bonds.
1820 C
1821       implicit real*8 (a-h,o-z)
1822       include 'DIMENSIONS'
1823       include 'DIMENSIONS.ZSCOPT'
1824       include 'DIMENSIONS.FREE'
1825       include 'COMMON.CONTROL'
1826       include 'COMMON.IOUNITS'
1827       include 'COMMON.GEO'
1828       include 'COMMON.VAR'
1829       include 'COMMON.LOCAL'
1830       include 'COMMON.CHAIN'
1831       include 'COMMON.DERIV'
1832       include 'COMMON.INTERACT'
1833       include 'COMMON.CONTACTS'
1834       include 'COMMON.TORSION'
1835       include 'COMMON.VECTORS'
1836       include 'COMMON.FFIELD'
1837       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1838      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1839       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1840      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1841       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1842 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1843       double precision scal_el /0.5d0/
1844 C 12/13/98
1845 C 13-go grudnia roku pamietnego...
1846       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1847      &                   0.0d0,1.0d0,0.0d0,
1848      &                   0.0d0,0.0d0,1.0d0/
1849 cd      write(iout,*) 'In EELEC'
1850 cd      do i=1,nloctyp
1851 cd        write(iout,*) 'Type',i
1852 cd        write(iout,*) 'B1',B1(:,i)
1853 cd        write(iout,*) 'B2',B2(:,i)
1854 cd        write(iout,*) 'CC',CC(:,:,i)
1855 cd        write(iout,*) 'DD',DD(:,:,i)
1856 cd        write(iout,*) 'EE',EE(:,:,i)
1857 cd      enddo
1858 cd      call check_vecgrad
1859 cd      stop
1860       if (icheckgrad.eq.1) then
1861         do i=1,nres-1
1862           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1863           do k=1,3
1864             dc_norm(k,i)=dc(k,i)*fac
1865           enddo
1866 c          write (iout,*) 'i',i,' fac',fac
1867         enddo
1868       endif
1869       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1870      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1871      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1872 cd      if (wel_loc.gt.0.0d0) then
1873         if (icheckgrad.eq.1) then
1874         call vec_and_deriv_test
1875         else
1876         call vec_and_deriv
1877         endif
1878         call set_matrices
1879       endif
1880 cd      do i=1,nres-1
1881 cd        write (iout,*) 'i=',i
1882 cd        do k=1,3
1883 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1884 cd        enddo
1885 cd        do k=1,3
1886 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1887 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1888 cd        enddo
1889 cd      enddo
1890       num_conti_hb=0
1891       ees=0.0D0
1892       evdw1=0.0D0
1893       eel_loc=0.0d0
1894       eello_turn3=0.0d0
1895       eello_turn4=0.0d0
1896       ind=0
1897       do i=1,nres
1898         num_cont_hb(i)=0
1899       enddo
1900 cd      print '(a)','Enter EELEC'
1901 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1902       do i=1,nres
1903         gel_loc_loc(i)=0.0d0
1904         gcorr_loc(i)=0.0d0
1905       enddo
1906       do i=iatel_s,iatel_e
1907         if (itel(i).eq.0) goto 1215
1908         dxi=dc(1,i)
1909         dyi=dc(2,i)
1910         dzi=dc(3,i)
1911         dx_normi=dc_norm(1,i)
1912         dy_normi=dc_norm(2,i)
1913         dz_normi=dc_norm(3,i)
1914         xmedi=c(1,i)+0.5d0*dxi
1915         ymedi=c(2,i)+0.5d0*dyi
1916         zmedi=c(3,i)+0.5d0*dzi
1917         num_conti=0
1918 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1919         do j=ielstart(i),ielend(i)
1920           if (itel(j).eq.0) goto 1216
1921           ind=ind+1
1922           iteli=itel(i)
1923           itelj=itel(j)
1924           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1925           aaa=app(iteli,itelj)
1926           bbb=bpp(iteli,itelj)
1927 C Diagnostics only!!!
1928 c         aaa=0.0D0
1929 c         bbb=0.0D0
1930 c         ael6i=0.0D0
1931 c         ael3i=0.0D0
1932 C End diagnostics
1933           ael6i=ael6(iteli,itelj)
1934           ael3i=ael3(iteli,itelj)
1935           dxj=dc(1,j)
1936           dyj=dc(2,j)
1937           dzj=dc(3,j)
1938           dx_normj=dc_norm(1,j)
1939           dy_normj=dc_norm(2,j)
1940           dz_normj=dc_norm(3,j)
1941           xj=c(1,j)+0.5D0*dxj-xmedi
1942           yj=c(2,j)+0.5D0*dyj-ymedi
1943           zj=c(3,j)+0.5D0*dzj-zmedi
1944           rij=xj*xj+yj*yj+zj*zj
1945           rrmij=1.0D0/rij
1946           rij=dsqrt(rij)
1947           rmij=1.0D0/rij
1948           r3ij=rrmij*rmij
1949           r6ij=r3ij*r3ij
1950           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1951           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1952           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1953           fac=cosa-3.0D0*cosb*cosg
1954           ev1=aaa*r6ij*r6ij
1955 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1956           if (j.eq.i+2) ev1=scal_el*ev1
1957           ev2=bbb*r6ij
1958           fac3=ael6i*r6ij
1959           fac4=ael3i*r3ij
1960           evdwij=ev1+ev2
1961           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1962           el2=fac4*fac
1963           eesij=el1+el2
1964 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1965 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1966           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1967           ees=ees+eesij
1968           evdw1=evdw1+evdwij
1969 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1970 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1971 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1972 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1973 C
1974 C Calculate contributions to the Cartesian gradient.
1975 C
1976 #ifdef SPLITELE
1977           facvdw=-6*rrmij*(ev1+evdwij)
1978           facel=-3*rrmij*(el1+eesij)
1979           fac1=fac
1980           erij(1)=xj*rmij
1981           erij(2)=yj*rmij
1982           erij(3)=zj*rmij
1983           if (calc_grad) then
1984 *
1985 * Radial derivatives. First process both termini of the fragment (i,j)
1986 *
1987           ggg(1)=facel*xj
1988           ggg(2)=facel*yj
1989           ggg(3)=facel*zj
1990           do k=1,3
1991             ghalf=0.5D0*ggg(k)
1992             gelc(k,i)=gelc(k,i)+ghalf
1993             gelc(k,j)=gelc(k,j)+ghalf
1994           enddo
1995 *
1996 * Loop over residues i+1 thru j-1.
1997 *
1998           do k=i+1,j-1
1999             do l=1,3
2000               gelc(l,k)=gelc(l,k)+ggg(l)
2001             enddo
2002           enddo
2003           ggg(1)=facvdw*xj
2004           ggg(2)=facvdw*yj
2005           ggg(3)=facvdw*zj
2006           do k=1,3
2007             ghalf=0.5D0*ggg(k)
2008             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2009             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2010           enddo
2011 *
2012 * Loop over residues i+1 thru j-1.
2013 *
2014           do k=i+1,j-1
2015             do l=1,3
2016               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2017             enddo
2018           enddo
2019 #else
2020           facvdw=ev1+evdwij
2021           facel=el1+eesij
2022           fac1=fac
2023           fac=-3*rrmij*(facvdw+facvdw+facel)
2024           erij(1)=xj*rmij
2025           erij(2)=yj*rmij
2026           erij(3)=zj*rmij
2027           if (calc_grad) then
2028 *
2029 * Radial derivatives. First process both termini of the fragment (i,j)
2030 *
2031           ggg(1)=fac*xj
2032           ggg(2)=fac*yj
2033           ggg(3)=fac*zj
2034           do k=1,3
2035             ghalf=0.5D0*ggg(k)
2036             gelc(k,i)=gelc(k,i)+ghalf
2037             gelc(k,j)=gelc(k,j)+ghalf
2038           enddo
2039 *
2040 * Loop over residues i+1 thru j-1.
2041 *
2042           do k=i+1,j-1
2043             do l=1,3
2044               gelc(l,k)=gelc(l,k)+ggg(l)
2045             enddo
2046           enddo
2047 #endif
2048 *
2049 * Angular part
2050 *
2051           ecosa=2.0D0*fac3*fac1+fac4
2052           fac4=-3.0D0*fac4
2053           fac3=-6.0D0*fac3
2054           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2055           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2056           do k=1,3
2057             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2058             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2059           enddo
2060 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2061 cd   &          (dcosg(k),k=1,3)
2062           do k=1,3
2063             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2064           enddo
2065           do k=1,3
2066             ghalf=0.5D0*ggg(k)
2067             gelc(k,i)=gelc(k,i)+ghalf
2068      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2069      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2070             gelc(k,j)=gelc(k,j)+ghalf
2071      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2072      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2073           enddo
2074           do k=i+1,j-1
2075             do l=1,3
2076               gelc(l,k)=gelc(l,k)+ggg(l)
2077             enddo
2078           enddo
2079           endif
2080
2081           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2082      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2083      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2084 C
2085 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2086 C   energy of a peptide unit is assumed in the form of a second-order
2087 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2088 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2089 C   are computed for EVERY pair of non-contiguous peptide groups.
2090 C
2091           if (j.lt.nres-1) then
2092             j1=j+1
2093             j2=j-1
2094           else
2095             j1=j-1
2096             j2=j-2
2097           endif
2098           kkk=0
2099           do k=1,2
2100             do l=1,2
2101               kkk=kkk+1
2102               muij(kkk)=mu(k,i)*mu(l,j)
2103             enddo
2104           enddo
2105 cd         write (iout,*) 'EELEC: i',i,' j',j
2106 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2107 cd          write(iout,*) 'muij',muij
2108           ury=scalar(uy(1,i),erij)
2109           urz=scalar(uz(1,i),erij)
2110           vry=scalar(uy(1,j),erij)
2111           vrz=scalar(uz(1,j),erij)
2112           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2113           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2114           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2115           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2116 C For diagnostics only
2117 cd          a22=1.0d0
2118 cd          a23=1.0d0
2119 cd          a32=1.0d0
2120 cd          a33=1.0d0
2121           fac=dsqrt(-ael6i)*r3ij
2122 cd          write (2,*) 'fac=',fac
2123 C For diagnostics only
2124 cd          fac=1.0d0
2125           a22=a22*fac
2126           a23=a23*fac
2127           a32=a32*fac
2128           a33=a33*fac
2129 cd          write (iout,'(4i5,4f10.5)')
2130 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2131 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2132 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2133 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2134 cd          write (iout,'(4f10.5)')
2135 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2136 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2137 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2138 cd           write (iout,'(2i3,9f10.5/)') i,j,
2139 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2140           if (calc_grad) then
2141 C Derivatives of the elements of A in virtual-bond vectors
2142           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2143 cd          do k=1,3
2144 cd            do l=1,3
2145 cd              erder(k,l)=0.0d0
2146 cd            enddo
2147 cd          enddo
2148           do k=1,3
2149             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2150             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2151             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2152             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2153             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2154             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2155             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2156             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2157             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2158             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2159             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2160             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2161           enddo
2162 cd          do k=1,3
2163 cd            do l=1,3
2164 cd              uryg(k,l)=0.0d0
2165 cd              urzg(k,l)=0.0d0
2166 cd              vryg(k,l)=0.0d0
2167 cd              vrzg(k,l)=0.0d0
2168 cd            enddo
2169 cd          enddo
2170 C Compute radial contributions to the gradient
2171           facr=-3.0d0*rrmij
2172           a22der=a22*facr
2173           a23der=a23*facr
2174           a32der=a32*facr
2175           a33der=a33*facr
2176 cd          a22der=0.0d0
2177 cd          a23der=0.0d0
2178 cd          a32der=0.0d0
2179 cd          a33der=0.0d0
2180           agg(1,1)=a22der*xj
2181           agg(2,1)=a22der*yj
2182           agg(3,1)=a22der*zj
2183           agg(1,2)=a23der*xj
2184           agg(2,2)=a23der*yj
2185           agg(3,2)=a23der*zj
2186           agg(1,3)=a32der*xj
2187           agg(2,3)=a32der*yj
2188           agg(3,3)=a32der*zj
2189           agg(1,4)=a33der*xj
2190           agg(2,4)=a33der*yj
2191           agg(3,4)=a33der*zj
2192 C Add the contributions coming from er
2193           fac3=-3.0d0*fac
2194           do k=1,3
2195             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2196             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2197             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2198             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2199           enddo
2200           do k=1,3
2201 C Derivatives in DC(i)
2202             ghalf1=0.5d0*agg(k,1)
2203             ghalf2=0.5d0*agg(k,2)
2204             ghalf3=0.5d0*agg(k,3)
2205             ghalf4=0.5d0*agg(k,4)
2206             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2207      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2208             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2209      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2210             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2211      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2212             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2213      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2214 C Derivatives in DC(i+1)
2215             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2216      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2217             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2218      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2219             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2220      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2221             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2222      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2223 C Derivatives in DC(j)
2224             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2226             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2227      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2228             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2230             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2231      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2232 C Derivatives in DC(j+1) or DC(nres-1)
2233             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vryg(k,3)*ury)
2235             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2236      &      -3.0d0*vrzg(k,3)*ury)
2237             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vryg(k,3)*urz)
2239             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2240      &      -3.0d0*vrzg(k,3)*urz)
2241 cd            aggi(k,1)=ghalf1
2242 cd            aggi(k,2)=ghalf2
2243 cd            aggi(k,3)=ghalf3
2244 cd            aggi(k,4)=ghalf4
2245 C Derivatives in DC(i+1)
2246 cd            aggi1(k,1)=agg(k,1)
2247 cd            aggi1(k,2)=agg(k,2)
2248 cd            aggi1(k,3)=agg(k,3)
2249 cd            aggi1(k,4)=agg(k,4)
2250 C Derivatives in DC(j)
2251 cd            aggj(k,1)=ghalf1
2252 cd            aggj(k,2)=ghalf2
2253 cd            aggj(k,3)=ghalf3
2254 cd            aggj(k,4)=ghalf4
2255 C Derivatives in DC(j+1)
2256 cd            aggj1(k,1)=0.0d0
2257 cd            aggj1(k,2)=0.0d0
2258 cd            aggj1(k,3)=0.0d0
2259 cd            aggj1(k,4)=0.0d0
2260             if (j.eq.nres-1 .and. i.lt.j-2) then
2261               do l=1,4
2262                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2263 cd                aggj1(k,l)=agg(k,l)
2264               enddo
2265             endif
2266           enddo
2267           endif
2268 c          goto 11111
2269 C Check the loc-el terms by numerical integration
2270           acipa(1,1)=a22
2271           acipa(1,2)=a23
2272           acipa(2,1)=a32
2273           acipa(2,2)=a33
2274           a22=-a22
2275           a23=-a23
2276           do l=1,2
2277             do k=1,3
2278               agg(k,l)=-agg(k,l)
2279               aggi(k,l)=-aggi(k,l)
2280               aggi1(k,l)=-aggi1(k,l)
2281               aggj(k,l)=-aggj(k,l)
2282               aggj1(k,l)=-aggj1(k,l)
2283             enddo
2284           enddo
2285           if (j.lt.nres-1) then
2286             a22=-a22
2287             a32=-a32
2288             do l=1,3,2
2289               do k=1,3
2290                 agg(k,l)=-agg(k,l)
2291                 aggi(k,l)=-aggi(k,l)
2292                 aggi1(k,l)=-aggi1(k,l)
2293                 aggj(k,l)=-aggj(k,l)
2294                 aggj1(k,l)=-aggj1(k,l)
2295               enddo
2296             enddo
2297           else
2298             a22=-a22
2299             a23=-a23
2300             a32=-a32
2301             a33=-a33
2302             do l=1,4
2303               do k=1,3
2304                 agg(k,l)=-agg(k,l)
2305                 aggi(k,l)=-aggi(k,l)
2306                 aggi1(k,l)=-aggi1(k,l)
2307                 aggj(k,l)=-aggj(k,l)
2308                 aggj1(k,l)=-aggj1(k,l)
2309               enddo
2310             enddo
2311           endif
2312           ENDIF ! WCORR
2313 11111     continue
2314           IF (wel_loc.gt.0.0d0) THEN
2315 C Contribution to the local-electrostatic energy coming from the i-j pair
2316           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2317      &     +a33*muij(4)
2318 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2319 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2320           eel_loc=eel_loc+eel_loc_ij
2321 C Partial derivatives in virtual-bond dihedral angles gamma
2322           if (calc_grad) then
2323           if (i.gt.1)
2324      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2325      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2326      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2327           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2328      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2329      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2330 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2331 cd          write(iout,*) 'agg  ',agg
2332 cd          write(iout,*) 'aggi ',aggi
2333 cd          write(iout,*) 'aggi1',aggi1
2334 cd          write(iout,*) 'aggj ',aggj
2335 cd          write(iout,*) 'aggj1',aggj1
2336
2337 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2338           do l=1,3
2339             ggg(l)=agg(l,1)*muij(1)+
2340      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2341           enddo
2342           do k=i+2,j2
2343             do l=1,3
2344               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2345             enddo
2346           enddo
2347 C Remaining derivatives of eello
2348           do l=1,3
2349             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2350      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2351             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2352      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2353             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2354      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2355             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2356      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2357           enddo
2358           endif
2359           ENDIF
2360           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2361 C Contributions from turns
2362             a_temp(1,1)=a22
2363             a_temp(1,2)=a23
2364             a_temp(2,1)=a32
2365             a_temp(2,2)=a33
2366             call eturn34(i,j,eello_turn3,eello_turn4)
2367           endif
2368 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2369           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2370 C
2371 C Calculate the contact function. The ith column of the array JCONT will
2372 C contain the numbers of atoms that make contacts with the atom I (of numbers
2373 C greater than I). The arrays FACONT and GACONT will contain the values of
2374 C the contact function and its derivative.
2375 c           r0ij=1.02D0*rpp(iteli,itelj)
2376 c           r0ij=1.11D0*rpp(iteli,itelj)
2377             r0ij=2.20D0*rpp(iteli,itelj)
2378 c           r0ij=1.55D0*rpp(iteli,itelj)
2379             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2380             if (fcont.gt.0.0D0) then
2381               num_conti=num_conti+1
2382               if (num_conti.gt.maxconts) then
2383                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2384      &                         ' will skip next contacts for this conf.'
2385               else
2386                 jcont_hb(num_conti,i)=j
2387                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2388      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2389 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2390 C  terms.
2391                 d_cont(num_conti,i)=rij
2392 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2393 C     --- Electrostatic-interaction matrix ---
2394                 a_chuj(1,1,num_conti,i)=a22
2395                 a_chuj(1,2,num_conti,i)=a23
2396                 a_chuj(2,1,num_conti,i)=a32
2397                 a_chuj(2,2,num_conti,i)=a33
2398 C     --- Gradient of rij
2399                 do kkk=1,3
2400                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2401                 enddo
2402 c             if (i.eq.1) then
2403 c                a_chuj(1,1,num_conti,i)=-0.61d0
2404 c                a_chuj(1,2,num_conti,i)= 0.4d0
2405 c                a_chuj(2,1,num_conti,i)= 0.65d0
2406 c                a_chuj(2,2,num_conti,i)= 0.50d0
2407 c             else if (i.eq.2) then
2408 c                a_chuj(1,1,num_conti,i)= 0.0d0
2409 c                a_chuj(1,2,num_conti,i)= 0.0d0
2410 c                a_chuj(2,1,num_conti,i)= 0.0d0
2411 c                a_chuj(2,2,num_conti,i)= 0.0d0
2412 c             endif
2413 C     --- and its gradients
2414 cd                write (iout,*) 'i',i,' j',j
2415 cd                do kkk=1,3
2416 cd                write (iout,*) 'iii 1 kkk',kkk
2417 cd                write (iout,*) agg(kkk,:)
2418 cd                enddo
2419 cd                do kkk=1,3
2420 cd                write (iout,*) 'iii 2 kkk',kkk
2421 cd                write (iout,*) aggi(kkk,:)
2422 cd                enddo
2423 cd                do kkk=1,3
2424 cd                write (iout,*) 'iii 3 kkk',kkk
2425 cd                write (iout,*) aggi1(kkk,:)
2426 cd                enddo
2427 cd                do kkk=1,3
2428 cd                write (iout,*) 'iii 4 kkk',kkk
2429 cd                write (iout,*) aggj(kkk,:)
2430 cd                enddo
2431 cd                do kkk=1,3
2432 cd                write (iout,*) 'iii 5 kkk',kkk
2433 cd                write (iout,*) aggj1(kkk,:)
2434 cd                enddo
2435                 kkll=0
2436                 do k=1,2
2437                   do l=1,2
2438                     kkll=kkll+1
2439                     do m=1,3
2440                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2441                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2442                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2443                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2444                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2445 c                      do mm=1,5
2446 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2447 c                      enddo
2448                     enddo
2449                   enddo
2450                 enddo
2451                 ENDIF
2452                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2453 C Calculate contact energies
2454                 cosa4=4.0D0*cosa
2455                 wij=cosa-3.0D0*cosb*cosg
2456                 cosbg1=cosb+cosg
2457                 cosbg2=cosb-cosg
2458 c               fac3=dsqrt(-ael6i)/r0ij**3
2459                 fac3=dsqrt(-ael6i)*r3ij
2460                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2461                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2462 c               ees0mij=0.0D0
2463                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2464                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2465 C Diagnostics. Comment out or remove after debugging!
2466 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2467 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2468 c               ees0m(num_conti,i)=0.0D0
2469 C End diagnostics.
2470 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2471 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2472                 facont_hb(num_conti,i)=fcont
2473                 if (calc_grad) then
2474 C Angular derivatives of the contact function
2475                 ees0pij1=fac3/ees0pij
2476                 ees0mij1=fac3/ees0mij
2477                 fac3p=-3.0D0*fac3*rrmij
2478                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2479                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2480 c               ees0mij1=0.0D0
2481                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2482                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2483                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2484                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2485                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2486                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2487                 ecosap=ecosa1+ecosa2
2488                 ecosbp=ecosb1+ecosb2
2489                 ecosgp=ecosg1+ecosg2
2490                 ecosam=ecosa1-ecosa2
2491                 ecosbm=ecosb1-ecosb2
2492                 ecosgm=ecosg1-ecosg2
2493 C Diagnostics
2494 c               ecosap=ecosa1
2495 c               ecosbp=ecosb1
2496 c               ecosgp=ecosg1
2497 c               ecosam=0.0D0
2498 c               ecosbm=0.0D0
2499 c               ecosgm=0.0D0
2500 C End diagnostics
2501                 fprimcont=fprimcont/rij
2502 cd              facont_hb(num_conti,i)=1.0D0
2503 C Following line is for diagnostics.
2504 cd              fprimcont=0.0D0
2505                 do k=1,3
2506                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2507                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2508                 enddo
2509                 do k=1,3
2510                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2511                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2512                 enddo
2513                 gggp(1)=gggp(1)+ees0pijp*xj
2514                 gggp(2)=gggp(2)+ees0pijp*yj
2515                 gggp(3)=gggp(3)+ees0pijp*zj
2516                 gggm(1)=gggm(1)+ees0mijp*xj
2517                 gggm(2)=gggm(2)+ees0mijp*yj
2518                 gggm(3)=gggm(3)+ees0mijp*zj
2519 C Derivatives due to the contact function
2520                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2521                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2522                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2523                 do k=1,3
2524                   ghalfp=0.5D0*gggp(k)
2525                   ghalfm=0.5D0*gggm(k)
2526                   gacontp_hb1(k,num_conti,i)=ghalfp
2527      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2528      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2529                   gacontp_hb2(k,num_conti,i)=ghalfp
2530      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2531      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2532                   gacontp_hb3(k,num_conti,i)=gggp(k)
2533                   gacontm_hb1(k,num_conti,i)=ghalfm
2534      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2535      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2536                   gacontm_hb2(k,num_conti,i)=ghalfm
2537      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2538      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2539                   gacontm_hb3(k,num_conti,i)=gggm(k)
2540                 enddo
2541                 endif
2542 C Diagnostics. Comment out or remove after debugging!
2543 cdiag           do k=1,3
2544 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2545 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2546 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2548 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2549 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2550 cdiag           enddo
2551               ENDIF ! wcorr
2552               endif  ! num_conti.le.maxconts
2553             endif  ! fcont.gt.0
2554           endif    ! j.gt.i+1
2555  1216     continue
2556         enddo ! j
2557         num_cont_hb(i)=num_conti
2558  1215   continue
2559       enddo   ! i
2560 cd      do i=1,nres
2561 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2562 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2563 cd      enddo
2564 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2565 ccc      eel_loc=eel_loc+eello_turn3
2566       return
2567       end
2568 C-----------------------------------------------------------------------------
2569       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2570 C Third- and fourth-order contributions from turns
2571       implicit real*8 (a-h,o-z)
2572       include 'DIMENSIONS'
2573       include 'DIMENSIONS.ZSCOPT'
2574       include 'COMMON.IOUNITS'
2575       include 'COMMON.GEO'
2576       include 'COMMON.VAR'
2577       include 'COMMON.LOCAL'
2578       include 'COMMON.CHAIN'
2579       include 'COMMON.DERIV'
2580       include 'COMMON.INTERACT'
2581       include 'COMMON.CONTACTS'
2582       include 'COMMON.TORSION'
2583       include 'COMMON.VECTORS'
2584       include 'COMMON.FFIELD'
2585       dimension ggg(3)
2586       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2587      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2588      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2589       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2590      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2591       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2592       if (j.eq.i+2) then
2593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2594 C
2595 C               Third-order contributions
2596 C
2597 C                 (i+2)o----(i+3)
2598 C                      | |
2599 C                      | |
2600 C                 (i+1)o----i
2601 C
2602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2603 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2604         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2605         call transpose2(auxmat(1,1),auxmat1(1,1))
2606         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2607         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2608 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2609 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2610 cd     &    ' eello_turn3_num',4*eello_turn3_num
2611         if (calc_grad) then
2612 C Derivatives in gamma(i)
2613         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2614         call transpose2(auxmat2(1,1),pizda(1,1))
2615         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2616         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2617 C Derivatives in gamma(i+1)
2618         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2619         call transpose2(auxmat2(1,1),pizda(1,1))
2620         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2621         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2622      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2623 C Cartesian derivatives
2624         do l=1,3
2625           a_temp(1,1)=aggi(l,1)
2626           a_temp(1,2)=aggi(l,2)
2627           a_temp(2,1)=aggi(l,3)
2628           a_temp(2,2)=aggi(l,4)
2629           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2630           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2631      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2632           a_temp(1,1)=aggi1(l,1)
2633           a_temp(1,2)=aggi1(l,2)
2634           a_temp(2,1)=aggi1(l,3)
2635           a_temp(2,2)=aggi1(l,4)
2636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2637           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2639           a_temp(1,1)=aggj(l,1)
2640           a_temp(1,2)=aggj(l,2)
2641           a_temp(2,1)=aggj(l,3)
2642           a_temp(2,2)=aggj(l,4)
2643           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2644           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2645      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2646           a_temp(1,1)=aggj1(l,1)
2647           a_temp(1,2)=aggj1(l,2)
2648           a_temp(2,1)=aggj1(l,3)
2649           a_temp(2,2)=aggj1(l,4)
2650           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2651           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2652      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2653         enddo
2654         endif
2655       else if (j.eq.i+3) then
2656 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2657 C
2658 C               Fourth-order contributions
2659 C
2660 C                 (i+3)o----(i+4)
2661 C                     /  |
2662 C               (i+2)o   |
2663 C                     \  |
2664 C                 (i+1)o----i
2665 C
2666 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2667 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2668         iti1=itortyp(itype(i+1))
2669         iti2=itortyp(itype(i+2))
2670         iti3=itortyp(itype(i+3))
2671         call transpose2(EUg(1,1,i+1),e1t(1,1))
2672         call transpose2(Eug(1,1,i+2),e2t(1,1))
2673         call transpose2(Eug(1,1,i+3),e3t(1,1))
2674         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2675         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2676         s1=scalar2(b1(1,iti2),auxvec(1))
2677         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2678         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2679         s2=scalar2(b1(1,iti1),auxvec(1))
2680         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2681         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2682         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2683         eello_turn4=eello_turn4-(s1+s2+s3)
2684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2685 cd     &    ' eello_turn4_num',8*eello_turn4_num
2686 C Derivatives in gamma(i)
2687         if (calc_grad) then
2688         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2689         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2690         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2691         s1=scalar2(b1(1,iti2),auxvec(1))
2692         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2693         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2694         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2695 C Derivatives in gamma(i+1)
2696         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2697         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2698         s2=scalar2(b1(1,iti1),auxvec(1))
2699         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2700         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2702         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2703 C Derivatives in gamma(i+2)
2704         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2705         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2706         s1=scalar2(b1(1,iti2),auxvec(1))
2707         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2708         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2709         s2=scalar2(b1(1,iti1),auxvec(1))
2710         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2711         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2712         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2713         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2714 C Cartesian derivatives
2715 C Derivatives of this turn contributions in DC(i+2)
2716         if (j.lt.nres-1) then
2717           do l=1,3
2718             a_temp(1,1)=agg(l,1)
2719             a_temp(1,2)=agg(l,2)
2720             a_temp(2,1)=agg(l,3)
2721             a_temp(2,2)=agg(l,4)
2722             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2723             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2724             s1=scalar2(b1(1,iti2),auxvec(1))
2725             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2726             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2727             s2=scalar2(b1(1,iti1),auxvec(1))
2728             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2729             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2730             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2731             ggg(l)=-(s1+s2+s3)
2732             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2733           enddo
2734         endif
2735 C Remaining derivatives of this turn contribution
2736         do l=1,3
2737           a_temp(1,1)=aggi(l,1)
2738           a_temp(1,2)=aggi(l,2)
2739           a_temp(2,1)=aggi(l,3)
2740           a_temp(2,2)=aggi(l,4)
2741           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2742           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2743           s1=scalar2(b1(1,iti2),auxvec(1))
2744           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2745           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2746           s2=scalar2(b1(1,iti1),auxvec(1))
2747           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2748           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2749           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2750           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2751           a_temp(1,1)=aggi1(l,1)
2752           a_temp(1,2)=aggi1(l,2)
2753           a_temp(2,1)=aggi1(l,3)
2754           a_temp(2,2)=aggi1(l,4)
2755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2757           s1=scalar2(b1(1,iti2),auxvec(1))
2758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2760           s2=scalar2(b1(1,iti1),auxvec(1))
2761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2765           a_temp(1,1)=aggj(l,1)
2766           a_temp(1,2)=aggj(l,2)
2767           a_temp(2,1)=aggj(l,3)
2768           a_temp(2,2)=aggj(l,4)
2769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2771           s1=scalar2(b1(1,iti2),auxvec(1))
2772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2774           s2=scalar2(b1(1,iti1),auxvec(1))
2775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2778           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2779           a_temp(1,1)=aggj1(l,1)
2780           a_temp(1,2)=aggj1(l,2)
2781           a_temp(2,1)=aggj1(l,3)
2782           a_temp(2,2)=aggj1(l,4)
2783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2785           s1=scalar2(b1(1,iti2),auxvec(1))
2786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2788           s2=scalar2(b1(1,iti1),auxvec(1))
2789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2792           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2793         enddo
2794         endif
2795       endif
2796       return
2797       end
2798 C-----------------------------------------------------------------------------
2799       subroutine vecpr(u,v,w)
2800       implicit real*8(a-h,o-z)
2801       dimension u(3),v(3),w(3)
2802       w(1)=u(2)*v(3)-u(3)*v(2)
2803       w(2)=-u(1)*v(3)+u(3)*v(1)
2804       w(3)=u(1)*v(2)-u(2)*v(1)
2805       return
2806       end
2807 C-----------------------------------------------------------------------------
2808       subroutine unormderiv(u,ugrad,unorm,ungrad)
2809 C This subroutine computes the derivatives of a normalized vector u, given
2810 C the derivatives computed without normalization conditions, ugrad. Returns
2811 C ungrad.
2812       implicit none
2813       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2814       double precision vec(3)
2815       double precision scalar
2816       integer i,j
2817 c      write (2,*) 'ugrad',ugrad
2818 c      write (2,*) 'u',u
2819       do i=1,3
2820         vec(i)=scalar(ugrad(1,i),u(1))
2821       enddo
2822 c      write (2,*) 'vec',vec
2823       do i=1,3
2824         do j=1,3
2825           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2826         enddo
2827       enddo
2828 c      write (2,*) 'ungrad',ungrad
2829       return
2830       end
2831 C-----------------------------------------------------------------------------
2832       subroutine escp(evdw2,evdw2_14)
2833 C
2834 C This subroutine calculates the excluded-volume interaction energy between
2835 C peptide-group centers and side chains and its gradient in virtual-bond and
2836 C side-chain vectors.
2837 C
2838       implicit real*8 (a-h,o-z)
2839       include 'DIMENSIONS'
2840       include 'DIMENSIONS.ZSCOPT'
2841       include 'COMMON.GEO'
2842       include 'COMMON.VAR'
2843       include 'COMMON.LOCAL'
2844       include 'COMMON.CHAIN'
2845       include 'COMMON.DERIV'
2846       include 'COMMON.INTERACT'
2847       include 'COMMON.FFIELD'
2848       include 'COMMON.IOUNITS'
2849       dimension ggg(3)
2850       evdw2=0.0D0
2851       evdw2_14=0.0d0
2852 cd    print '(a)','Enter ESCP'
2853 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2854 c     &  ' scal14',scal14
2855       do i=iatscp_s,iatscp_e
2856         iteli=itel(i)
2857 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2858 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2859         if (iteli.eq.0) goto 1225
2860         xi=0.5D0*(c(1,i)+c(1,i+1))
2861         yi=0.5D0*(c(2,i)+c(2,i+1))
2862         zi=0.5D0*(c(3,i)+c(3,i+1))
2863
2864         do iint=1,nscp_gr(i)
2865
2866         do j=iscpstart(i,iint),iscpend(i,iint)
2867           itypj=itype(j)
2868 C Uncomment following three lines for SC-p interactions
2869 c         xj=c(1,nres+j)-xi
2870 c         yj=c(2,nres+j)-yi
2871 c         zj=c(3,nres+j)-zi
2872 C Uncomment following three lines for Ca-p interactions
2873           xj=c(1,j)-xi
2874           yj=c(2,j)-yi
2875           zj=c(3,j)-zi
2876           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2877           fac=rrij**expon2
2878           e1=fac*fac*aad(itypj,iteli)
2879           e2=fac*bad(itypj,iteli)
2880           if (iabs(j-i) .le. 2) then
2881             e1=scal14*e1
2882             e2=scal14*e2
2883             evdw2_14=evdw2_14+e1+e2
2884           endif
2885           evdwij=e1+e2
2886 c          write (iout,*) i,j,evdwij
2887           evdw2=evdw2+evdwij
2888           if (calc_grad) then
2889 C
2890 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2891 C
2892           fac=-(evdwij+e1)*rrij
2893           ggg(1)=xj*fac
2894           ggg(2)=yj*fac
2895           ggg(3)=zj*fac
2896           if (j.lt.i) then
2897 cd          write (iout,*) 'j<i'
2898 C Uncomment following three lines for SC-p interactions
2899 c           do k=1,3
2900 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2901 c           enddo
2902           else
2903 cd          write (iout,*) 'j>i'
2904             do k=1,3
2905               ggg(k)=-ggg(k)
2906 C Uncomment following line for SC-p interactions
2907 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2908             enddo
2909           endif
2910           do k=1,3
2911             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2912           enddo
2913           kstart=min0(i+1,j)
2914           kend=max0(i-1,j-1)
2915 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2916 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2917           do k=kstart,kend
2918             do l=1,3
2919               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2920             enddo
2921           enddo
2922           endif
2923         enddo
2924         enddo ! iint
2925  1225   continue
2926       enddo ! i
2927       do i=1,nct
2928         do j=1,3
2929           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2930           gradx_scp(j,i)=expon*gradx_scp(j,i)
2931         enddo
2932       enddo
2933 C******************************************************************************
2934 C
2935 C                              N O T E !!!
2936 C
2937 C To save time the factor EXPON has been extracted from ALL components
2938 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2939 C use!
2940 C
2941 C******************************************************************************
2942       return
2943       end
2944 C--------------------------------------------------------------------------
2945       subroutine edis(ehpb)
2946 C
2947 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2948 C
2949       implicit real*8 (a-h,o-z)
2950       include 'DIMENSIONS'
2951       include 'DIMENSIONS.FREE'
2952       include 'COMMON.SBRIDGE'
2953       include 'COMMON.CHAIN'
2954       include 'COMMON.DERIV'
2955       include 'COMMON.VAR'
2956       include 'COMMON.INTERACT'
2957       include 'COMMON.IOUNITS'
2958       include 'COMMON.CONTROL'
2959       dimension ggg(3)
2960       ehpb=0.0D0
2961 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2962 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2963       if (link_end.eq.0) return
2964       do i=link_start,link_end
2965 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2966 C CA-CA distance used in regularization of structure.
2967         ii=ihpb(i)
2968         jj=jhpb(i)
2969 C iii and jjj point to the residues for which the distance is assigned.
2970         if (ii.gt.nres) then
2971           iii=ii-nres
2972           jjj=jj-nres
2973         else
2974           iii=ii
2975           jjj=jj
2976         endif
2977 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2978 c     &    dhpb(i),dhpb1(i),forcon(i)
2979 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2980 C    distance and angle dependent SS bond potential.
2981         if (.not.dyn_ss .and. i.le.nss) then
2982 C 15/02/13 CC dynamic SSbond - additional check
2983         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2984           call ssbond_ene(iii,jjj,eij)
2985           ehpb=ehpb+2*eij
2986          endif
2987 cd          write (iout,*) "eij",eij
2988         else if (ii.gt.nres .and. jj.gt.nres) then
2989 c Restraints from contact prediction
2990           dd=dist(ii,jj)
2991          if (constr_dist.eq.11) then
2992             ehpb=ehpb+fordepth(i)**4.0d0
2993      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2994             fac=fordepth(i)**4.0d0
2995      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2996          else
2997           if (dhpb1(i).gt.0.0d0) then
2998             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2999             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3000 c            write (iout,*) "beta nmr",
3001 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3002           else
3003             dd=dist(ii,jj)
3004             rdis=dd-dhpb(i)
3005 C Get the force constant corresponding to this distance.
3006             waga=forcon(i)
3007 C Calculate the contribution to energy.
3008             ehpb=ehpb+waga*rdis*rdis
3009 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3010 C
3011 C Evaluate gradient.
3012 C
3013             fac=waga*rdis/dd
3014           endif !end dhpb1(i).gt.0
3015          endif !end const_dist=11
3016           do j=1,3
3017             ggg(j)=fac*(c(j,jj)-c(j,ii))
3018           enddo
3019           do j=1,3
3020             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3021             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3022           enddo
3023           do k=1,3
3024             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3025             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3026           enddo
3027         else
3028 C Calculate the distance between the two points and its difference from the
3029 C target distance.
3030           dd=dist(ii,jj)
3031 C          write(iout,*) "after",dd
3032           if (constr_dist.eq.11) then
3033             ehpb=ehpb+fordepth(i)**4.0d0
3034      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3035             fac=fordepth(i)**4.0d0
3036      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3037 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3038 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3039 C            print *,ehpb,"tu?"
3040 C            write(iout,*) ehpb,"btu?",
3041 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3042 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3043 C     &    ehpb,fordepth(i),dd
3044            else
3045           if (dhpb1(i).gt.0.0d0) then
3046             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3047             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3048 c            write (iout,*) "alph nmr",
3049 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3050           else
3051             rdis=dd-dhpb(i)
3052 C Get the force constant corresponding to this distance.
3053             waga=forcon(i)
3054 C Calculate the contribution to energy.
3055             ehpb=ehpb+waga*rdis*rdis
3056 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3057 C
3058 C Evaluate gradient.
3059 C
3060             fac=waga*rdis/dd
3061           endif
3062           endif
3063 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3064 cd   &   ' waga=',waga,' fac=',fac
3065             do j=1,3
3066               ggg(j)=fac*(c(j,jj)-c(j,ii))
3067             enddo
3068 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3069 C If this is a SC-SC distance, we need to calculate the contributions to the
3070 C Cartesian gradient in the SC vectors (ghpbx).
3071           if (iii.lt.ii) then
3072           do j=1,3
3073             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3074             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3075           enddo
3076           endif
3077           do k=1,3
3078             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3079             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3080           enddo
3081         endif
3082       enddo
3083       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3084       return
3085       end
3086 C--------------------------------------------------------------------------
3087       subroutine ssbond_ene(i,j,eij)
3088 C
3089 C Calculate the distance and angle dependent SS-bond potential energy
3090 C using a free-energy function derived based on RHF/6-31G** ab initio
3091 C calculations of diethyl disulfide.
3092 C
3093 C A. Liwo and U. Kozlowska, 11/24/03
3094 C
3095       implicit real*8 (a-h,o-z)
3096       include 'DIMENSIONS'
3097       include 'DIMENSIONS.ZSCOPT'
3098       include 'COMMON.SBRIDGE'
3099       include 'COMMON.CHAIN'
3100       include 'COMMON.DERIV'
3101       include 'COMMON.LOCAL'
3102       include 'COMMON.INTERACT'
3103       include 'COMMON.VAR'
3104       include 'COMMON.IOUNITS'
3105       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3106       itypi=itype(i)
3107       xi=c(1,nres+i)
3108       yi=c(2,nres+i)
3109       zi=c(3,nres+i)
3110       dxi=dc_norm(1,nres+i)
3111       dyi=dc_norm(2,nres+i)
3112       dzi=dc_norm(3,nres+i)
3113       dsci_inv=dsc_inv(itypi)
3114       itypj=itype(j)
3115       dscj_inv=dsc_inv(itypj)
3116       xj=c(1,nres+j)-xi
3117       yj=c(2,nres+j)-yi
3118       zj=c(3,nres+j)-zi
3119       dxj=dc_norm(1,nres+j)
3120       dyj=dc_norm(2,nres+j)
3121       dzj=dc_norm(3,nres+j)
3122       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3123       rij=dsqrt(rrij)
3124       erij(1)=xj*rij
3125       erij(2)=yj*rij
3126       erij(3)=zj*rij
3127       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3128       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3129       om12=dxi*dxj+dyi*dyj+dzi*dzj
3130       do k=1,3
3131         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3132         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3133       enddo
3134       rij=1.0d0/rij
3135       deltad=rij-d0cm
3136       deltat1=1.0d0-om1
3137       deltat2=1.0d0+om2
3138       deltat12=om2-om1+2.0d0
3139       cosphi=om12-om1*om2
3140       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3141      &  +akct*deltad*deltat12+ebr
3142 c     &  +akct*deltad*deltat12
3143      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3144       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3145      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3146      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3147       ed=2*akcm*deltad+akct*deltat12
3148       pom1=akct*deltad
3149       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3150       eom1=-2*akth*deltat1-pom1-om2*pom2
3151       eom2= 2*akth*deltat2+pom1-om1*pom2
3152       eom12=pom2
3153       do k=1,3
3154         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3155       enddo
3156       do k=1,3
3157         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3158      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3159         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3160      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3161       enddo
3162 C
3163 C Calculate the components of the gradient in DC and X
3164 C
3165       do k=i,j-1
3166         do l=1,3
3167           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3168         enddo
3169       enddo
3170       return
3171       end
3172 C--------------------------------------------------------------------------
3173 c MODELLER restraint function
3174       subroutine e_modeller(ehomology_constr)
3175       implicit real*8 (a-h,o-z)
3176       include 'DIMENSIONS'
3177       include 'DIMENSIONS.ZSCOPT'
3178       include 'DIMENSIONS.FREE'
3179       integer nnn, i, j, k, ki, irec, l
3180       integer katy, odleglosci, test7
3181       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3182       real*8 distance(max_template),distancek(max_template),
3183      &    min_odl,godl(max_template),dih_diff(max_template)
3184
3185 c
3186 c     FP - 30/10/2014 Temporary specifications for homology restraints
3187 c
3188       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3189      &                 sgtheta
3190       double precision, dimension (maxres) :: guscdiff,usc_diff
3191       double precision, dimension (max_template) ::
3192      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3193      &           theta_diff
3194
3195       include 'COMMON.SBRIDGE'
3196       include 'COMMON.CHAIN'
3197       include 'COMMON.GEO'
3198       include 'COMMON.DERIV'
3199       include 'COMMON.LOCAL'
3200       include 'COMMON.INTERACT'
3201       include 'COMMON.VAR'
3202       include 'COMMON.IOUNITS'
3203       include 'COMMON.CONTROL'
3204       include 'COMMON.HOMRESTR'
3205 c
3206       include 'COMMON.SETUP'
3207       include 'COMMON.NAMES'
3208
3209       do i=1,max_template
3210         distancek(i)=9999999.9
3211       enddo
3212
3213       odleg=0.0d0
3214
3215 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3216 c function)
3217 C AL 5/2/14 - Introduce list of restraints
3218 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3219 #ifdef DEBUG
3220       write(iout,*) "------- dist restrs start -------"
3221 #endif
3222       do ii = link_start_homo,link_end_homo
3223          i = ires_homo(ii)
3224          j = jres_homo(ii)
3225          dij=dist(i,j)
3226 c        write (iout,*) "dij(",i,j,") =",dij
3227          nexl=0
3228          do k=1,constr_homology
3229            if(.not.l_homo(k,ii)) then
3230               nexl=nexl+1
3231               cycle
3232            endif
3233            distance(k)=odl(k,ii)-dij
3234 c          write (iout,*) "distance(",k,") =",distance(k)
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3239 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3240 c          write (iout,*) "distancek(",k,") =",distancek(k)
3241 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3242 c
3243 c          For Lorentzian-type Urestr
3244 c
3245            if (waga_dist.lt.0.0d0) then
3246               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3247               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3248      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3249            endif
3250          enddo
3251
3252 c         min_odl=minval(distancek)
3253          do kk=1,constr_homology
3254           if(l_homo(kk,ii)) then
3255             min_odl=distancek(kk)
3256             exit
3257           endif
3258          enddo
3259          do kk=1,constr_homology
3260           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3261      &              min_odl=distancek(kk)
3262          enddo
3263 c        write (iout,* )"min_odl",min_odl
3264 #ifdef DEBUG
3265          write (iout,*) "ij dij",i,j,dij
3266          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3267          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3268          write (iout,* )"min_odl",min_odl
3269 #endif
3270 #ifdef OLDRESTR
3271          odleg2=0.0d0
3272 #else
3273          if (waga_dist.ge.0.0d0) then
3274            odleg2=nexl
3275          else
3276            odleg2=0.0d0
3277          endif
3278 #endif
3279          do k=1,constr_homology
3280 c Nie wiem po co to liczycie jeszcze raz!
3281 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3282 c     &              (2*(sigma_odl(i,j,k))**2))
3283            if(.not.l_homo(k,ii)) cycle
3284            if (waga_dist.ge.0.0d0) then
3285 c
3286 c          For Gaussian-type Urestr
3287 c
3288             godl(k)=dexp(-distancek(k)+min_odl)
3289             odleg2=odleg2+godl(k)
3290 c
3291 c          For Lorentzian-type Urestr
3292 c
3293            else
3294             odleg2=odleg2+distancek(k)
3295            endif
3296
3297 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3298 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3299 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3300 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3301
3302          enddo
3303 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3304 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3305 #ifdef DEBUG
3306          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3307          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3308 #endif
3309            if (waga_dist.ge.0.0d0) then
3310 c
3311 c          For Gaussian-type Urestr
3312 c
3313               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3314 c
3315 c          For Lorentzian-type Urestr
3316 c
3317            else
3318               odleg=odleg+odleg2/constr_homology
3319            endif
3320 c
3321 #ifdef GRAD
3322 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3323 c Gradient
3324 c
3325 c          For Gaussian-type Urestr
3326 c
3327          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3328          sum_sgodl=0.0d0
3329          do k=1,constr_homology
3330 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3331 c     &           *waga_dist)+min_odl
3332 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3333 c
3334          if(.not.l_homo(k,ii)) cycle
3335          if (waga_dist.ge.0.0d0) then
3336 c          For Gaussian-type Urestr
3337 c
3338            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3339 c
3340 c          For Lorentzian-type Urestr
3341 c
3342          else
3343            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3344      &           sigma_odlir(k,ii)**2)**2)
3345          endif
3346            sum_sgodl=sum_sgodl+sgodl
3347
3348 c            sgodl2=sgodl2+sgodl
3349 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3350 c      write(iout,*) "constr_homology=",constr_homology
3351 c      write(iout,*) i, j, k, "TEST K"
3352          enddo
3353          if (waga_dist.ge.0.0d0) then
3354 c
3355 c          For Gaussian-type Urestr
3356 c
3357             grad_odl3=waga_homology(iset)*waga_dist
3358      &                *sum_sgodl/(sum_godl*dij)
3359 c
3360 c          For Lorentzian-type Urestr
3361 c
3362          else
3363 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3364 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3365             grad_odl3=-waga_homology(iset)*waga_dist*
3366      &                sum_sgodl/(constr_homology*dij)
3367          endif
3368 c
3369 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3370
3371
3372 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3373 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3374 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3375
3376 ccc      write(iout,*) godl, sgodl, grad_odl3
3377
3378 c          grad_odl=grad_odl+grad_odl3
3379
3380          do jik=1,3
3381             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3382 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3383 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3384 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3385             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3386             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3387 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3388 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3389 c         if (i.eq.25.and.j.eq.27) then
3390 c         write(iout,*) "jik",jik,"i",i,"j",j
3391 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3392 c         write(iout,*) "grad_odl3",grad_odl3
3393 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3394 c         write(iout,*) "ggodl",ggodl
3395 c         write(iout,*) "ghpbc(",jik,i,")",
3396 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3397 c     &                 ghpbc(jik,j)
3398 c         endif
3399          enddo
3400 #endif
3401 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3402 ccc     & dLOG(odleg2),"-odleg=", -odleg
3403
3404       enddo ! ii-loop for dist
3405 #ifdef DEBUG
3406       write(iout,*) "------- dist restrs end -------"
3407 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3408 c    &     waga_d.eq.1.0d0) call sum_gradient
3409 #endif
3410 c Pseudo-energy and gradient from dihedral-angle restraints from
3411 c homology templates
3412 c      write (iout,*) "End of distance loop"
3413 c      call flush(iout)
3414       kat=0.0d0
3415 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3416 #ifdef DEBUG
3417       write(iout,*) "------- dih restrs start -------"
3418       do i=idihconstr_start_homo,idihconstr_end_homo
3419         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3420       enddo
3421 #endif
3422       do i=idihconstr_start_homo,idihconstr_end_homo
3423 #ifdef OLDRESTR
3424         kat2=0.0d0
3425 #else
3426         kat2=nexl
3427 #endif
3428 c        betai=beta(i,i+1,i+2,i+3)
3429         betai = phi(i)
3430 c       write (iout,*) "betai =",betai
3431         do k=1,constr_homology
3432           dih_diff(k)=pinorm(dih(k,i)-betai)
3433 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3434 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3435 c     &                                   -(6.28318-dih_diff(i,k))
3436 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3437 c     &                                   6.28318+dih_diff(i,k)
3438 #ifdef OLD_DIHED
3439           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3440 #else
3441           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
3442 #endif
3443 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3444           gdih(k)=dexp(kat3)
3445           kat2=kat2+gdih(k)
3446 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3447 c          write(*,*)""
3448         enddo
3449 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3450 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3451 #ifdef DEBUG
3452         write (iout,*) "i",i," betai",betai," kat2",kat2
3453         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3454 #endif
3455         if (kat2.le.1.0d-14) cycle
3456         kat=kat-dLOG(kat2/constr_homology)
3457 c       write (iout,*) "kat",kat ! sum of -ln-s
3458
3459 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3460 ccc     & dLOG(kat2), "-kat=", -kat
3461
3462 #ifdef GRAD
3463 c ----------------------------------------------------------------------
3464 c Gradient
3465 c ----------------------------------------------------------------------
3466
3467         sum_gdih=kat2
3468         sum_sgdih=0.0d0
3469         do k=1,constr_homology
3470 #ifdef OLD_DIHED
3471           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3472 #else
3473           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
3474 #endif
3475 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3476           sum_sgdih=sum_sgdih+sgdih
3477         enddo
3478 c       grad_dih3=sum_sgdih/sum_gdih
3479         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3480
3481 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3482 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3483 ccc     & gloc(nphi+i-3,icg)
3484         gloc(i,icg)=gloc(i,icg)+grad_dih3
3485 c        if (i.eq.25) then
3486 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3487 c        endif
3488 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3489 ccc     & gloc(nphi+i-3,icg)
3490 #endif
3491       enddo ! i-loop for dih
3492 #ifdef DEBUG
3493       write(iout,*) "------- dih restrs end -------"
3494 #endif
3495
3496 c Pseudo-energy and gradient for theta angle restraints from
3497 c homology templates
3498 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3499 c adapted
3500
3501 c
3502 c     For constr_homology reference structures (FP)
3503 c
3504 c     Uconst_back_tot=0.0d0
3505       Eval=0.0d0
3506       Erot=0.0d0
3507 c     Econstr_back legacy
3508 #ifdef GRAD
3509       do i=1,nres
3510 c     do i=ithet_start,ithet_end
3511        dutheta(i)=0.0d0
3512 c     enddo
3513 c     do i=loc_start,loc_end
3514         do j=1,3
3515           duscdiff(j,i)=0.0d0
3516           duscdiffx(j,i)=0.0d0
3517         enddo
3518       enddo
3519 #endif
3520 c
3521 c     do iref=1,nref
3522 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3523 c     write (iout,*) "waga_theta",waga_theta
3524       if (waga_theta.gt.0.0d0) then
3525 #ifdef DEBUG
3526       write (iout,*) "usampl",usampl
3527       write(iout,*) "------- theta restrs start -------"
3528 c     do i=ithet_start,ithet_end
3529 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3530 c     enddo
3531 #endif
3532 c     write (iout,*) "maxres",maxres,"nres",nres
3533
3534       do i=ithet_start,ithet_end
3535 c
3536 c     do i=1,nfrag_back
3537 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3538 c
3539 c Deviation of theta angles wrt constr_homology ref structures
3540 c
3541         utheta_i=0.0d0 ! argument of Gaussian for single k
3542 #ifdef OLDRESTR
3543         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3544 #else
3545         gutheta_i=nexl
3546 #endif
3547 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3548 c       over residues in a fragment
3549 c       write (iout,*) "theta(",i,")=",theta(i)
3550         do k=1,constr_homology
3551 c
3552 c         dtheta_i=theta(j)-thetaref(j,iref)
3553 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3554           theta_diff(k)=thetatpl(k,i)-theta(i)
3555 c
3556           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3557 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3558           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3559           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3560 c         Gradient for single Gaussian restraint in subr Econstr_back
3561 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3562 c
3563         enddo
3564 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3565 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3566
3567 c
3568 #ifdef GRAD
3569 c         Gradient for multiple Gaussian restraint
3570         sum_gtheta=gutheta_i
3571         sum_sgtheta=0.0d0
3572         do k=1,constr_homology
3573 c        New generalized expr for multiple Gaussian from Econstr_back
3574          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3575 c
3576 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3577           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3578         enddo
3579 c
3580 c       Final value of gradient using same var as in Econstr_back
3581         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3582      &               *waga_homology(iset)
3583 c       dutheta(i)=sum_sgtheta/sum_gtheta
3584 c
3585 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3586 #endif
3587         Eval=Eval-dLOG(gutheta_i/constr_homology)
3588 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3589 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3590 c       Uconst_back=Uconst_back+utheta(i)
3591       enddo ! (i-loop for theta)
3592 #ifdef DEBUG
3593       write(iout,*) "------- theta restrs end -------"
3594 #endif
3595       endif
3596 c
3597 c Deviation of local SC geometry
3598 c
3599 c Separation of two i-loops (instructed by AL - 11/3/2014)
3600 c
3601 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3602 c     write (iout,*) "waga_d",waga_d
3603
3604 #ifdef DEBUG
3605       write(iout,*) "------- SC restrs start -------"
3606       write (iout,*) "Initial duscdiff,duscdiffx"
3607       do i=loc_start,loc_end
3608         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3609      &                 (duscdiffx(jik,i),jik=1,3)
3610       enddo
3611 #endif
3612       do i=loc_start,loc_end
3613         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3614 #ifdef OLDRESTR
3615         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3616 #else
3617         guscdiff(i)=nexl
3618 #endif
3619 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3620 c       write(iout,*) "xxtab, yytab, zztab"
3621 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3622         do k=1,constr_homology
3623 c
3624           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3625 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3626           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3627           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3628 c         write(iout,*) "dxx, dyy, dzz"
3629 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3630 c
3631           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3632 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3633 c         uscdiffk(k)=usc_diff(i)
3634           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3635           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3636 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3637 c     &      xxref(j),yyref(j),zzref(j)
3638         enddo
3639 c
3640 c       Gradient
3641 c
3642 c       Generalized expression for multiple Gaussian acc to that for a single
3643 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3644 c
3645 c       Original implementation
3646 c       sum_guscdiff=guscdiff(i)
3647 c
3648 c       sum_sguscdiff=0.0d0
3649 c       do k=1,constr_homology
3650 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3651 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3652 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3653 c       enddo
3654 c
3655 c       Implementation of new expressions for gradient (Jan. 2015)
3656 c
3657 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3658 #ifdef GRAD
3659         do k=1,constr_homology
3660 c
3661 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3662 c       before. Now the drivatives should be correct
3663 c
3664           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3665 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3666           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3667           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3668 c
3669 c         New implementation
3670 c
3671           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3672      &                 sigma_d(k,i) ! for the grad wrt r'
3673 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3674 c
3675 c
3676 c        New implementation
3677          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3678          do jik=1,3
3679             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3680      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3681      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3682             duscdiff(jik,i)=duscdiff(jik,i)+
3683      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3684      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3685             duscdiffx(jik,i)=duscdiffx(jik,i)+
3686      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3687      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3688 c
3689 #ifdef DEBUG
3690              write(iout,*) "jik",jik,"i",i
3691              write(iout,*) "dxx, dyy, dzz"
3692              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3693              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3694 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3695 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3696 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3697 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3698 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3699 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3700 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3701 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3702 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3703 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3704 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3705 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3706 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3707 c            endif
3708 #endif
3709          enddo
3710         enddo
3711 #endif
3712 c
3713 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3714 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3715 c
3716 c        write (iout,*) i," uscdiff",uscdiff(i)
3717 c
3718 c Put together deviations from local geometry
3719
3720 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3721 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3722         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3723 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3724 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3725 c       Uconst_back=Uconst_back+usc_diff(i)
3726 c
3727 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3728 c
3729 c     New implment: multiplied by sum_sguscdiff
3730 c
3731
3732       enddo ! (i-loop for dscdiff)
3733
3734 c      endif
3735
3736 #ifdef DEBUG
3737       write(iout,*) "------- SC restrs end -------"
3738         write (iout,*) "------ After SC loop in e_modeller ------"
3739         do i=loc_start,loc_end
3740          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3741          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3742         enddo
3743       if (waga_theta.eq.1.0d0) then
3744       write (iout,*) "in e_modeller after SC restr end: dutheta"
3745       do i=ithet_start,ithet_end
3746         write (iout,*) i,dutheta(i)
3747       enddo
3748       endif
3749       if (waga_d.eq.1.0d0) then
3750       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3751       do i=1,nres
3752         write (iout,*) i,(duscdiff(j,i),j=1,3)
3753         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3754       enddo
3755       endif
3756 #endif
3757
3758 c Total energy from homology restraints
3759 #ifdef DEBUG
3760       write (iout,*) "odleg",odleg," kat",kat
3761       write (iout,*) "odleg",odleg," kat",kat
3762       write (iout,*) "Eval",Eval," Erot",Erot
3763       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3764       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3765       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3766 #endif
3767 c
3768 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3769 c
3770 c     ehomology_constr=odleg+kat
3771 c
3772 c     For Lorentzian-type Urestr
3773 c
3774
3775       if (waga_dist.ge.0.0d0) then
3776 c
3777 c          For Gaussian-type Urestr
3778 c
3779 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3780 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3781         ehomology_constr=waga_dist*odleg+waga_angle*kat+
3782      &              waga_theta*Eval+waga_d*Erot
3783 c     write (iout,*) "ehomology_constr=",ehomology_constr
3784       else
3785 c
3786 c          For Lorentzian-type Urestr
3787 c
3788 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3789 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3790         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
3791      &              waga_theta*Eval+waga_d*Erot
3792 c     write (iout,*) "ehomology_constr=",ehomology_constr
3793       endif
3794 #ifdef DEBUG
3795       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
3796      & "Eval",waga_theta,eval,
3797      &   "Erot",waga_d,Erot
3798       write (iout,*) "ehomology_constr",ehomology_constr
3799 #endif
3800       return
3801
3802   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3803   747 format(a12,i4,i4,i4,f8.3,f8.3)
3804   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3805   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3806   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3807      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3808       end
3809 c-----------------------------------------------------------------------
3810       subroutine ebond(estr)
3811 c
3812 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3813 c
3814       implicit real*8 (a-h,o-z)
3815       include 'DIMENSIONS'
3816       include 'DIMENSIONS.ZSCOPT'
3817       include 'DIMENSIONS.FREE'
3818       include 'COMMON.LOCAL'
3819       include 'COMMON.GEO'
3820       include 'COMMON.INTERACT'
3821       include 'COMMON.DERIV'
3822       include 'COMMON.VAR'
3823       include 'COMMON.CHAIN'
3824       include 'COMMON.IOUNITS'
3825       include 'COMMON.NAMES'
3826       include 'COMMON.FFIELD'
3827       include 'COMMON.CONTROL'
3828       double precision u(3),ud(3)
3829       logical :: lprn=.false.
3830       estr=0.0d0
3831       do i=nnt+1,nct
3832         diff = vbld(i)-vbldp0
3833 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3834         estr=estr+diff*diff
3835         do j=1,3
3836           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3837         enddo
3838       enddo
3839       estr=0.5d0*AKP*estr
3840 c
3841 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3842 c
3843       do i=nnt,nct
3844         iti=itype(i)
3845         if (iti.ne.10) then
3846           nbi=nbondterm(iti)
3847           if (nbi.eq.1) then
3848             diff=vbld(i+nres)-vbldsc0(1,iti)
3849             if (lprn)
3850      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3851      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3852             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3853             do j=1,3
3854               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3855             enddo
3856           else
3857             do j=1,nbi
3858               diff=vbld(i+nres)-vbldsc0(j,iti)
3859               ud(j)=aksc(j,iti)*diff
3860               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3861             enddo
3862             uprod=u(1)
3863             do j=2,nbi
3864               uprod=uprod*u(j)
3865             enddo
3866             usum=0.0d0
3867             usumsqder=0.0d0
3868             do j=1,nbi
3869               uprod1=1.0d0
3870               uprod2=1.0d0
3871               do k=1,nbi
3872                 if (k.ne.j) then
3873                   uprod1=uprod1*u(k)
3874                   uprod2=uprod2*u(k)*u(k)
3875                 endif
3876               enddo
3877               usum=usum+uprod1
3878               usumsqder=usumsqder+ud(j)*uprod2
3879             enddo
3880             if (lprn)
3881      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3882      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3883             estr=estr+uprod/usum
3884             do j=1,3
3885              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3886             enddo
3887           endif
3888         endif
3889       enddo
3890       return
3891       end
3892 #ifdef CRYST_THETA
3893 C--------------------------------------------------------------------------
3894       subroutine ebend(etheta)
3895 C
3896 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3897 C angles gamma and its derivatives in consecutive thetas and gammas.
3898 C
3899       implicit real*8 (a-h,o-z)
3900       include 'DIMENSIONS'
3901       include 'DIMENSIONS.ZSCOPT'
3902       include 'COMMON.LOCAL'
3903       include 'COMMON.GEO'
3904       include 'COMMON.INTERACT'
3905       include 'COMMON.DERIV'
3906       include 'COMMON.VAR'
3907       include 'COMMON.CHAIN'
3908       include 'COMMON.IOUNITS'
3909       include 'COMMON.NAMES'
3910       include 'COMMON.FFIELD'
3911       common /calcthet/ term1,term2,termm,diffak,ratak,
3912      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3913      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3914       double precision y(2),z(2)
3915       delta=0.02d0*pi
3916       time11=dexp(-2*time)
3917       time12=1.0d0
3918       etheta=0.0D0
3919 c      write (iout,*) "nres",nres
3920 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3921 c      write (iout,*) ithet_start,ithet_end
3922       do i=ithet_start,ithet_end
3923 C Zero the energy function and its derivative at 0 or pi.
3924         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3925         it=itype(i-1)
3926 c        if (i.gt.ithet_start .and.
3927 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3928 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3929 c          phii=phi(i)
3930 c          y(1)=dcos(phii)
3931 c          y(2)=dsin(phii)
3932 c        else
3933 c          y(1)=0.0D0
3934 c          y(2)=0.0D0
3935 c        endif
3936 c        if (i.lt.nres .and. itel(i).ne.0) then
3937 c          phii1=phi(i+1)
3938 c          z(1)=dcos(phii1)
3939 c          z(2)=dsin(phii1)
3940 c        else
3941 c          z(1)=0.0D0
3942 c          z(2)=0.0D0
3943 c        endif
3944         if (i.gt.3) then
3945 #ifdef OSF
3946           phii=phi(i)
3947           icrc=0
3948           call proc_proc(phii,icrc)
3949           if (icrc.eq.1) phii=150.0
3950 #else
3951           phii=phi(i)
3952 #endif
3953           y(1)=dcos(phii)
3954           y(2)=dsin(phii)
3955         else
3956           y(1)=0.0D0
3957           y(2)=0.0D0
3958         endif
3959         if (i.lt.nres) then
3960 #ifdef OSF
3961           phii1=phi(i+1)
3962           icrc=0
3963           call proc_proc(phii1,icrc)
3964           if (icrc.eq.1) phii1=150.0
3965           phii1=pinorm(phii1)
3966           z(1)=cos(phii1)
3967 #else
3968           phii1=phi(i+1)
3969           z(1)=dcos(phii1)
3970 #endif
3971           z(2)=dsin(phii1)
3972         else
3973           z(1)=0.0D0
3974           z(2)=0.0D0
3975         endif
3976 C Calculate the "mean" value of theta from the part of the distribution
3977 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3978 C In following comments this theta will be referred to as t_c.
3979         thet_pred_mean=0.0d0
3980         do k=1,2
3981           athetk=athet(k,it)
3982           bthetk=bthet(k,it)
3983           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3984         enddo
3985 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3986         dthett=thet_pred_mean*ssd
3987         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3988 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3989 C Derivatives of the "mean" values in gamma1 and gamma2.
3990         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3991         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3992         if (theta(i).gt.pi-delta) then
3993           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3994      &         E_tc0)
3995           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3996           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3997           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3998      &        E_theta)
3999           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4000      &        E_tc)
4001         else if (theta(i).lt.delta) then
4002           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4003           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4004           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4005      &        E_theta)
4006           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4007           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4008      &        E_tc)
4009         else
4010           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4011      &        E_theta,E_tc)
4012         endif
4013         etheta=etheta+ethetai
4014 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4015 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4016         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4017         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4018         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4019  1215   continue
4020       enddo
4021 C Ufff.... We've done all this!!!
4022       return
4023       end
4024 C---------------------------------------------------------------------------
4025       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4026      &     E_tc)
4027       implicit real*8 (a-h,o-z)
4028       include 'DIMENSIONS'
4029       include 'COMMON.LOCAL'
4030       include 'COMMON.IOUNITS'
4031       common /calcthet/ term1,term2,termm,diffak,ratak,
4032      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4033      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4034 C Calculate the contributions to both Gaussian lobes.
4035 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4036 C The "polynomial part" of the "standard deviation" of this part of
4037 C the distribution.
4038         sig=polthet(3,it)
4039         do j=2,0,-1
4040           sig=sig*thet_pred_mean+polthet(j,it)
4041         enddo
4042 C Derivative of the "interior part" of the "standard deviation of the"
4043 C gamma-dependent Gaussian lobe in t_c.
4044         sigtc=3*polthet(3,it)
4045         do j=2,1,-1
4046           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4047         enddo
4048         sigtc=sig*sigtc
4049 C Set the parameters of both Gaussian lobes of the distribution.
4050 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4051         fac=sig*sig+sigc0(it)
4052         sigcsq=fac+fac
4053         sigc=1.0D0/sigcsq
4054 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4055         sigsqtc=-4.0D0*sigcsq*sigtc
4056 c       print *,i,sig,sigtc,sigsqtc
4057 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4058         sigtc=-sigtc/(fac*fac)
4059 C Following variable is sigma(t_c)**(-2)
4060         sigcsq=sigcsq*sigcsq
4061         sig0i=sig0(it)
4062         sig0inv=1.0D0/sig0i**2
4063         delthec=thetai-thet_pred_mean
4064         delthe0=thetai-theta0i
4065         term1=-0.5D0*sigcsq*delthec*delthec
4066         term2=-0.5D0*sig0inv*delthe0*delthe0
4067 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4068 C NaNs in taking the logarithm. We extract the largest exponent which is added
4069 C to the energy (this being the log of the distribution) at the end of energy
4070 C term evaluation for this virtual-bond angle.
4071         if (term1.gt.term2) then
4072           termm=term1
4073           term2=dexp(term2-termm)
4074           term1=1.0d0
4075         else
4076           termm=term2
4077           term1=dexp(term1-termm)
4078           term2=1.0d0
4079         endif
4080 C The ratio between the gamma-independent and gamma-dependent lobes of
4081 C the distribution is a Gaussian function of thet_pred_mean too.
4082         diffak=gthet(2,it)-thet_pred_mean
4083         ratak=diffak/gthet(3,it)**2
4084         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4085 C Let's differentiate it in thet_pred_mean NOW.
4086         aktc=ak*ratak
4087 C Now put together the distribution terms to make complete distribution.
4088         termexp=term1+ak*term2
4089         termpre=sigc+ak*sig0i
4090 C Contribution of the bending energy from this theta is just the -log of
4091 C the sum of the contributions from the two lobes and the pre-exponential
4092 C factor. Simple enough, isn't it?
4093         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4094 C NOW the derivatives!!!
4095 C 6/6/97 Take into account the deformation.
4096         E_theta=(delthec*sigcsq*term1
4097      &       +ak*delthe0*sig0inv*term2)/termexp
4098         E_tc=((sigtc+aktc*sig0i)/termpre
4099      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4100      &       aktc*term2)/termexp)
4101       return
4102       end
4103 c-----------------------------------------------------------------------------
4104       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4105       implicit real*8 (a-h,o-z)
4106       include 'DIMENSIONS'
4107       include 'COMMON.LOCAL'
4108       include 'COMMON.IOUNITS'
4109       common /calcthet/ term1,term2,termm,diffak,ratak,
4110      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4111      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4112       delthec=thetai-thet_pred_mean
4113       delthe0=thetai-theta0i
4114 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4115       t3 = thetai-thet_pred_mean
4116       t6 = t3**2
4117       t9 = term1
4118       t12 = t3*sigcsq
4119       t14 = t12+t6*sigsqtc
4120       t16 = 1.0d0
4121       t21 = thetai-theta0i
4122       t23 = t21**2
4123       t26 = term2
4124       t27 = t21*t26
4125       t32 = termexp
4126       t40 = t32**2
4127       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4128      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4129      & *(-t12*t9-ak*sig0inv*t27)
4130       return
4131       end
4132 #else
4133 C--------------------------------------------------------------------------
4134       subroutine ebend(etheta)
4135 C
4136 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4137 C angles gamma and its derivatives in consecutive thetas and gammas.
4138 C ab initio-derived potentials from
4139 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4140 C
4141       implicit real*8 (a-h,o-z)
4142       include 'DIMENSIONS'
4143       include 'DIMENSIONS.ZSCOPT'
4144       include 'DIMENSIONS.FREE'
4145       include 'COMMON.LOCAL'
4146       include 'COMMON.GEO'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.DERIV'
4149       include 'COMMON.VAR'
4150       include 'COMMON.CHAIN'
4151       include 'COMMON.IOUNITS'
4152       include 'COMMON.NAMES'
4153       include 'COMMON.FFIELD'
4154       include 'COMMON.CONTROL'
4155       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4156      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4157      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4158      & sinph1ph2(maxdouble,maxdouble)
4159       logical lprn /.false./, lprn1 /.false./
4160       etheta=0.0D0
4161 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4162       do i=ithet_start,ithet_end
4163         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4164      &    (itype(i).eq.ntyp1)) cycle
4165         dethetai=0.0d0
4166         dephii=0.0d0
4167         dephii1=0.0d0
4168         theti2=0.5d0*theta(i)
4169         ityp2=ithetyp(itype(i-1))
4170         do k=1,nntheterm
4171           coskt(k)=dcos(k*theti2)
4172           sinkt(k)=dsin(k*theti2)
4173         enddo
4174         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4175 #ifdef OSF
4176           phii=phi(i)
4177           if (phii.ne.phii) phii=150.0
4178 #else
4179           phii=phi(i)
4180 #endif
4181           ityp1=ithetyp(itype(i-2))
4182           do k=1,nsingle
4183             cosph1(k)=dcos(k*phii)
4184             sinph1(k)=dsin(k*phii)
4185           enddo
4186         else
4187           phii=0.0d0
4188           ityp1=ithetyp(itype(i-2))
4189           do k=1,nsingle
4190             cosph1(k)=0.0d0
4191             sinph1(k)=0.0d0
4192           enddo
4193         endif
4194         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4195 #ifdef OSF
4196           phii1=phi(i+1)
4197           if (phii1.ne.phii1) phii1=150.0
4198           phii1=pinorm(phii1)
4199 #else
4200           phii1=phi(i+1)
4201 #endif
4202           ityp3=ithetyp(itype(i))
4203           do k=1,nsingle
4204             cosph2(k)=dcos(k*phii1)
4205             sinph2(k)=dsin(k*phii1)
4206           enddo
4207         else
4208           phii1=0.0d0
4209 c          ityp3=nthetyp+1
4210           ityp3=ithetyp(itype(i))
4211           do k=1,nsingle
4212             cosph2(k)=0.0d0
4213             sinph2(k)=0.0d0
4214           enddo
4215         endif
4216 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4217 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4218 c        call flush(iout)
4219         ethetai=aa0thet(ityp1,ityp2,ityp3)
4220         do k=1,ndouble
4221           do l=1,k-1
4222             ccl=cosph1(l)*cosph2(k-l)
4223             ssl=sinph1(l)*sinph2(k-l)
4224             scl=sinph1(l)*cosph2(k-l)
4225             csl=cosph1(l)*sinph2(k-l)
4226             cosph1ph2(l,k)=ccl-ssl
4227             cosph1ph2(k,l)=ccl+ssl
4228             sinph1ph2(l,k)=scl+csl
4229             sinph1ph2(k,l)=scl-csl
4230           enddo
4231         enddo
4232         if (lprn) then
4233         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4234      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4235         write (iout,*) "coskt and sinkt"
4236         do k=1,nntheterm
4237           write (iout,*) k,coskt(k),sinkt(k)
4238         enddo
4239         endif
4240         do k=1,ntheterm
4241           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4242           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4243      &      *coskt(k)
4244           if (lprn)
4245      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4246      &     " ethetai",ethetai
4247         enddo
4248         if (lprn) then
4249         write (iout,*) "cosph and sinph"
4250         do k=1,nsingle
4251           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4252         enddo
4253         write (iout,*) "cosph1ph2 and sinph2ph2"
4254         do k=2,ndouble
4255           do l=1,k-1
4256             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4257      &         sinph1ph2(l,k),sinph1ph2(k,l)
4258           enddo
4259         enddo
4260         write(iout,*) "ethetai",ethetai
4261         endif
4262         do m=1,ntheterm2
4263           do k=1,nsingle
4264             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4265      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4266      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4267      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4268             ethetai=ethetai+sinkt(m)*aux
4269             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4270             dephii=dephii+k*sinkt(m)*(
4271      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4272      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4273             dephii1=dephii1+k*sinkt(m)*(
4274      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4275      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4276             if (lprn)
4277      &      write (iout,*) "m",m," k",k," bbthet",
4278      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4279      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4280      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4281      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4282           enddo
4283         enddo
4284         if (lprn)
4285      &  write(iout,*) "ethetai",ethetai
4286         do m=1,ntheterm3
4287           do k=2,ndouble
4288             do l=1,k-1
4289               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4290      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4291      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4292      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4293               ethetai=ethetai+sinkt(m)*aux
4294               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4295               dephii=dephii+l*sinkt(m)*(
4296      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4297      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4298      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4299      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4300               dephii1=dephii1+(k-l)*sinkt(m)*(
4301      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4302      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4303      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4304      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4305               if (lprn) then
4306               write (iout,*) "m",m," k",k," l",l," ffthet",
4307      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4308      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4309      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4310      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4311               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4312      &            cosph1ph2(k,l)*sinkt(m),
4313      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4314               endif
4315             enddo
4316           enddo
4317         enddo
4318 10      continue
4319 c        lprn1=.true.
4320         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4321      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4322      &   phii1*rad2deg,ethetai
4323 c        lprn1=.false.
4324         etheta=etheta+ethetai
4325
4326         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4327         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4328         gloc(nphi+i-2,icg)=wang*dethetai
4329       enddo
4330       return
4331       end
4332 #endif
4333 #ifdef CRYST_SC
4334 c-----------------------------------------------------------------------------
4335       subroutine esc(escloc)
4336 C Calculate the local energy of a side chain and its derivatives in the
4337 C corresponding virtual-bond valence angles THETA and the spherical angles
4338 C ALPHA and OMEGA.
4339       implicit real*8 (a-h,o-z)
4340       include 'DIMENSIONS'
4341       include 'DIMENSIONS.ZSCOPT'
4342       include 'COMMON.GEO'
4343       include 'COMMON.LOCAL'
4344       include 'COMMON.VAR'
4345       include 'COMMON.INTERACT'
4346       include 'COMMON.DERIV'
4347       include 'COMMON.CHAIN'
4348       include 'COMMON.IOUNITS'
4349       include 'COMMON.NAMES'
4350       include 'COMMON.FFIELD'
4351       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4352      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4353       common /sccalc/ time11,time12,time112,theti,it,nlobit
4354       delta=0.02d0*pi
4355       escloc=0.0D0
4356 c     write (iout,'(a)') 'ESC'
4357       do i=loc_start,loc_end
4358         it=itype(i)
4359         if (it.eq.10) goto 1
4360         nlobit=nlob(it)
4361 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4362 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4363         theti=theta(i+1)-pipol
4364         x(1)=dtan(theti)
4365         x(2)=alph(i)
4366         x(3)=omeg(i)
4367 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4368
4369         if (x(2).gt.pi-delta) then
4370           xtemp(1)=x(1)
4371           xtemp(2)=pi-delta
4372           xtemp(3)=x(3)
4373           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4374           xtemp(2)=pi
4375           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4376           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4377      &        escloci,dersc(2))
4378           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4379      &        ddersc0(1),dersc(1))
4380           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4381      &        ddersc0(3),dersc(3))
4382           xtemp(2)=pi-delta
4383           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4384           xtemp(2)=pi
4385           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4386           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4387      &            dersc0(2),esclocbi,dersc02)
4388           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4389      &            dersc12,dersc01)
4390           call splinthet(x(2),0.5d0*delta,ss,ssd)
4391           dersc0(1)=dersc01
4392           dersc0(2)=dersc02
4393           dersc0(3)=0.0d0
4394           do k=1,3
4395             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4396           enddo
4397           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4398 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4399 c    &             esclocbi,ss,ssd
4400           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4401 c         escloci=esclocbi
4402 c         write (iout,*) escloci
4403         else if (x(2).lt.delta) then
4404           xtemp(1)=x(1)
4405           xtemp(2)=delta
4406           xtemp(3)=x(3)
4407           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4408           xtemp(2)=0.0d0
4409           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4410           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4411      &        escloci,dersc(2))
4412           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4413      &        ddersc0(1),dersc(1))
4414           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4415      &        ddersc0(3),dersc(3))
4416           xtemp(2)=delta
4417           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4418           xtemp(2)=0.0d0
4419           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4420           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4421      &            dersc0(2),esclocbi,dersc02)
4422           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4423      &            dersc12,dersc01)
4424           dersc0(1)=dersc01
4425           dersc0(2)=dersc02
4426           dersc0(3)=0.0d0
4427           call splinthet(x(2),0.5d0*delta,ss,ssd)
4428           do k=1,3
4429             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4430           enddo
4431           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4432 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4433 c    &             esclocbi,ss,ssd
4434           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4435 c         write (iout,*) escloci
4436         else
4437           call enesc(x,escloci,dersc,ddummy,.false.)
4438         endif
4439
4440         escloc=escloc+escloci
4441 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4442
4443         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4444      &   wscloc*dersc(1)
4445         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4446         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4447     1   continue
4448       enddo
4449       return
4450       end
4451 C---------------------------------------------------------------------------
4452       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4453       implicit real*8 (a-h,o-z)
4454       include 'DIMENSIONS'
4455       include 'COMMON.GEO'
4456       include 'COMMON.LOCAL'
4457       include 'COMMON.IOUNITS'
4458       common /sccalc/ time11,time12,time112,theti,it,nlobit
4459       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4460       double precision contr(maxlob,-1:1)
4461       logical mixed
4462 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4463         escloc_i=0.0D0
4464         do j=1,3
4465           dersc(j)=0.0D0
4466           if (mixed) ddersc(j)=0.0d0
4467         enddo
4468         x3=x(3)
4469
4470 C Because of periodicity of the dependence of the SC energy in omega we have
4471 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4472 C To avoid underflows, first compute & store the exponents.
4473
4474         do iii=-1,1
4475
4476           x(3)=x3+iii*dwapi
4477
4478           do j=1,nlobit
4479             do k=1,3
4480               z(k)=x(k)-censc(k,j,it)
4481             enddo
4482             do k=1,3
4483               Axk=0.0D0
4484               do l=1,3
4485                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4486               enddo
4487               Ax(k,j,iii)=Axk
4488             enddo
4489             expfac=0.0D0
4490             do k=1,3
4491               expfac=expfac+Ax(k,j,iii)*z(k)
4492             enddo
4493             contr(j,iii)=expfac
4494           enddo ! j
4495
4496         enddo ! iii
4497
4498         x(3)=x3
4499 C As in the case of ebend, we want to avoid underflows in exponentiation and
4500 C subsequent NaNs and INFs in energy calculation.
4501 C Find the largest exponent
4502         emin=contr(1,-1)
4503         do iii=-1,1
4504           do j=1,nlobit
4505             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4506           enddo
4507         enddo
4508         emin=0.5D0*emin
4509 cd      print *,'it=',it,' emin=',emin
4510
4511 C Compute the contribution to SC energy and derivatives
4512         do iii=-1,1
4513
4514           do j=1,nlobit
4515             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4516 cd          print *,'j=',j,' expfac=',expfac
4517             escloc_i=escloc_i+expfac
4518             do k=1,3
4519               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4520             enddo
4521             if (mixed) then
4522               do k=1,3,2
4523                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4524      &            +gaussc(k,2,j,it))*expfac
4525               enddo
4526             endif
4527           enddo
4528
4529         enddo ! iii
4530
4531         dersc(1)=dersc(1)/cos(theti)**2
4532         ddersc(1)=ddersc(1)/cos(theti)**2
4533         ddersc(3)=ddersc(3)
4534
4535         escloci=-(dlog(escloc_i)-emin)
4536         do j=1,3
4537           dersc(j)=dersc(j)/escloc_i
4538         enddo
4539         if (mixed) then
4540           do j=1,3,2
4541             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4542           enddo
4543         endif
4544       return
4545       end
4546 C------------------------------------------------------------------------------
4547       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4548       implicit real*8 (a-h,o-z)
4549       include 'DIMENSIONS'
4550       include 'COMMON.GEO'
4551       include 'COMMON.LOCAL'
4552       include 'COMMON.IOUNITS'
4553       common /sccalc/ time11,time12,time112,theti,it,nlobit
4554       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4555       double precision contr(maxlob)
4556       logical mixed
4557
4558       escloc_i=0.0D0
4559
4560       do j=1,3
4561         dersc(j)=0.0D0
4562       enddo
4563
4564       do j=1,nlobit
4565         do k=1,2
4566           z(k)=x(k)-censc(k,j,it)
4567         enddo
4568         z(3)=dwapi
4569         do k=1,3
4570           Axk=0.0D0
4571           do l=1,3
4572             Axk=Axk+gaussc(l,k,j,it)*z(l)
4573           enddo
4574           Ax(k,j)=Axk
4575         enddo
4576         expfac=0.0D0
4577         do k=1,3
4578           expfac=expfac+Ax(k,j)*z(k)
4579         enddo
4580         contr(j)=expfac
4581       enddo ! j
4582
4583 C As in the case of ebend, we want to avoid underflows in exponentiation and
4584 C subsequent NaNs and INFs in energy calculation.
4585 C Find the largest exponent
4586       emin=contr(1)
4587       do j=1,nlobit
4588         if (emin.gt.contr(j)) emin=contr(j)
4589       enddo
4590       emin=0.5D0*emin
4591
4592 C Compute the contribution to SC energy and derivatives
4593
4594       dersc12=0.0d0
4595       do j=1,nlobit
4596         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4597         escloc_i=escloc_i+expfac
4598         do k=1,2
4599           dersc(k)=dersc(k)+Ax(k,j)*expfac
4600         enddo
4601         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4602      &            +gaussc(1,2,j,it))*expfac
4603         dersc(3)=0.0d0
4604       enddo
4605
4606       dersc(1)=dersc(1)/cos(theti)**2
4607       dersc12=dersc12/cos(theti)**2
4608       escloci=-(dlog(escloc_i)-emin)
4609       do j=1,2
4610         dersc(j)=dersc(j)/escloc_i
4611       enddo
4612       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4613       return
4614       end
4615 #else
4616 c----------------------------------------------------------------------------------
4617       subroutine esc(escloc)
4618 C Calculate the local energy of a side chain and its derivatives in the
4619 C corresponding virtual-bond valence angles THETA and the spherical angles
4620 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4621 C added by Urszula Kozlowska. 07/11/2007
4622 C
4623       implicit real*8 (a-h,o-z)
4624       include 'DIMENSIONS'
4625       include 'DIMENSIONS.ZSCOPT'
4626       include 'DIMENSIONS.FREE'
4627       include 'COMMON.GEO'
4628       include 'COMMON.LOCAL'
4629       include 'COMMON.VAR'
4630       include 'COMMON.SCROT'
4631       include 'COMMON.INTERACT'
4632       include 'COMMON.DERIV'
4633       include 'COMMON.CHAIN'
4634       include 'COMMON.IOUNITS'
4635       include 'COMMON.NAMES'
4636       include 'COMMON.FFIELD'
4637       include 'COMMON.CONTROL'
4638       include 'COMMON.VECTORS'
4639       double precision x_prime(3),y_prime(3),z_prime(3)
4640      &    , sumene,dsc_i,dp2_i,x(65),
4641      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4642      &    de_dxx,de_dyy,de_dzz,de_dt
4643       double precision s1_t,s1_6_t,s2_t,s2_6_t
4644       double precision
4645      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4646      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4647      & dt_dCi(3),dt_dCi1(3)
4648       common /sccalc/ time11,time12,time112,theti,it,nlobit
4649       delta=0.02d0*pi
4650       escloc=0.0D0
4651       do i=loc_start,loc_end
4652         costtab(i+1) =dcos(theta(i+1))
4653         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4654         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4655         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4656         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4657         cosfac=dsqrt(cosfac2)
4658         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4659         sinfac=dsqrt(sinfac2)
4660         it=itype(i)
4661         if (it.eq.10) goto 1
4662 c
4663 C  Compute the axes of tghe local cartesian coordinates system; store in
4664 c   x_prime, y_prime and z_prime
4665 c
4666         do j=1,3
4667           x_prime(j) = 0.00
4668           y_prime(j) = 0.00
4669           z_prime(j) = 0.00
4670         enddo
4671 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4672 C     &   dc_norm(3,i+nres)
4673         do j = 1,3
4674           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4675           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4676         enddo
4677         do j = 1,3
4678           z_prime(j) = -uz(j,i-1)
4679         enddo
4680 c       write (2,*) "i",i
4681 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4682 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4683 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4684 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4685 c      & " xy",scalar(x_prime(1),y_prime(1)),
4686 c      & " xz",scalar(x_prime(1),z_prime(1)),
4687 c      & " yy",scalar(y_prime(1),y_prime(1)),
4688 c      & " yz",scalar(y_prime(1),z_prime(1)),
4689 c      & " zz",scalar(z_prime(1),z_prime(1))
4690 c
4691 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4692 C to local coordinate system. Store in xx, yy, zz.
4693 c
4694         xx=0.0d0
4695         yy=0.0d0
4696         zz=0.0d0
4697         do j = 1,3
4698           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4699           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4700           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4701         enddo
4702
4703         xxtab(i)=xx
4704         yytab(i)=yy
4705         zztab(i)=zz
4706 C
4707 C Compute the energy of the ith side cbain
4708 C
4709 c        write (2,*) "xx",xx," yy",yy," zz",zz
4710         it=itype(i)
4711         do j = 1,65
4712           x(j) = sc_parmin(j,it)
4713         enddo
4714 #ifdef CHECK_COORD
4715 Cc diagnostics - remove later
4716         xx1 = dcos(alph(2))
4717         yy1 = dsin(alph(2))*dcos(omeg(2))
4718         zz1 = -dsin(alph(2))*dsin(omeg(2))
4719         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4720      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4721      &    xx1,yy1,zz1
4722 C,"  --- ", xx_w,yy_w,zz_w
4723 c end diagnostics
4724 #endif
4725         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4726      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4727      &   + x(10)*yy*zz
4728         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4729      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4730      & + x(20)*yy*zz
4731         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4732      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4733      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4734      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4735      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4736      &  +x(40)*xx*yy*zz
4737         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4738      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4739      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4740      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4741      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4742      &  +x(60)*xx*yy*zz
4743         dsc_i   = 0.743d0+x(61)
4744         dp2_i   = 1.9d0+x(62)
4745         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4746      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4747         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4748      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4749         s1=(1+x(63))/(0.1d0 + dscp1)
4750         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4751         s2=(1+x(65))/(0.1d0 + dscp2)
4752         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4753         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4754      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4755 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4756 c     &   sumene4,
4757 c     &   dscp1,dscp2,sumene
4758 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4759         escloc = escloc + sumene
4760 c        write (2,*) "escloc",escloc
4761         if (.not. calc_grad) goto 1
4762
4763 #ifdef DEBUG2
4764 C
4765 C This section to check the numerical derivatives of the energy of ith side
4766 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4767 C #define DEBUG in the code to turn it on.
4768 C
4769         write (2,*) "sumene               =",sumene
4770         aincr=1.0d-7
4771         xxsave=xx
4772         xx=xx+aincr
4773         write (2,*) xx,yy,zz
4774         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4775         de_dxx_num=(sumenep-sumene)/aincr
4776         xx=xxsave
4777         write (2,*) "xx+ sumene from enesc=",sumenep
4778         yysave=yy
4779         yy=yy+aincr
4780         write (2,*) xx,yy,zz
4781         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4782         de_dyy_num=(sumenep-sumene)/aincr
4783         yy=yysave
4784         write (2,*) "yy+ sumene from enesc=",sumenep
4785         zzsave=zz
4786         zz=zz+aincr
4787         write (2,*) xx,yy,zz
4788         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4789         de_dzz_num=(sumenep-sumene)/aincr
4790         zz=zzsave
4791         write (2,*) "zz+ sumene from enesc=",sumenep
4792         costsave=cost2tab(i+1)
4793         sintsave=sint2tab(i+1)
4794         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4795         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4796         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4797         de_dt_num=(sumenep-sumene)/aincr
4798         write (2,*) " t+ sumene from enesc=",sumenep
4799         cost2tab(i+1)=costsave
4800         sint2tab(i+1)=sintsave
4801 C End of diagnostics section.
4802 #endif
4803 C
4804 C Compute the gradient of esc
4805 C
4806         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4807         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4808         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4809         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4810         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4811         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4812         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4813         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4814         pom1=(sumene3*sint2tab(i+1)+sumene1)
4815      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4816         pom2=(sumene4*cost2tab(i+1)+sumene2)
4817      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4818         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4819         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4820      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4821      &  +x(40)*yy*zz
4822         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4823         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4824      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4825      &  +x(60)*yy*zz
4826         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4827      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4828      &        +(pom1+pom2)*pom_dx
4829 #ifdef DEBUG
4830         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4831 #endif
4832 C
4833         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4834         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4835      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4836      &  +x(40)*xx*zz
4837         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4838         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4839      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4840      &  +x(59)*zz**2 +x(60)*xx*zz
4841         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4842      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4843      &        +(pom1-pom2)*pom_dy
4844 #ifdef DEBUG
4845         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4846 #endif
4847 C
4848         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4849      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4850      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4851      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4852      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4853      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4854      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4855      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4856 #ifdef DEBUG
4857         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4858 #endif
4859 C
4860         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4861      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4862      &  +pom1*pom_dt1+pom2*pom_dt2
4863 #ifdef DEBUG
4864         write(2,*), "de_dt = ", de_dt,de_dt_num
4865 #endif
4866 c
4867 C
4868        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4869        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4870        cosfac2xx=cosfac2*xx
4871        sinfac2yy=sinfac2*yy
4872        do k = 1,3
4873          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4874      &      vbld_inv(i+1)
4875          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4876      &      vbld_inv(i)
4877          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4878          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4879 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4880 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4881 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4882 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4883          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4884          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4885          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4886          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4887          dZZ_Ci1(k)=0.0d0
4888          dZZ_Ci(k)=0.0d0
4889          do j=1,3
4890            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4891            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4892          enddo
4893
4894          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4895          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4896          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4897 c
4898          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4899          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4900        enddo
4901
4902        do k=1,3
4903          dXX_Ctab(k,i)=dXX_Ci(k)
4904          dXX_C1tab(k,i)=dXX_Ci1(k)
4905          dYY_Ctab(k,i)=dYY_Ci(k)
4906          dYY_C1tab(k,i)=dYY_Ci1(k)
4907          dZZ_Ctab(k,i)=dZZ_Ci(k)
4908          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4909          dXX_XYZtab(k,i)=dXX_XYZ(k)
4910          dYY_XYZtab(k,i)=dYY_XYZ(k)
4911          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4912        enddo
4913
4914        do k = 1,3
4915 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4916 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4917 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4918 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4919 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4920 c     &    dt_dci(k)
4921 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4922 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4923          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4924      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4925          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4926      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4927          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4928      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4929        enddo
4930 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4931 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4932
4933 C to check gradient call subroutine check_grad
4934
4935     1 continue
4936       enddo
4937       return
4938       end
4939 #endif
4940 c------------------------------------------------------------------------------
4941       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4942 C
4943 C This procedure calculates two-body contact function g(rij) and its derivative:
4944 C
4945 C           eps0ij                                     !       x < -1
4946 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4947 C            0                                         !       x > 1
4948 C
4949 C where x=(rij-r0ij)/delta
4950 C
4951 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4952 C
4953       implicit none
4954       double precision rij,r0ij,eps0ij,fcont,fprimcont
4955       double precision x,x2,x4,delta
4956 c     delta=0.02D0*r0ij
4957 c      delta=0.2D0*r0ij
4958       x=(rij-r0ij)/delta
4959       if (x.lt.-1.0D0) then
4960         fcont=eps0ij
4961         fprimcont=0.0D0
4962       else if (x.le.1.0D0) then
4963         x2=x*x
4964         x4=x2*x2
4965         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4966         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4967       else
4968         fcont=0.0D0
4969         fprimcont=0.0D0
4970       endif
4971       return
4972       end
4973 c------------------------------------------------------------------------------
4974       subroutine splinthet(theti,delta,ss,ssder)
4975       implicit real*8 (a-h,o-z)
4976       include 'DIMENSIONS'
4977       include 'DIMENSIONS.ZSCOPT'
4978       include 'COMMON.VAR'
4979       include 'COMMON.GEO'
4980       thetup=pi-delta
4981       thetlow=delta
4982       if (theti.gt.pipol) then
4983         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4984       else
4985         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4986         ssder=-ssder
4987       endif
4988       return
4989       end
4990 c------------------------------------------------------------------------------
4991       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4992       implicit none
4993       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4994       double precision ksi,ksi2,ksi3,a1,a2,a3
4995       a1=fprim0*delta/(f1-f0)
4996       a2=3.0d0-2.0d0*a1
4997       a3=a1-2.0d0
4998       ksi=(x-x0)/delta
4999       ksi2=ksi*ksi
5000       ksi3=ksi2*ksi
5001       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5002       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5003       return
5004       end
5005 c------------------------------------------------------------------------------
5006       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5007       implicit none
5008       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5009       double precision ksi,ksi2,ksi3,a1,a2,a3
5010       ksi=(x-x0)/delta
5011       ksi2=ksi*ksi
5012       ksi3=ksi2*ksi
5013       a1=fprim0x*delta
5014       a2=3*(f1x-f0x)-2*fprim0x*delta
5015       a3=fprim0x*delta-2*(f1x-f0x)
5016       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5017       return
5018       end
5019 C-----------------------------------------------------------------------------
5020 #ifdef CRYST_TOR
5021 C-----------------------------------------------------------------------------
5022       subroutine etor(etors,edihcnstr,fact)
5023       implicit real*8 (a-h,o-z)
5024       include 'DIMENSIONS'
5025       include 'DIMENSIONS.ZSCOPT'
5026       include 'COMMON.VAR'
5027       include 'COMMON.GEO'
5028       include 'COMMON.LOCAL'
5029       include 'COMMON.TORSION'
5030       include 'COMMON.INTERACT'
5031       include 'COMMON.DERIV'
5032       include 'COMMON.CHAIN'
5033       include 'COMMON.NAMES'
5034       include 'COMMON.IOUNITS'
5035       include 'COMMON.FFIELD'
5036       include 'COMMON.TORCNSTR'
5037       logical lprn
5038 C Set lprn=.true. for debugging
5039       lprn=.false.
5040 c      lprn=.true.
5041       etors=0.0D0
5042       do i=iphi_start,iphi_end
5043         itori=itortyp(itype(i-2))
5044         itori1=itortyp(itype(i-1))
5045         phii=phi(i)
5046         gloci=0.0D0
5047 C Proline-Proline pair is a special case...
5048         if (itori.eq.3 .and. itori1.eq.3) then
5049           if (phii.gt.-dwapi3) then
5050             cosphi=dcos(3*phii)
5051             fac=1.0D0/(1.0D0-cosphi)
5052             etorsi=v1(1,3,3)*fac
5053             etorsi=etorsi+etorsi
5054             etors=etors+etorsi-v1(1,3,3)
5055             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5056           endif
5057           do j=1,3
5058             v1ij=v1(j+1,itori,itori1)
5059             v2ij=v2(j+1,itori,itori1)
5060             cosphi=dcos(j*phii)
5061             sinphi=dsin(j*phii)
5062             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5063             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5064           enddo
5065         else
5066           do j=1,nterm_old
5067             v1ij=v1(j,itori,itori1)
5068             v2ij=v2(j,itori,itori1)
5069             cosphi=dcos(j*phii)
5070             sinphi=dsin(j*phii)
5071             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5072             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5073           enddo
5074         endif
5075         if (lprn)
5076      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5077      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5078      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5079         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5080 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5081       enddo
5082 ! 6/20/98 - dihedral angle constraints
5083       edihcnstr=0.0d0
5084       do i=1,ndih_constr
5085         itori=idih_constr(i)
5086         phii=phi(itori)
5087         difi=phii-phi0(i)
5088         if (difi.gt.drange(i)) then
5089           difi=difi-drange(i)
5090           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5091           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5092         else if (difi.lt.-drange(i)) then
5093           difi=difi+drange(i)
5094           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5095           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5096         endif
5097 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5098 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5099       enddo
5100 !      write (iout,*) 'edihcnstr',edihcnstr
5101       return
5102       end
5103 c------------------------------------------------------------------------------
5104 #else
5105       subroutine etor(etors,edihcnstr,fact)
5106       implicit real*8 (a-h,o-z)
5107       include 'DIMENSIONS'
5108       include 'DIMENSIONS.ZSCOPT'
5109       include 'COMMON.VAR'
5110       include 'COMMON.GEO'
5111       include 'COMMON.LOCAL'
5112       include 'COMMON.TORSION'
5113       include 'COMMON.INTERACT'
5114       include 'COMMON.DERIV'
5115       include 'COMMON.CHAIN'
5116       include 'COMMON.NAMES'
5117       include 'COMMON.IOUNITS'
5118       include 'COMMON.FFIELD'
5119       include 'COMMON.TORCNSTR'
5120       logical lprn
5121 C Set lprn=.true. for debugging
5122       lprn=.false.
5123 c      lprn=.true.
5124       etors=0.0D0
5125       do i=iphi_start,iphi_end
5126         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5127         itori=itortyp(itype(i-2))
5128         itori1=itortyp(itype(i-1))
5129         phii=phi(i)
5130         gloci=0.0D0
5131 C Regular cosine and sine terms
5132         do j=1,nterm(itori,itori1)
5133           v1ij=v1(j,itori,itori1)
5134           v2ij=v2(j,itori,itori1)
5135           cosphi=dcos(j*phii)
5136           sinphi=dsin(j*phii)
5137           etors=etors+v1ij*cosphi+v2ij*sinphi
5138           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5139         enddo
5140 C Lorentz terms
5141 C                         v1
5142 C  E = SUM ----------------------------------- - v1
5143 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5144 C
5145         cosphi=dcos(0.5d0*phii)
5146         sinphi=dsin(0.5d0*phii)
5147         do j=1,nlor(itori,itori1)
5148           vl1ij=vlor1(j,itori,itori1)
5149           vl2ij=vlor2(j,itori,itori1)
5150           vl3ij=vlor3(j,itori,itori1)
5151           pom=vl2ij*cosphi+vl3ij*sinphi
5152           pom1=1.0d0/(pom*pom+1.0d0)
5153           etors=etors+vl1ij*pom1
5154           pom=-pom*pom1*pom1
5155           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5156         enddo
5157 C Subtract the constant term
5158         etors=etors-v0(itori,itori1)
5159         if (lprn)
5160      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5161      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5162      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5163         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5164 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5165  1215   continue
5166       enddo
5167 ! 6/20/98 - dihedral angle constraints
5168       edihcnstr=0.0d0
5169       do i=1,ndih_constr
5170         itori=idih_constr(i)
5171         phii=phi(itori)
5172         difi=pinorm(phii-phi0(i))
5173         edihi=0.0d0
5174         if (difi.gt.drange(i)) then
5175           difi=difi-drange(i)
5176           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5177           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5178           edihi=0.25d0*ftors*difi**4
5179         else if (difi.lt.-drange(i)) then
5180           difi=difi+drange(i)
5181           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5182           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5183           edihi=0.25d0*ftors*difi**4
5184         else
5185           difi=0.0d0
5186         endif
5187 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5188 c     &    drange(i),edihi
5189 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5190 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5191       enddo
5192 !      write (iout,*) 'edihcnstr',edihcnstr
5193       return
5194       end
5195 c----------------------------------------------------------------------------
5196       subroutine etor_d(etors_d,fact2)
5197 C 6/23/01 Compute double torsional energy
5198       implicit real*8 (a-h,o-z)
5199       include 'DIMENSIONS'
5200       include 'DIMENSIONS.ZSCOPT'
5201       include 'COMMON.VAR'
5202       include 'COMMON.GEO'
5203       include 'COMMON.LOCAL'
5204       include 'COMMON.TORSION'
5205       include 'COMMON.INTERACT'
5206       include 'COMMON.DERIV'
5207       include 'COMMON.CHAIN'
5208       include 'COMMON.NAMES'
5209       include 'COMMON.IOUNITS'
5210       include 'COMMON.FFIELD'
5211       include 'COMMON.TORCNSTR'
5212       logical lprn
5213 C Set lprn=.true. for debugging
5214       lprn=.false.
5215 c     lprn=.true.
5216       etors_d=0.0D0
5217       do i=iphi_start,iphi_end-1
5218         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5219      &     goto 1215
5220         itori=itortyp(itype(i-2))
5221         itori1=itortyp(itype(i-1))
5222         itori2=itortyp(itype(i))
5223         phii=phi(i)
5224         phii1=phi(i+1)
5225         gloci1=0.0D0
5226         gloci2=0.0D0
5227 C Regular cosine and sine terms
5228         do j=1,ntermd_1(itori,itori1,itori2)
5229           v1cij=v1c(1,j,itori,itori1,itori2)
5230           v1sij=v1s(1,j,itori,itori1,itori2)
5231           v2cij=v1c(2,j,itori,itori1,itori2)
5232           v2sij=v1s(2,j,itori,itori1,itori2)
5233           cosphi1=dcos(j*phii)
5234           sinphi1=dsin(j*phii)
5235           cosphi2=dcos(j*phii1)
5236           sinphi2=dsin(j*phii1)
5237           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5238      &     v2cij*cosphi2+v2sij*sinphi2
5239           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5240           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5241         enddo
5242         do k=2,ntermd_2(itori,itori1,itori2)
5243           do l=1,k-1
5244             v1cdij = v2c(k,l,itori,itori1,itori2)
5245             v2cdij = v2c(l,k,itori,itori1,itori2)
5246             v1sdij = v2s(k,l,itori,itori1,itori2)
5247             v2sdij = v2s(l,k,itori,itori1,itori2)
5248             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5249             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5250             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5251             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5252             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5253      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5254             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5255      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5256             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5257      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5258           enddo
5259         enddo
5260         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5261         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5262  1215   continue
5263       enddo
5264       return
5265       end
5266 #endif
5267 c------------------------------------------------------------------------------
5268       subroutine eback_sc_corr(esccor)
5269 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5270 c        conformational states; temporarily implemented as differences
5271 c        between UNRES torsional potentials (dependent on three types of
5272 c        residues) and the torsional potentials dependent on all 20 types
5273 c        of residues computed from AM1 energy surfaces of terminally-blocked
5274 c        amino-acid residues.
5275       implicit real*8 (a-h,o-z)
5276       include 'DIMENSIONS'
5277       include 'DIMENSIONS.ZSCOPT'
5278       include 'DIMENSIONS.FREE'
5279       include 'COMMON.VAR'
5280       include 'COMMON.GEO'
5281       include 'COMMON.LOCAL'
5282       include 'COMMON.TORSION'
5283       include 'COMMON.SCCOR'
5284       include 'COMMON.INTERACT'
5285       include 'COMMON.DERIV'
5286       include 'COMMON.CHAIN'
5287       include 'COMMON.NAMES'
5288       include 'COMMON.IOUNITS'
5289       include 'COMMON.FFIELD'
5290       include 'COMMON.CONTROL'
5291       logical lprn
5292 C Set lprn=.true. for debugging
5293       lprn=.false.
5294 c      lprn=.true.
5295 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5296       esccor=0.0D0
5297       do i=itau_start,itau_end
5298         esccor_ii=0.0D0
5299         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5300         isccori=isccortyp(itype(i-2))
5301         isccori1=isccortyp(itype(i-1))
5302         phii=phi(i)
5303 cccc  Added 9 May 2012
5304 cc Tauangle is torsional engle depending on the value of first digit
5305 c(see comment below)
5306 cc Omicron is flat angle depending on the value of first digit
5307 c(see comment below)
5308
5309
5310         do intertyp=1,3 !intertyp
5311 cc Added 09 May 2012 (Adasko)
5312 cc  Intertyp means interaction type of backbone mainchain correlation:
5313 c   1 = SC...Ca...Ca...Ca
5314 c   2 = Ca...Ca...Ca...SC
5315 c   3 = SC...Ca...Ca...SCi
5316         gloci=0.0D0
5317         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5318      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5319      &      (itype(i-1).eq.21)))
5320      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5321      &     .or.(itype(i-2).eq.21)))
5322      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5323      &      (itype(i-1).eq.21)))) cycle
5324         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5325         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5326      & cycle
5327         do j=1,nterm_sccor(isccori,isccori1)
5328           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5329           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5330           cosphi=dcos(j*tauangle(intertyp,i))
5331           sinphi=dsin(j*tauangle(intertyp,i))
5332           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5333 #ifdef DEBUG
5334           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
5335 #endif
5336           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5337         enddo
5338         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5339 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5340 c     &gloc_sc(intertyp,i-3,icg)
5341         if (lprn)
5342      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5343      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5344      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5345      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5346         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5347        enddo !intertyp
5348 #ifdef DEBUG
5349        write (iout,*) "i",i,(tauangle(j,i),j=1,3),esccor_ii
5350 #endif
5351       enddo
5352 c        do i=1,nres
5353 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5354 c        enddo
5355       return
5356       end
5357 c------------------------------------------------------------------------------
5358       subroutine multibody(ecorr)
5359 C This subroutine calculates multi-body contributions to energy following
5360 C the idea of Skolnick et al. If side chains I and J make a contact and
5361 C at the same time side chains I+1 and J+1 make a contact, an extra
5362 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5363       implicit real*8 (a-h,o-z)
5364       include 'DIMENSIONS'
5365       include 'COMMON.IOUNITS'
5366       include 'COMMON.DERIV'
5367       include 'COMMON.INTERACT'
5368       include 'COMMON.CONTACTS'
5369       double precision gx(3),gx1(3)
5370       logical lprn
5371
5372 C Set lprn=.true. for debugging
5373       lprn=.false.
5374
5375       if (lprn) then
5376         write (iout,'(a)') 'Contact function values:'
5377         do i=nnt,nct-2
5378           write (iout,'(i2,20(1x,i2,f10.5))')
5379      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5380         enddo
5381       endif
5382       ecorr=0.0D0
5383       do i=nnt,nct
5384         do j=1,3
5385           gradcorr(j,i)=0.0D0
5386           gradxorr(j,i)=0.0D0
5387         enddo
5388       enddo
5389       do i=nnt,nct-2
5390
5391         DO ISHIFT = 3,4
5392
5393         i1=i+ishift
5394         num_conti=num_cont(i)
5395         num_conti1=num_cont(i1)
5396         do jj=1,num_conti
5397           j=jcont(jj,i)
5398           do kk=1,num_conti1
5399             j1=jcont(kk,i1)
5400             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5401 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5402 cd   &                   ' ishift=',ishift
5403 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5404 C The system gains extra energy.
5405               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5406             endif   ! j1==j+-ishift
5407           enddo     ! kk
5408         enddo       ! jj
5409
5410         ENDDO ! ISHIFT
5411
5412       enddo         ! i
5413       return
5414       end
5415 c------------------------------------------------------------------------------
5416       double precision function esccorr(i,j,k,l,jj,kk)
5417       implicit real*8 (a-h,o-z)
5418       include 'DIMENSIONS'
5419       include 'COMMON.IOUNITS'
5420       include 'COMMON.DERIV'
5421       include 'COMMON.INTERACT'
5422       include 'COMMON.CONTACTS'
5423       double precision gx(3),gx1(3)
5424       logical lprn
5425       lprn=.false.
5426       eij=facont(jj,i)
5427       ekl=facont(kk,k)
5428 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5429 C Calculate the multi-body contribution to energy.
5430 C Calculate multi-body contributions to the gradient.
5431 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5432 cd   & k,l,(gacont(m,kk,k),m=1,3)
5433       do m=1,3
5434         gx(m) =ekl*gacont(m,jj,i)
5435         gx1(m)=eij*gacont(m,kk,k)
5436         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5437         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5438         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5439         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5440       enddo
5441       do m=i,j-1
5442         do ll=1,3
5443           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5444         enddo
5445       enddo
5446       do m=k,l-1
5447         do ll=1,3
5448           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5449         enddo
5450       enddo
5451       esccorr=-eij*ekl
5452       return
5453       end
5454 c------------------------------------------------------------------------------
5455 #ifdef MPL
5456       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5457       implicit real*8 (a-h,o-z)
5458       include 'DIMENSIONS'
5459       integer dimen1,dimen2,atom,indx
5460       double precision buffer(dimen1,dimen2)
5461       double precision zapas
5462       common /contacts_hb/ zapas(3,20,maxres,7),
5463      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5464      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5465       num_kont=num_cont_hb(atom)
5466       do i=1,num_kont
5467         do k=1,7
5468           do j=1,3
5469             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5470           enddo ! j
5471         enddo ! k
5472         buffer(i,indx+22)=facont_hb(i,atom)
5473         buffer(i,indx+23)=ees0p(i,atom)
5474         buffer(i,indx+24)=ees0m(i,atom)
5475         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5476       enddo ! i
5477       buffer(1,indx+26)=dfloat(num_kont)
5478       return
5479       end
5480 c------------------------------------------------------------------------------
5481       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5482       implicit real*8 (a-h,o-z)
5483       include 'DIMENSIONS'
5484       integer dimen1,dimen2,atom,indx
5485       double precision buffer(dimen1,dimen2)
5486       double precision zapas
5487       common /contacts_hb/ zapas(3,20,maxres,7),
5488      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5489      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5490       num_kont=buffer(1,indx+26)
5491       num_kont_old=num_cont_hb(atom)
5492       num_cont_hb(atom)=num_kont+num_kont_old
5493       do i=1,num_kont
5494         ii=i+num_kont_old
5495         do k=1,7
5496           do j=1,3
5497             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5498           enddo ! j
5499         enddo ! k
5500         facont_hb(ii,atom)=buffer(i,indx+22)
5501         ees0p(ii,atom)=buffer(i,indx+23)
5502         ees0m(ii,atom)=buffer(i,indx+24)
5503         jcont_hb(ii,atom)=buffer(i,indx+25)
5504       enddo ! i
5505       return
5506       end
5507 c------------------------------------------------------------------------------
5508 #endif
5509       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5510 C This subroutine calculates multi-body contributions to hydrogen-bonding
5511       implicit real*8 (a-h,o-z)
5512       include 'DIMENSIONS'
5513       include 'DIMENSIONS.ZSCOPT'
5514       include 'COMMON.IOUNITS'
5515 #ifdef MPL
5516       include 'COMMON.INFO'
5517 #endif
5518       include 'COMMON.FFIELD'
5519       include 'COMMON.DERIV'
5520       include 'COMMON.INTERACT'
5521       include 'COMMON.CONTACTS'
5522 #ifdef MPL
5523       parameter (max_cont=maxconts)
5524       parameter (max_dim=2*(8*3+2))
5525       parameter (msglen1=max_cont*max_dim*4)
5526       parameter (msglen2=2*msglen1)
5527       integer source,CorrelType,CorrelID,Error
5528       double precision buffer(max_cont,max_dim)
5529 #endif
5530       double precision gx(3),gx1(3)
5531       logical lprn,ldone
5532
5533 C Set lprn=.true. for debugging
5534       lprn=.false.
5535 #ifdef MPL
5536       n_corr=0
5537       n_corr1=0
5538       if (fgProcs.le.1) goto 30
5539       if (lprn) then
5540         write (iout,'(a)') 'Contact function values:'
5541         do i=nnt,nct-2
5542           write (iout,'(2i3,50(1x,i2,f5.2))')
5543      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5544      &    j=1,num_cont_hb(i))
5545         enddo
5546       endif
5547 C Caution! Following code assumes that electrostatic interactions concerning
5548 C a given atom are split among at most two processors!
5549       CorrelType=477
5550       CorrelID=MyID+1
5551       ldone=.false.
5552       do i=1,max_cont
5553         do j=1,max_dim
5554           buffer(i,j)=0.0D0
5555         enddo
5556       enddo
5557       mm=mod(MyRank,2)
5558 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5559       if (mm) 20,20,10
5560    10 continue
5561 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5562       if (MyRank.gt.0) then
5563 C Send correlation contributions to the preceding processor
5564         msglen=msglen1
5565         nn=num_cont_hb(iatel_s)
5566         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5567 cd      write (iout,*) 'The BUFFER array:'
5568 cd      do i=1,nn
5569 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5570 cd      enddo
5571         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5572           msglen=msglen2
5573             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5574 C Clear the contacts of the atom passed to the neighboring processor
5575         nn=num_cont_hb(iatel_s+1)
5576 cd      do i=1,nn
5577 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5578 cd      enddo
5579             num_cont_hb(iatel_s)=0
5580         endif
5581 cd      write (iout,*) 'Processor ',MyID,MyRank,
5582 cd   & ' is sending correlation contribution to processor',MyID-1,
5583 cd   & ' msglen=',msglen
5584 cd      write (*,*) 'Processor ',MyID,MyRank,
5585 cd   & ' is sending correlation contribution to processor',MyID-1,
5586 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5587         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5588 cd      write (iout,*) 'Processor ',MyID,
5589 cd   & ' has sent correlation contribution to processor',MyID-1,
5590 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5591 cd      write (*,*) 'Processor ',MyID,
5592 cd   & ' has sent correlation contribution to processor',MyID-1,
5593 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5594         msglen=msglen1
5595       endif ! (MyRank.gt.0)
5596       if (ldone) goto 30
5597       ldone=.true.
5598    20 continue
5599 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5600       if (MyRank.lt.fgProcs-1) then
5601 C Receive correlation contributions from the next processor
5602         msglen=msglen1
5603         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5604 cd      write (iout,*) 'Processor',MyID,
5605 cd   & ' is receiving correlation contribution from processor',MyID+1,
5606 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5607 cd      write (*,*) 'Processor',MyID,
5608 cd   & ' is receiving correlation contribution from processor',MyID+1,
5609 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5610         nbytes=-1
5611         do while (nbytes.le.0)
5612           call mp_probe(MyID+1,CorrelType,nbytes)
5613         enddo
5614 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5615         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5616 cd      write (iout,*) 'Processor',MyID,
5617 cd   & ' has received correlation contribution from processor',MyID+1,
5618 cd   & ' msglen=',msglen,' nbytes=',nbytes
5619 cd      write (iout,*) 'The received BUFFER array:'
5620 cd      do i=1,max_cont
5621 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5622 cd      enddo
5623         if (msglen.eq.msglen1) then
5624           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5625         else if (msglen.eq.msglen2)  then
5626           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5627           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5628         else
5629           write (iout,*)
5630      & 'ERROR!!!! message length changed while processing correlations.'
5631           write (*,*)
5632      & 'ERROR!!!! message length changed while processing correlations.'
5633           call mp_stopall(Error)
5634         endif ! msglen.eq.msglen1
5635       endif ! MyRank.lt.fgProcs-1
5636       if (ldone) goto 30
5637       ldone=.true.
5638       goto 10
5639    30 continue
5640 #endif
5641       if (lprn) then
5642         write (iout,'(a)') 'Contact function values:'
5643         do i=nnt,nct-2
5644           write (iout,'(2i3,50(1x,i2,f5.2))')
5645      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5646      &    j=1,num_cont_hb(i))
5647         enddo
5648       endif
5649       ecorr=0.0D0
5650 C Remove the loop below after debugging !!!
5651       do i=nnt,nct
5652         do j=1,3
5653           gradcorr(j,i)=0.0D0
5654           gradxorr(j,i)=0.0D0
5655         enddo
5656       enddo
5657 C Calculate the local-electrostatic correlation terms
5658       do i=iatel_s,iatel_e+1
5659         i1=i+1
5660         num_conti=num_cont_hb(i)
5661         num_conti1=num_cont_hb(i+1)
5662         do jj=1,num_conti
5663           j=jcont_hb(jj,i)
5664           do kk=1,num_conti1
5665             j1=jcont_hb(kk,i1)
5666 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5667 c     &         ' jj=',jj,' kk=',kk
5668             if (j1.eq.j+1 .or. j1.eq.j-1) then
5669 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5670 C The system gains extra energy.
5671               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5672 #ifdef DEBUG
5673               write (iout,*) "ecorr",i,j,i+1,j1,
5674      &               ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5675 #endif
5676               n_corr=n_corr+1
5677             else if (j1.eq.j) then
5678 C Contacts I-J and I-(J+1) occur simultaneously.
5679 C The system loses extra energy.
5680 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5681             endif
5682           enddo ! kk
5683           do kk=1,num_conti
5684             j1=jcont_hb(kk,i)
5685 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5686 c    &         ' jj=',jj,' kk=',kk
5687             if (j1.eq.j+1) then
5688 C Contacts I-J and (I+1)-J occur simultaneously.
5689 C The system loses extra energy.
5690 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5691             endif ! j1==j+1
5692           enddo ! kk
5693         enddo ! jj
5694       enddo ! i
5695       return
5696       end
5697 c------------------------------------------------------------------------------
5698       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5699      &  n_corr1)
5700 C This subroutine calculates multi-body contributions to hydrogen-bonding
5701       implicit real*8 (a-h,o-z)
5702       include 'DIMENSIONS'
5703       include 'DIMENSIONS.ZSCOPT'
5704       include 'COMMON.IOUNITS'
5705 #ifdef MPL
5706       include 'COMMON.INFO'
5707 #endif
5708       include 'COMMON.FFIELD'
5709       include 'COMMON.DERIV'
5710       include 'COMMON.INTERACT'
5711       include 'COMMON.CONTACTS'
5712 #ifdef MPL
5713       parameter (max_cont=maxconts)
5714       parameter (max_dim=2*(8*3+2))
5715       parameter (msglen1=max_cont*max_dim*4)
5716       parameter (msglen2=2*msglen1)
5717       integer source,CorrelType,CorrelID,Error
5718       double precision buffer(max_cont,max_dim)
5719 #endif
5720       double precision gx(3),gx1(3)
5721       logical lprn,ldone
5722
5723 C Set lprn=.true. for debugging
5724       lprn=.false.
5725       eturn6=0.0d0
5726 #ifdef MPL
5727       n_corr=0
5728       n_corr1=0
5729       if (fgProcs.le.1) goto 30
5730       if (lprn) then
5731         write (iout,'(a)') 'Contact function values:'
5732         do i=nnt,nct-2
5733           write (iout,'(2i3,50(1x,i2,f5.2))')
5734      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5735      &    j=1,num_cont_hb(i))
5736         enddo
5737       endif
5738 C Caution! Following code assumes that electrostatic interactions concerning
5739 C a given atom are split among at most two processors!
5740       CorrelType=477
5741       CorrelID=MyID+1
5742       ldone=.false.
5743       do i=1,max_cont
5744         do j=1,max_dim
5745           buffer(i,j)=0.0D0
5746         enddo
5747       enddo
5748       mm=mod(MyRank,2)
5749 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5750       if (mm) 20,20,10
5751    10 continue
5752 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5753       if (MyRank.gt.0) then
5754 C Send correlation contributions to the preceding processor
5755         msglen=msglen1
5756         nn=num_cont_hb(iatel_s)
5757         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5758 cd      write (iout,*) 'The BUFFER array:'
5759 cd      do i=1,nn
5760 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5761 cd      enddo
5762         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5763           msglen=msglen2
5764             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5765 C Clear the contacts of the atom passed to the neighboring processor
5766         nn=num_cont_hb(iatel_s+1)
5767 cd      do i=1,nn
5768 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5769 cd      enddo
5770             num_cont_hb(iatel_s)=0
5771         endif
5772 cd      write (iout,*) 'Processor ',MyID,MyRank,
5773 cd   & ' is sending correlation contribution to processor',MyID-1,
5774 cd   & ' msglen=',msglen
5775 cd      write (*,*) 'Processor ',MyID,MyRank,
5776 cd   & ' is sending correlation contribution to processor',MyID-1,
5777 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5778         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5779 cd      write (iout,*) 'Processor ',MyID,
5780 cd   & ' has sent correlation contribution to processor',MyID-1,
5781 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5782 cd      write (*,*) 'Processor ',MyID,
5783 cd   & ' has sent correlation contribution to processor',MyID-1,
5784 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5785         msglen=msglen1
5786       endif ! (MyRank.gt.0)
5787       if (ldone) goto 30
5788       ldone=.true.
5789    20 continue
5790 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5791       if (MyRank.lt.fgProcs-1) then
5792 C Receive correlation contributions from the next processor
5793         msglen=msglen1
5794         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5795 cd      write (iout,*) 'Processor',MyID,
5796 cd   & ' is receiving correlation contribution from processor',MyID+1,
5797 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5798 cd      write (*,*) 'Processor',MyID,
5799 cd   & ' is receiving correlation contribution from processor',MyID+1,
5800 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5801         nbytes=-1
5802         do while (nbytes.le.0)
5803           call mp_probe(MyID+1,CorrelType,nbytes)
5804         enddo
5805 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5806         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5807 cd      write (iout,*) 'Processor',MyID,
5808 cd   & ' has received correlation contribution from processor',MyID+1,
5809 cd   & ' msglen=',msglen,' nbytes=',nbytes
5810 cd      write (iout,*) 'The received BUFFER array:'
5811 cd      do i=1,max_cont
5812 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5813 cd      enddo
5814         if (msglen.eq.msglen1) then
5815           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5816         else if (msglen.eq.msglen2)  then
5817           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5818           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5819         else
5820           write (iout,*)
5821      & 'ERROR!!!! message length changed while processing correlations.'
5822           write (*,*)
5823      & 'ERROR!!!! message length changed while processing correlations.'
5824           call mp_stopall(Error)
5825         endif ! msglen.eq.msglen1
5826       endif ! MyRank.lt.fgProcs-1
5827       if (ldone) goto 30
5828       ldone=.true.
5829       goto 10
5830    30 continue
5831 #endif
5832       if (lprn) then
5833         write (iout,'(a)') 'Contact function values:'
5834         do i=nnt,nct-2
5835           write (iout,'(2i3,50(1x,i2,f5.2))')
5836      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5837      &    j=1,num_cont_hb(i))
5838         enddo
5839       endif
5840       ecorr=0.0D0
5841       ecorr5=0.0d0
5842       ecorr6=0.0d0
5843 C Remove the loop below after debugging !!!
5844       do i=nnt,nct
5845         do j=1,3
5846           gradcorr(j,i)=0.0D0
5847           gradxorr(j,i)=0.0D0
5848         enddo
5849       enddo
5850 C Calculate the dipole-dipole interaction energies
5851       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5852       do i=iatel_s,iatel_e+1
5853         num_conti=num_cont_hb(i)
5854         do jj=1,num_conti
5855           j=jcont_hb(jj,i)
5856           call dipole(i,j,jj)
5857         enddo
5858       enddo
5859       endif
5860 C Calculate the local-electrostatic correlation terms
5861       do i=iatel_s,iatel_e+1
5862         i1=i+1
5863         num_conti=num_cont_hb(i)
5864         num_conti1=num_cont_hb(i+1)
5865         do jj=1,num_conti
5866           j=jcont_hb(jj,i)
5867           do kk=1,num_conti1
5868             j1=jcont_hb(kk,i1)
5869 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5870 c     &         ' jj=',jj,' kk=',kk
5871             if (j1.eq.j+1 .or. j1.eq.j-1) then
5872 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5873 C The system gains extra energy.
5874               n_corr=n_corr+1
5875               sqd1=dsqrt(d_cont(jj,i))
5876               sqd2=dsqrt(d_cont(kk,i1))
5877               sred_geom = sqd1*sqd2
5878               IF (sred_geom.lt.cutoff_corr) THEN
5879                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5880      &            ekont,fprimcont)
5881 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5882 c     &         ' jj=',jj,' kk=',kk
5883                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5884                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5885                 do l=1,3
5886                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5887                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5888                 enddo
5889                 n_corr1=n_corr1+1
5890 cd               write (iout,*) 'sred_geom=',sred_geom,
5891 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5892                 call calc_eello(i,j,i+1,j1,jj,kk)
5893                 if (wcorr4.gt.0.0d0)
5894      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5895                 if (wcorr5.gt.0.0d0)
5896      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5897 c                print *,"wcorr5",ecorr5
5898 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5899 cd                write(2,*)'ijkl',i,j,i+1,j1
5900                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5901      &               .or. wturn6.eq.0.0d0))then
5902 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5903                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5904 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5905 cd     &            'ecorr6=',ecorr6
5906 cd                write (iout,'(4e15.5)') sred_geom,
5907 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5908 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5909 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5910                 else if (wturn6.gt.0.0d0
5911      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5912 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5913                   eturn6=eturn6+eello_turn6(i,jj,kk)
5914 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5915                 endif
5916               ENDIF
5917 1111          continue
5918             else if (j1.eq.j) then
5919 C Contacts I-J and I-(J+1) occur simultaneously.
5920 C The system loses extra energy.
5921 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5922             endif
5923           enddo ! kk
5924           do kk=1,num_conti
5925             j1=jcont_hb(kk,i)
5926 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5927 c    &         ' jj=',jj,' kk=',kk
5928             if (j1.eq.j+1) then
5929 C Contacts I-J and (I+1)-J occur simultaneously.
5930 C The system loses extra energy.
5931 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5932             endif ! j1==j+1
5933           enddo ! kk
5934         enddo ! jj
5935       enddo ! i
5936       return
5937       end
5938 c------------------------------------------------------------------------------
5939       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5940       implicit real*8 (a-h,o-z)
5941       include 'DIMENSIONS'
5942       include 'COMMON.IOUNITS'
5943       include 'COMMON.DERIV'
5944       include 'COMMON.INTERACT'
5945       include 'COMMON.CONTACTS'
5946       double precision gx(3),gx1(3)
5947       logical lprn
5948       lprn=.false.
5949       eij=facont_hb(jj,i)
5950       ekl=facont_hb(kk,k)
5951       ees0pij=ees0p(jj,i)
5952       ees0pkl=ees0p(kk,k)
5953       ees0mij=ees0m(jj,i)
5954       ees0mkl=ees0m(kk,k)
5955       ekont=eij*ekl
5956       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5957 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5958 C Following 4 lines for diagnostics.
5959 cd    ees0pkl=0.0D0
5960 cd    ees0pij=1.0D0
5961 cd    ees0mkl=0.0D0
5962 cd    ees0mij=1.0D0
5963 cd      write (iout,*)'Contacts have occurred for peptide groups',i,j,
5964 cd     &   ' and',k,l
5965 cd      write (iout,*)'Contacts have occurred for peptide groups',
5966 cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5967 cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5968 C Calculate the multi-body contribution to energy.
5969       ecorr=ecorr+ekont*ees
5970       if (calc_grad) then
5971 C Calculate multi-body contributions to the gradient.
5972       do ll=1,3
5973         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5974         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5975      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5976      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5977         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5978      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5979      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5980         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5981         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5982      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5983      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5984         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5985      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5986      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5987       enddo
5988       do m=i+1,j-1
5989         do ll=1,3
5990           gradcorr(ll,m)=gradcorr(ll,m)+
5991      &     ees*ekl*gacont_hbr(ll,jj,i)-
5992      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5993      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5994         enddo
5995       enddo
5996       do m=k+1,l-1
5997         do ll=1,3
5998           gradcorr(ll,m)=gradcorr(ll,m)+
5999      &     ees*eij*gacont_hbr(ll,kk,k)-
6000      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6001      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6002         enddo
6003       enddo
6004       endif
6005       ehbcorr=ekont*ees
6006       return
6007       end
6008 C---------------------------------------------------------------------------
6009       subroutine dipole(i,j,jj)
6010       implicit real*8 (a-h,o-z)
6011       include 'DIMENSIONS'
6012       include 'DIMENSIONS.ZSCOPT'
6013       include 'COMMON.IOUNITS'
6014       include 'COMMON.CHAIN'
6015       include 'COMMON.FFIELD'
6016       include 'COMMON.DERIV'
6017       include 'COMMON.INTERACT'
6018       include 'COMMON.CONTACTS'
6019       include 'COMMON.TORSION'
6020       include 'COMMON.VAR'
6021       include 'COMMON.GEO'
6022       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6023      &  auxmat(2,2)
6024       iti1 = itortyp(itype(i+1))
6025       if (j.lt.nres-1) then
6026         itj1 = itortyp(itype(j+1))
6027       else
6028         itj1=ntortyp+1
6029       endif
6030       do iii=1,2
6031         dipi(iii,1)=Ub2(iii,i)
6032         dipderi(iii)=Ub2der(iii,i)
6033         dipi(iii,2)=b1(iii,iti1)
6034         dipj(iii,1)=Ub2(iii,j)
6035         dipderj(iii)=Ub2der(iii,j)
6036         dipj(iii,2)=b1(iii,itj1)
6037       enddo
6038       kkk=0
6039       do iii=1,2
6040         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6041         do jjj=1,2
6042           kkk=kkk+1
6043           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6044         enddo
6045       enddo
6046       if (.not.calc_grad) return
6047       do kkk=1,5
6048         do lll=1,3
6049           mmm=0
6050           do iii=1,2
6051             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6052      &        auxvec(1))
6053             do jjj=1,2
6054               mmm=mmm+1
6055               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6056             enddo
6057           enddo
6058         enddo
6059       enddo
6060       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6061       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6062       do iii=1,2
6063         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6064       enddo
6065       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6066       do iii=1,2
6067         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6068       enddo
6069       return
6070       end
6071 C---------------------------------------------------------------------------
6072       subroutine calc_eello(i,j,k,l,jj,kk)
6073 C
6074 C This subroutine computes matrices and vectors needed to calculate
6075 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6076 C
6077       implicit real*8 (a-h,o-z)
6078       include 'DIMENSIONS'
6079       include 'DIMENSIONS.ZSCOPT'
6080       include 'COMMON.IOUNITS'
6081       include 'COMMON.CHAIN'
6082       include 'COMMON.DERIV'
6083       include 'COMMON.INTERACT'
6084       include 'COMMON.CONTACTS'
6085       include 'COMMON.TORSION'
6086       include 'COMMON.VAR'
6087       include 'COMMON.GEO'
6088       include 'COMMON.FFIELD'
6089       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6090      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6091       logical lprn
6092       common /kutas/ lprn
6093 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6094 cd     & ' jj=',jj,' kk=',kk
6095 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6096       do iii=1,2
6097         do jjj=1,2
6098           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6099           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6100         enddo
6101       enddo
6102       call transpose2(aa1(1,1),aa1t(1,1))
6103       call transpose2(aa2(1,1),aa2t(1,1))
6104       do kkk=1,5
6105         do lll=1,3
6106           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6107      &      aa1tder(1,1,lll,kkk))
6108           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6109      &      aa2tder(1,1,lll,kkk))
6110         enddo
6111       enddo
6112       if (l.eq.j+1) then
6113 C parallel orientation of the two CA-CA-CA frames.
6114         if (i.gt.1) then
6115           iti=itortyp(itype(i))
6116         else
6117           iti=ntortyp+1
6118         endif
6119         itk1=itortyp(itype(k+1))
6120         itj=itortyp(itype(j))
6121         if (l.lt.nres-1) then
6122           itl1=itortyp(itype(l+1))
6123         else
6124           itl1=ntortyp+1
6125         endif
6126 C A1 kernel(j+1) A2T
6127 cd        do iii=1,2
6128 cd          write (iout,'(3f10.5,5x,3f10.5)')
6129 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6130 cd        enddo
6131         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6132      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6133      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6134 C Following matrices are needed only for 6-th order cumulants
6135         IF (wcorr6.gt.0.0d0) THEN
6136         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6137      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6138      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6139         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6140      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6141      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6142      &   ADtEAderx(1,1,1,1,1,1))
6143         lprn=.false.
6144         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6145      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6146      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6147      &   ADtEA1derx(1,1,1,1,1,1))
6148         ENDIF
6149 C End 6-th order cumulants
6150 cd        lprn=.false.
6151 cd        if (lprn) then
6152 cd        write (2,*) 'In calc_eello6'
6153 cd        do iii=1,2
6154 cd          write (2,*) 'iii=',iii
6155 cd          do kkk=1,5
6156 cd            write (2,*) 'kkk=',kkk
6157 cd            do jjj=1,2
6158 cd              write (2,'(3(2f10.5),5x)')
6159 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6160 cd            enddo
6161 cd          enddo
6162 cd        enddo
6163 cd        endif
6164         call transpose2(EUgder(1,1,k),auxmat(1,1))
6165         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6166         call transpose2(EUg(1,1,k),auxmat(1,1))
6167         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6168         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6169         do iii=1,2
6170           do kkk=1,5
6171             do lll=1,3
6172               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6173      &          EAEAderx(1,1,lll,kkk,iii,1))
6174             enddo
6175           enddo
6176         enddo
6177 C A1T kernel(i+1) A2
6178         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6179      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6180      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6181 C Following matrices are needed only for 6-th order cumulants
6182         IF (wcorr6.gt.0.0d0) THEN
6183         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6184      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6185      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6186         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6187      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6188      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6189      &   ADtEAderx(1,1,1,1,1,2))
6190         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6191      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6192      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6193      &   ADtEA1derx(1,1,1,1,1,2))
6194         ENDIF
6195 C End 6-th order cumulants
6196         call transpose2(EUgder(1,1,l),auxmat(1,1))
6197         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6198         call transpose2(EUg(1,1,l),auxmat(1,1))
6199         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6200         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6201         do iii=1,2
6202           do kkk=1,5
6203             do lll=1,3
6204               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6205      &          EAEAderx(1,1,lll,kkk,iii,2))
6206             enddo
6207           enddo
6208         enddo
6209 C AEAb1 and AEAb2
6210 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6211 C They are needed only when the fifth- or the sixth-order cumulants are
6212 C indluded.
6213         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6214         call transpose2(AEA(1,1,1),auxmat(1,1))
6215         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6216         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6217         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6218         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6219         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6220         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6221         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6222         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6223         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6224         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6225         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6226         call transpose2(AEA(1,1,2),auxmat(1,1))
6227         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6228         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6229         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6230         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6231         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6232         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6233         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6234         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6235         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6236         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6237         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6238 C Calculate the Cartesian derivatives of the vectors.
6239         do iii=1,2
6240           do kkk=1,5
6241             do lll=1,3
6242               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6243               call matvec2(auxmat(1,1),b1(1,iti),
6244      &          AEAb1derx(1,lll,kkk,iii,1,1))
6245               call matvec2(auxmat(1,1),Ub2(1,i),
6246      &          AEAb2derx(1,lll,kkk,iii,1,1))
6247               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6248      &          AEAb1derx(1,lll,kkk,iii,2,1))
6249               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6250      &          AEAb2derx(1,lll,kkk,iii,2,1))
6251               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6252               call matvec2(auxmat(1,1),b1(1,itj),
6253      &          AEAb1derx(1,lll,kkk,iii,1,2))
6254               call matvec2(auxmat(1,1),Ub2(1,j),
6255      &          AEAb2derx(1,lll,kkk,iii,1,2))
6256               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6257      &          AEAb1derx(1,lll,kkk,iii,2,2))
6258               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6259      &          AEAb2derx(1,lll,kkk,iii,2,2))
6260             enddo
6261           enddo
6262         enddo
6263         ENDIF
6264 C End vectors
6265       else
6266 C Antiparallel orientation of the two CA-CA-CA frames.
6267         if (i.gt.1) then
6268           iti=itortyp(itype(i))
6269         else
6270           iti=ntortyp+1
6271         endif
6272         itk1=itortyp(itype(k+1))
6273         itl=itortyp(itype(l))
6274         itj=itortyp(itype(j))
6275         if (j.lt.nres-1) then
6276           itj1=itortyp(itype(j+1))
6277         else
6278           itj1=ntortyp+1
6279         endif
6280 C A2 kernel(j-1)T A1T
6281         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6282      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6283      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6284 C Following matrices are needed only for 6-th order cumulants
6285         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6286      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6287         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6288      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6289      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6290         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6291      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6292      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6293      &   ADtEAderx(1,1,1,1,1,1))
6294         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6295      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6296      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6297      &   ADtEA1derx(1,1,1,1,1,1))
6298         ENDIF
6299 C End 6-th order cumulants
6300         call transpose2(EUgder(1,1,k),auxmat(1,1))
6301         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6302         call transpose2(EUg(1,1,k),auxmat(1,1))
6303         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6304         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6305         do iii=1,2
6306           do kkk=1,5
6307             do lll=1,3
6308               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6309      &          EAEAderx(1,1,lll,kkk,iii,1))
6310             enddo
6311           enddo
6312         enddo
6313 C A2T kernel(i+1)T A1
6314         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6315      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6316      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6317 C Following matrices are needed only for 6-th order cumulants
6318         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6319      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6320         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6321      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6322      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6323         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6324      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6325      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6326      &   ADtEAderx(1,1,1,1,1,2))
6327         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6328      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6329      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6330      &   ADtEA1derx(1,1,1,1,1,2))
6331         ENDIF
6332 C End 6-th order cumulants
6333         call transpose2(EUgder(1,1,j),auxmat(1,1))
6334         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6335         call transpose2(EUg(1,1,j),auxmat(1,1))
6336         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6337         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6338         do iii=1,2
6339           do kkk=1,5
6340             do lll=1,3
6341               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6342      &          EAEAderx(1,1,lll,kkk,iii,2))
6343             enddo
6344           enddo
6345         enddo
6346 C AEAb1 and AEAb2
6347 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6348 C They are needed only when the fifth- or the sixth-order cumulants are
6349 C indluded.
6350         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6351      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6352         call transpose2(AEA(1,1,1),auxmat(1,1))
6353         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6354         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6355         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6356         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6357         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6358         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6359         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6360         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6361         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6362         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6363         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6364         call transpose2(AEA(1,1,2),auxmat(1,1))
6365         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6366         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6367         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6368         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6369         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6370         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6371         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6372         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6373         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6374         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6375         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6376 C Calculate the Cartesian derivatives of the vectors.
6377         do iii=1,2
6378           do kkk=1,5
6379             do lll=1,3
6380               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6381               call matvec2(auxmat(1,1),b1(1,iti),
6382      &          AEAb1derx(1,lll,kkk,iii,1,1))
6383               call matvec2(auxmat(1,1),Ub2(1,i),
6384      &          AEAb2derx(1,lll,kkk,iii,1,1))
6385               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6386      &          AEAb1derx(1,lll,kkk,iii,2,1))
6387               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6388      &          AEAb2derx(1,lll,kkk,iii,2,1))
6389               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6390               call matvec2(auxmat(1,1),b1(1,itl),
6391      &          AEAb1derx(1,lll,kkk,iii,1,2))
6392               call matvec2(auxmat(1,1),Ub2(1,l),
6393      &          AEAb2derx(1,lll,kkk,iii,1,2))
6394               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6395      &          AEAb1derx(1,lll,kkk,iii,2,2))
6396               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6397      &          AEAb2derx(1,lll,kkk,iii,2,2))
6398             enddo
6399           enddo
6400         enddo
6401         ENDIF
6402 C End vectors
6403       endif
6404       return
6405       end
6406 C---------------------------------------------------------------------------
6407       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6408      &  KK,KKderg,AKA,AKAderg,AKAderx)
6409       implicit none
6410       integer nderg
6411       logical transp
6412       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6413      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6414      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6415       integer iii,kkk,lll
6416       integer jjj,mmm
6417       logical lprn
6418       common /kutas/ lprn
6419       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6420       do iii=1,nderg
6421         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6422      &    AKAderg(1,1,iii))
6423       enddo
6424 cd      if (lprn) write (2,*) 'In kernel'
6425       do kkk=1,5
6426 cd        if (lprn) write (2,*) 'kkk=',kkk
6427         do lll=1,3
6428           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6429      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6430 cd          if (lprn) then
6431 cd            write (2,*) 'lll=',lll
6432 cd            write (2,*) 'iii=1'
6433 cd            do jjj=1,2
6434 cd              write (2,'(3(2f10.5),5x)')
6435 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6436 cd            enddo
6437 cd          endif
6438           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6439      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6440 cd          if (lprn) then
6441 cd            write (2,*) 'lll=',lll
6442 cd            write (2,*) 'iii=2'
6443 cd            do jjj=1,2
6444 cd              write (2,'(3(2f10.5),5x)')
6445 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6446 cd            enddo
6447 cd          endif
6448         enddo
6449       enddo
6450       return
6451       end
6452 C---------------------------------------------------------------------------
6453       double precision function eello4(i,j,k,l,jj,kk)
6454       implicit real*8 (a-h,o-z)
6455       include 'DIMENSIONS'
6456       include 'DIMENSIONS.ZSCOPT'
6457       include 'COMMON.IOUNITS'
6458       include 'COMMON.CHAIN'
6459       include 'COMMON.DERIV'
6460       include 'COMMON.INTERACT'
6461       include 'COMMON.CONTACTS'
6462       include 'COMMON.TORSION'
6463       include 'COMMON.VAR'
6464       include 'COMMON.GEO'
6465       double precision pizda(2,2),ggg1(3),ggg2(3)
6466 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6467 cd        eello4=0.0d0
6468 cd        return
6469 cd      endif
6470 cd      print *,'eello4:',i,j,k,l,jj,kk
6471 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6472 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6473 cold      eij=facont_hb(jj,i)
6474 cold      ekl=facont_hb(kk,k)
6475 cold      ekont=eij*ekl
6476       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6477       if (calc_grad) then
6478 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6479       gcorr_loc(k-1)=gcorr_loc(k-1)
6480      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6481       if (l.eq.j+1) then
6482         gcorr_loc(l-1)=gcorr_loc(l-1)
6483      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6484       else
6485         gcorr_loc(j-1)=gcorr_loc(j-1)
6486      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6487       endif
6488       do iii=1,2
6489         do kkk=1,5
6490           do lll=1,3
6491             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6492      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6493 cd            derx(lll,kkk,iii)=0.0d0
6494           enddo
6495         enddo
6496       enddo
6497 cd      gcorr_loc(l-1)=0.0d0
6498 cd      gcorr_loc(j-1)=0.0d0
6499 cd      gcorr_loc(k-1)=0.0d0
6500 cd      eel4=1.0d0
6501 cd      write (iout,*)'Contacts have occurred for peptide groups',
6502 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6503 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6504       if (j.lt.nres-1) then
6505         j1=j+1
6506         j2=j-1
6507       else
6508         j1=j-1
6509         j2=j-2
6510       endif
6511       if (l.lt.nres-1) then
6512         l1=l+1
6513         l2=l-1
6514       else
6515         l1=l-1
6516         l2=l-2
6517       endif
6518       do ll=1,3
6519 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6520         ggg1(ll)=eel4*g_contij(ll,1)
6521         ggg2(ll)=eel4*g_contij(ll,2)
6522         ghalf=0.5d0*ggg1(ll)
6523 cd        ghalf=0.0d0
6524         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6525         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6526         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6527         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6528 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6529         ghalf=0.5d0*ggg2(ll)
6530 cd        ghalf=0.0d0
6531         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6532         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6533         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6534         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6535       enddo
6536 cd      goto 1112
6537       do m=i+1,j-1
6538         do ll=1,3
6539 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6540           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6541         enddo
6542       enddo
6543       do m=k+1,l-1
6544         do ll=1,3
6545 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6546           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6547         enddo
6548       enddo
6549 1112  continue
6550       do m=i+2,j2
6551         do ll=1,3
6552           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6553         enddo
6554       enddo
6555       do m=k+2,l2
6556         do ll=1,3
6557           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6558         enddo
6559       enddo
6560 cd      do iii=1,nres-3
6561 cd        write (2,*) iii,gcorr_loc(iii)
6562 cd      enddo
6563       endif
6564       eello4=ekont*eel4
6565 cd      write (2,*) 'ekont',ekont
6566 cd      write (iout,*) 'eello4',ekont*eel4
6567       return
6568       end
6569 C---------------------------------------------------------------------------
6570       double precision function eello5(i,j,k,l,jj,kk)
6571       implicit real*8 (a-h,o-z)
6572       include 'DIMENSIONS'
6573       include 'DIMENSIONS.ZSCOPT'
6574       include 'COMMON.IOUNITS'
6575       include 'COMMON.CHAIN'
6576       include 'COMMON.DERIV'
6577       include 'COMMON.INTERACT'
6578       include 'COMMON.CONTACTS'
6579       include 'COMMON.TORSION'
6580       include 'COMMON.VAR'
6581       include 'COMMON.GEO'
6582       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6583       double precision ggg1(3),ggg2(3)
6584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6585 C                                                                              C
6586 C                            Parallel chains                                   C
6587 C                                                                              C
6588 C          o             o                   o             o                   C
6589 C         /l\           / \             \   / \           / \   /              C
6590 C        /   \         /   \             \ /   \         /   \ /               C
6591 C       j| o |l1       | o |              o| o |         | o |o                C
6592 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6593 C      \i/   \         /   \ /             /   \         /   \                 C
6594 C       o    k1             o                                                  C
6595 C         (I)          (II)                (III)          (IV)                 C
6596 C                                                                              C
6597 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6598 C                                                                              C
6599 C                            Antiparallel chains                               C
6600 C                                                                              C
6601 C          o             o                   o             o                   C
6602 C         /j\           / \             \   / \           / \   /              C
6603 C        /   \         /   \             \ /   \         /   \ /               C
6604 C      j1| o |l        | o |              o| o |         | o |o                C
6605 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6606 C      \i/   \         /   \ /             /   \         /   \                 C
6607 C       o     k1            o                                                  C
6608 C         (I)          (II)                (III)          (IV)                 C
6609 C                                                                              C
6610 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6611 C                                                                              C
6612 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6613 C                                                                              C
6614 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6615 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6616 cd        eello5=0.0d0
6617 cd        return
6618 cd      endif
6619 cd      write (iout,*)
6620 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6621 cd     &   ' and',k,l
6622       itk=itortyp(itype(k))
6623       itl=itortyp(itype(l))
6624       itj=itortyp(itype(j))
6625       eello5_1=0.0d0
6626       eello5_2=0.0d0
6627       eello5_3=0.0d0
6628       eello5_4=0.0d0
6629 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6630 cd     &   eel5_3_num,eel5_4_num)
6631       do iii=1,2
6632         do kkk=1,5
6633           do lll=1,3
6634             derx(lll,kkk,iii)=0.0d0
6635           enddo
6636         enddo
6637       enddo
6638 cd      eij=facont_hb(jj,i)
6639 cd      ekl=facont_hb(kk,k)
6640 cd      ekont=eij*ekl
6641 cd      write (iout,*)'Contacts have occurred for peptide groups',
6642 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6643 cd      goto 1111
6644 C Contribution from the graph I.
6645 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6646 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6647       call transpose2(EUg(1,1,k),auxmat(1,1))
6648       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6649       vv(1)=pizda(1,1)-pizda(2,2)
6650       vv(2)=pizda(1,2)+pizda(2,1)
6651       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6652      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6653       if (calc_grad) then
6654 C Explicit gradient in virtual-dihedral angles.
6655       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6656      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6657      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6658       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6659       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6660       vv(1)=pizda(1,1)-pizda(2,2)
6661       vv(2)=pizda(1,2)+pizda(2,1)
6662       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6663      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6664      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6665       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6666       vv(1)=pizda(1,1)-pizda(2,2)
6667       vv(2)=pizda(1,2)+pizda(2,1)
6668       if (l.eq.j+1) then
6669         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6670      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6671      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6672       else
6673         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6674      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6675      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6676       endif
6677 C Cartesian gradient
6678       do iii=1,2
6679         do kkk=1,5
6680           do lll=1,3
6681             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6682      &        pizda(1,1))
6683             vv(1)=pizda(1,1)-pizda(2,2)
6684             vv(2)=pizda(1,2)+pizda(2,1)
6685             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6686      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6687      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6688           enddo
6689         enddo
6690       enddo
6691 c      goto 1112
6692       endif
6693 c1111  continue
6694 C Contribution from graph II
6695       call transpose2(EE(1,1,itk),auxmat(1,1))
6696       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6697       vv(1)=pizda(1,1)+pizda(2,2)
6698       vv(2)=pizda(2,1)-pizda(1,2)
6699       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6700      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6701       if (calc_grad) then
6702 C Explicit gradient in virtual-dihedral angles.
6703       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6704      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6705       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6706       vv(1)=pizda(1,1)+pizda(2,2)
6707       vv(2)=pizda(2,1)-pizda(1,2)
6708       if (l.eq.j+1) then
6709         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6710      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6711      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6712       else
6713         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6714      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6715      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6716       endif
6717 C Cartesian gradient
6718       do iii=1,2
6719         do kkk=1,5
6720           do lll=1,3
6721             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6722      &        pizda(1,1))
6723             vv(1)=pizda(1,1)+pizda(2,2)
6724             vv(2)=pizda(2,1)-pizda(1,2)
6725             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6726      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6727      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6728           enddo
6729         enddo
6730       enddo
6731 cd      goto 1112
6732       endif
6733 cd1111  continue
6734       if (l.eq.j+1) then
6735 cd        goto 1110
6736 C Parallel orientation
6737 C Contribution from graph III
6738         call transpose2(EUg(1,1,l),auxmat(1,1))
6739         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6740         vv(1)=pizda(1,1)-pizda(2,2)
6741         vv(2)=pizda(1,2)+pizda(2,1)
6742         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6743      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6744         if (calc_grad) then
6745 C Explicit gradient in virtual-dihedral angles.
6746         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6747      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6748      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6749         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6750         vv(1)=pizda(1,1)-pizda(2,2)
6751         vv(2)=pizda(1,2)+pizda(2,1)
6752         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6753      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6754      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6755         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6756         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6757         vv(1)=pizda(1,1)-pizda(2,2)
6758         vv(2)=pizda(1,2)+pizda(2,1)
6759         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6760      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6762 C Cartesian gradient
6763         do iii=1,2
6764           do kkk=1,5
6765             do lll=1,3
6766               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6767      &          pizda(1,1))
6768               vv(1)=pizda(1,1)-pizda(2,2)
6769               vv(2)=pizda(1,2)+pizda(2,1)
6770               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6771      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6772      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6773             enddo
6774           enddo
6775         enddo
6776 cd        goto 1112
6777         endif
6778 C Contribution from graph IV
6779 cd1110    continue
6780         call transpose2(EE(1,1,itl),auxmat(1,1))
6781         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6782         vv(1)=pizda(1,1)+pizda(2,2)
6783         vv(2)=pizda(2,1)-pizda(1,2)
6784         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6785      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6786         if (calc_grad) then
6787 C Explicit gradient in virtual-dihedral angles.
6788         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6789      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6790         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6791         vv(1)=pizda(1,1)+pizda(2,2)
6792         vv(2)=pizda(2,1)-pizda(1,2)
6793         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6794      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6795      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6796 C Cartesian gradient
6797         do iii=1,2
6798           do kkk=1,5
6799             do lll=1,3
6800               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6801      &          pizda(1,1))
6802               vv(1)=pizda(1,1)+pizda(2,2)
6803               vv(2)=pizda(2,1)-pizda(1,2)
6804               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6805      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6806      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6807             enddo
6808           enddo
6809         enddo
6810         endif
6811       else
6812 C Antiparallel orientation
6813 C Contribution from graph III
6814 c        goto 1110
6815         call transpose2(EUg(1,1,j),auxmat(1,1))
6816         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6817         vv(1)=pizda(1,1)-pizda(2,2)
6818         vv(2)=pizda(1,2)+pizda(2,1)
6819         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6820      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6821         if (calc_grad) then
6822 C Explicit gradient in virtual-dihedral angles.
6823         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6824      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6825      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6826         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6827         vv(1)=pizda(1,1)-pizda(2,2)
6828         vv(2)=pizda(1,2)+pizda(2,1)
6829         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6830      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6831      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6832         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6833         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6834         vv(1)=pizda(1,1)-pizda(2,2)
6835         vv(2)=pizda(1,2)+pizda(2,1)
6836         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6837      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6838      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6839 C Cartesian gradient
6840         do iii=1,2
6841           do kkk=1,5
6842             do lll=1,3
6843               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6844      &          pizda(1,1))
6845               vv(1)=pizda(1,1)-pizda(2,2)
6846               vv(2)=pizda(1,2)+pizda(2,1)
6847               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6848      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6849      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6850             enddo
6851           enddo
6852         enddo
6853 cd        goto 1112
6854         endif
6855 C Contribution from graph IV
6856 1110    continue
6857         call transpose2(EE(1,1,itj),auxmat(1,1))
6858         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6859         vv(1)=pizda(1,1)+pizda(2,2)
6860         vv(2)=pizda(2,1)-pizda(1,2)
6861         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6862      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6863         if (calc_grad) then
6864 C Explicit gradient in virtual-dihedral angles.
6865         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6866      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6867         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6868         vv(1)=pizda(1,1)+pizda(2,2)
6869         vv(2)=pizda(2,1)-pizda(1,2)
6870         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6871      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6872      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6873 C Cartesian gradient
6874         do iii=1,2
6875           do kkk=1,5
6876             do lll=1,3
6877               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6878      &          pizda(1,1))
6879               vv(1)=pizda(1,1)+pizda(2,2)
6880               vv(2)=pizda(2,1)-pizda(1,2)
6881               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6882      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6883      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6884             enddo
6885           enddo
6886         enddo
6887       endif
6888       endif
6889 1112  continue
6890       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6891 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6892 cd        write (2,*) 'ijkl',i,j,k,l
6893 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6894 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6895 cd      endif
6896 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6897 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6898 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6899 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6900       if (calc_grad) then
6901       if (j.lt.nres-1) then
6902         j1=j+1
6903         j2=j-1
6904       else
6905         j1=j-1
6906         j2=j-2
6907       endif
6908       if (l.lt.nres-1) then
6909         l1=l+1
6910         l2=l-1
6911       else
6912         l1=l-1
6913         l2=l-2
6914       endif
6915 cd      eij=1.0d0
6916 cd      ekl=1.0d0
6917 cd      ekont=1.0d0
6918 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6919       do ll=1,3
6920         ggg1(ll)=eel5*g_contij(ll,1)
6921         ggg2(ll)=eel5*g_contij(ll,2)
6922 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6923         ghalf=0.5d0*ggg1(ll)
6924 cd        ghalf=0.0d0
6925         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6926         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6927         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6928         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6929 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6930         ghalf=0.5d0*ggg2(ll)
6931 cd        ghalf=0.0d0
6932         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6933         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6934         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6935         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6936       enddo
6937 cd      goto 1112
6938       do m=i+1,j-1
6939         do ll=1,3
6940 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6941           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6942         enddo
6943       enddo
6944       do m=k+1,l-1
6945         do ll=1,3
6946 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6947           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6948         enddo
6949       enddo
6950 c1112  continue
6951       do m=i+2,j2
6952         do ll=1,3
6953           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6954         enddo
6955       enddo
6956       do m=k+2,l2
6957         do ll=1,3
6958           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6959         enddo
6960       enddo
6961 cd      do iii=1,nres-3
6962 cd        write (2,*) iii,g_corr5_loc(iii)
6963 cd      enddo
6964       endif
6965       eello5=ekont*eel5
6966 cd      write (2,*) 'ekont',ekont
6967 cd      write (iout,*) 'eello5',ekont*eel5
6968       return
6969       end
6970 c--------------------------------------------------------------------------
6971       double precision function eello6(i,j,k,l,jj,kk)
6972       implicit real*8 (a-h,o-z)
6973       include 'DIMENSIONS'
6974       include 'DIMENSIONS.ZSCOPT'
6975       include 'COMMON.IOUNITS'
6976       include 'COMMON.CHAIN'
6977       include 'COMMON.DERIV'
6978       include 'COMMON.INTERACT'
6979       include 'COMMON.CONTACTS'
6980       include 'COMMON.TORSION'
6981       include 'COMMON.VAR'
6982       include 'COMMON.GEO'
6983       include 'COMMON.FFIELD'
6984       double precision ggg1(3),ggg2(3)
6985 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6986 cd        eello6=0.0d0
6987 cd        return
6988 cd      endif
6989 cd      write (iout,*)
6990 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6991 cd     &   ' and',k,l
6992       eello6_1=0.0d0
6993       eello6_2=0.0d0
6994       eello6_3=0.0d0
6995       eello6_4=0.0d0
6996       eello6_5=0.0d0
6997       eello6_6=0.0d0
6998 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6999 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7000       do iii=1,2
7001         do kkk=1,5
7002           do lll=1,3
7003             derx(lll,kkk,iii)=0.0d0
7004           enddo
7005         enddo
7006       enddo
7007 cd      eij=facont_hb(jj,i)
7008 cd      ekl=facont_hb(kk,k)
7009 cd      ekont=eij*ekl
7010 cd      eij=1.0d0
7011 cd      ekl=1.0d0
7012 cd      ekont=1.0d0
7013       if (l.eq.j+1) then
7014         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7015         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7016         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7017         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7018         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7019         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7020       else
7021         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7022         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7023         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7024         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7025         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7026           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7027         else
7028           eello6_5=0.0d0
7029         endif
7030         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7031       endif
7032 C If turn contributions are considered, they will be handled separately.
7033       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7034 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7035 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7036 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7037 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7038 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7039 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7040 cd      goto 1112
7041       if (calc_grad) then
7042       if (j.lt.nres-1) then
7043         j1=j+1
7044         j2=j-1
7045       else
7046         j1=j-1
7047         j2=j-2
7048       endif
7049       if (l.lt.nres-1) then
7050         l1=l+1
7051         l2=l-1
7052       else
7053         l1=l-1
7054         l2=l-2
7055       endif
7056       do ll=1,3
7057         ggg1(ll)=eel6*g_contij(ll,1)
7058         ggg2(ll)=eel6*g_contij(ll,2)
7059 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7060         ghalf=0.5d0*ggg1(ll)
7061 cd        ghalf=0.0d0
7062         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7063         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7064         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7065         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7066         ghalf=0.5d0*ggg2(ll)
7067 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7068 cd        ghalf=0.0d0
7069         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7070         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7071         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7072         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7073       enddo
7074 cd      goto 1112
7075       do m=i+1,j-1
7076         do ll=1,3
7077 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7078           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7079         enddo
7080       enddo
7081       do m=k+1,l-1
7082         do ll=1,3
7083 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7084           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7085         enddo
7086       enddo
7087 1112  continue
7088       do m=i+2,j2
7089         do ll=1,3
7090           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7091         enddo
7092       enddo
7093       do m=k+2,l2
7094         do ll=1,3
7095           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7096         enddo
7097       enddo
7098 cd      do iii=1,nres-3
7099 cd        write (2,*) iii,g_corr6_loc(iii)
7100 cd      enddo
7101       endif
7102       eello6=ekont*eel6
7103 cd      write (2,*) 'ekont',ekont
7104 cd      write (iout,*) 'eello6',ekont*eel6
7105       return
7106       end
7107 c--------------------------------------------------------------------------
7108       double precision function eello6_graph1(i,j,k,l,imat,swap)
7109       implicit real*8 (a-h,o-z)
7110       include 'DIMENSIONS'
7111       include 'DIMENSIONS.ZSCOPT'
7112       include 'COMMON.IOUNITS'
7113       include 'COMMON.CHAIN'
7114       include 'COMMON.DERIV'
7115       include 'COMMON.INTERACT'
7116       include 'COMMON.CONTACTS'
7117       include 'COMMON.TORSION'
7118       include 'COMMON.VAR'
7119       include 'COMMON.GEO'
7120       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7121       logical swap
7122       logical lprn
7123       common /kutas/ lprn
7124 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7125 C                                                                              C
7126 C      Parallel       Antiparallel                                             C
7127 C                                                                              C
7128 C          o             o                                                     C
7129 C         /l\           /j\                                                    C
7130 C        /   \         /   \                                                   C
7131 C       /| o |         | o |\                                                  C
7132 C     \ j|/k\|  /   \  |/k\|l /                                                C
7133 C      \ /   \ /     \ /   \ /                                                 C
7134 C       o     o       o     o                                                  C
7135 C       i             i                                                        C
7136 C                                                                              C
7137 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7138       itk=itortyp(itype(k))
7139       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7140       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7141       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7142       call transpose2(EUgC(1,1,k),auxmat(1,1))
7143       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7144       vv1(1)=pizda1(1,1)-pizda1(2,2)
7145       vv1(2)=pizda1(1,2)+pizda1(2,1)
7146       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7147       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7148       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7149       s5=scalar2(vv(1),Dtobr2(1,i))
7150 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7151       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7152       if (.not. calc_grad) return
7153       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7154      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7155      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7156      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7157      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7158      & +scalar2(vv(1),Dtobr2der(1,i)))
7159       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7160       vv1(1)=pizda1(1,1)-pizda1(2,2)
7161       vv1(2)=pizda1(1,2)+pizda1(2,1)
7162       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7163       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7164       if (l.eq.j+1) then
7165         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7166      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7167      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7168      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7169      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7170       else
7171         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7172      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7173      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7174      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7175      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7176       endif
7177       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7178       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7179       vv1(1)=pizda1(1,1)-pizda1(2,2)
7180       vv1(2)=pizda1(1,2)+pizda1(2,1)
7181       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7182      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7183      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7184      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7185       do iii=1,2
7186         if (swap) then
7187           ind=3-iii
7188         else
7189           ind=iii
7190         endif
7191         do kkk=1,5
7192           do lll=1,3
7193             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7194             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7195             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7196             call transpose2(EUgC(1,1,k),auxmat(1,1))
7197             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7198      &        pizda1(1,1))
7199             vv1(1)=pizda1(1,1)-pizda1(2,2)
7200             vv1(2)=pizda1(1,2)+pizda1(2,1)
7201             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7202             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7203      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7204             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7205      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7206             s5=scalar2(vv(1),Dtobr2(1,i))
7207             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7208           enddo
7209         enddo
7210       enddo
7211       return
7212       end
7213 c----------------------------------------------------------------------------
7214       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7215       implicit real*8 (a-h,o-z)
7216       include 'DIMENSIONS'
7217       include 'DIMENSIONS.ZSCOPT'
7218       include 'COMMON.IOUNITS'
7219       include 'COMMON.CHAIN'
7220       include 'COMMON.DERIV'
7221       include 'COMMON.INTERACT'
7222       include 'COMMON.CONTACTS'
7223       include 'COMMON.TORSION'
7224       include 'COMMON.VAR'
7225       include 'COMMON.GEO'
7226       logical swap
7227       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7228      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7229       logical lprn
7230       common /kutas/ lprn
7231 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7232 C                                                                              C
7233 C      Parallel       Antiparallel                                             C
7234 C                                                                              C
7235 C          o             o                                                     C
7236 C     \   /l\           /j\   /                                                C
7237 C      \ /   \         /   \ /                                                 C
7238 C       o| o |         | o |o                                                  C
7239 C     \ j|/k\|      \  |/k\|l                                                  C
7240 C      \ /   \       \ /   \                                                   C
7241 C       o             o                                                        C
7242 C       i             i                                                        C
7243 C                                                                              C
7244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7245 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7246 C AL 7/4/01 s1 would occur in the sixth-order moment,
7247 C           but not in a cluster cumulant
7248 #ifdef MOMENT
7249       s1=dip(1,jj,i)*dip(1,kk,k)
7250 #endif
7251       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7252       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7253       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7254       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7255       call transpose2(EUg(1,1,k),auxmat(1,1))
7256       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7257       vv(1)=pizda(1,1)-pizda(2,2)
7258       vv(2)=pizda(1,2)+pizda(2,1)
7259       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7260 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7261 #ifdef MOMENT
7262       eello6_graph2=-(s1+s2+s3+s4)
7263 #else
7264       eello6_graph2=-(s2+s3+s4)
7265 #endif
7266 c      eello6_graph2=-s3
7267       if (.not. calc_grad) return
7268 C Derivatives in gamma(i-1)
7269       if (i.gt.1) then
7270 #ifdef MOMENT
7271         s1=dipderg(1,jj,i)*dip(1,kk,k)
7272 #endif
7273         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7274         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7275         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7276         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7277 #ifdef MOMENT
7278         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7279 #else
7280         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7281 #endif
7282 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7283       endif
7284 C Derivatives in gamma(k-1)
7285 #ifdef MOMENT
7286       s1=dip(1,jj,i)*dipderg(1,kk,k)
7287 #endif
7288       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7289       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7290       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7291       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7292       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7293       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7294       vv(1)=pizda(1,1)-pizda(2,2)
7295       vv(2)=pizda(1,2)+pizda(2,1)
7296       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7297 #ifdef MOMENT
7298       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7299 #else
7300       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7301 #endif
7302 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7303 C Derivatives in gamma(j-1) or gamma(l-1)
7304       if (j.gt.1) then
7305 #ifdef MOMENT
7306         s1=dipderg(3,jj,i)*dip(1,kk,k)
7307 #endif
7308         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7309         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7310         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7311         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7312         vv(1)=pizda(1,1)-pizda(2,2)
7313         vv(2)=pizda(1,2)+pizda(2,1)
7314         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7315 #ifdef MOMENT
7316         if (swap) then
7317           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7318         else
7319           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7320         endif
7321 #endif
7322         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7323 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7324       endif
7325 C Derivatives in gamma(l-1) or gamma(j-1)
7326       if (l.gt.1) then
7327 #ifdef MOMENT
7328         s1=dip(1,jj,i)*dipderg(3,kk,k)
7329 #endif
7330         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7331         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7332         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7333         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7334         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7335         vv(1)=pizda(1,1)-pizda(2,2)
7336         vv(2)=pizda(1,2)+pizda(2,1)
7337         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7338 #ifdef MOMENT
7339         if (swap) then
7340           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7341         else
7342           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7343         endif
7344 #endif
7345         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7346 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7347       endif
7348 C Cartesian derivatives.
7349       if (lprn) then
7350         write (2,*) 'In eello6_graph2'
7351         do iii=1,2
7352           write (2,*) 'iii=',iii
7353           do kkk=1,5
7354             write (2,*) 'kkk=',kkk
7355             do jjj=1,2
7356               write (2,'(3(2f10.5),5x)')
7357      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7358             enddo
7359           enddo
7360         enddo
7361       endif
7362       do iii=1,2
7363         do kkk=1,5
7364           do lll=1,3
7365 #ifdef MOMENT
7366             if (iii.eq.1) then
7367               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7368             else
7369               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7370             endif
7371 #endif
7372             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7373      &        auxvec(1))
7374             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7375             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7376      &        auxvec(1))
7377             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7378             call transpose2(EUg(1,1,k),auxmat(1,1))
7379             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7380      &        pizda(1,1))
7381             vv(1)=pizda(1,1)-pizda(2,2)
7382             vv(2)=pizda(1,2)+pizda(2,1)
7383             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7384 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7385 #ifdef MOMENT
7386             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7387 #else
7388             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7389 #endif
7390             if (swap) then
7391               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7392             else
7393               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7394             endif
7395           enddo
7396         enddo
7397       enddo
7398       return
7399       end
7400 c----------------------------------------------------------------------------
7401       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7402       implicit real*8 (a-h,o-z)
7403       include 'DIMENSIONS'
7404       include 'DIMENSIONS.ZSCOPT'
7405       include 'COMMON.IOUNITS'
7406       include 'COMMON.CHAIN'
7407       include 'COMMON.DERIV'
7408       include 'COMMON.INTERACT'
7409       include 'COMMON.CONTACTS'
7410       include 'COMMON.TORSION'
7411       include 'COMMON.VAR'
7412       include 'COMMON.GEO'
7413       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7414       logical swap
7415 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7416 C                                                                              C
7417 C      Parallel       Antiparallel                                             C
7418 C                                                                              C
7419 C          o             o                                                     C
7420 C         /l\   /   \   /j\                                                    C
7421 C        /   \ /     \ /   \                                                   C
7422 C       /| o |o       o| o |\                                                  C
7423 C       j|/k\|  /      |/k\|l /                                                C
7424 C        /   \ /       /   \ /                                                 C
7425 C       /     o       /     o                                                  C
7426 C       i             i                                                        C
7427 C                                                                              C
7428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7429 C
7430 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7431 C           energy moment and not to the cluster cumulant.
7432       iti=itortyp(itype(i))
7433       if (j.lt.nres-1) then
7434         itj1=itortyp(itype(j+1))
7435       else
7436         itj1=ntortyp+1
7437       endif
7438       itk=itortyp(itype(k))
7439       itk1=itortyp(itype(k+1))
7440       if (l.lt.nres-1) then
7441         itl1=itortyp(itype(l+1))
7442       else
7443         itl1=ntortyp+1
7444       endif
7445 #ifdef MOMENT
7446       s1=dip(4,jj,i)*dip(4,kk,k)
7447 #endif
7448       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7449       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7450       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7451       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7452       call transpose2(EE(1,1,itk),auxmat(1,1))
7453       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7454       vv(1)=pizda(1,1)+pizda(2,2)
7455       vv(2)=pizda(2,1)-pizda(1,2)
7456       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7457 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7458 #ifdef MOMENT
7459       eello6_graph3=-(s1+s2+s3+s4)
7460 #else
7461       eello6_graph3=-(s2+s3+s4)
7462 #endif
7463 c      eello6_graph3=-s4
7464       if (.not. calc_grad) return
7465 C Derivatives in gamma(k-1)
7466       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7467       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7468       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7469       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7470 C Derivatives in gamma(l-1)
7471       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7472       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7473       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7474       vv(1)=pizda(1,1)+pizda(2,2)
7475       vv(2)=pizda(2,1)-pizda(1,2)
7476       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7477       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7478 C Cartesian derivatives.
7479       do iii=1,2
7480         do kkk=1,5
7481           do lll=1,3
7482 #ifdef MOMENT
7483             if (iii.eq.1) then
7484               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7485             else
7486               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7487             endif
7488 #endif
7489             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7490      &        auxvec(1))
7491             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7492             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7493      &        auxvec(1))
7494             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7495             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7496      &        pizda(1,1))
7497             vv(1)=pizda(1,1)+pizda(2,2)
7498             vv(2)=pizda(2,1)-pizda(1,2)
7499             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7500 #ifdef MOMENT
7501             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7502 #else
7503             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7504 #endif
7505             if (swap) then
7506               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7507             else
7508               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7509             endif
7510 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7511           enddo
7512         enddo
7513       enddo
7514       return
7515       end
7516 c----------------------------------------------------------------------------
7517       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7518       implicit real*8 (a-h,o-z)
7519       include 'DIMENSIONS'
7520       include 'DIMENSIONS.ZSCOPT'
7521       include 'COMMON.IOUNITS'
7522       include 'COMMON.CHAIN'
7523       include 'COMMON.DERIV'
7524       include 'COMMON.INTERACT'
7525       include 'COMMON.CONTACTS'
7526       include 'COMMON.TORSION'
7527       include 'COMMON.VAR'
7528       include 'COMMON.GEO'
7529       include 'COMMON.FFIELD'
7530       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7531      & auxvec1(2),auxmat1(2,2)
7532       logical swap
7533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7534 C                                                                              C
7535 C      Parallel       Antiparallel                                             C
7536 C                                                                              C
7537 C          o             o                                                     C
7538 C         /l\   /   \   /j\                                                    C
7539 C        /   \ /     \ /   \                                                   C
7540 C       /| o |o       o| o |\                                                  C
7541 C     \ j|/k\|      \  |/k\|l                                                  C
7542 C      \ /   \       \ /   \                                                   C
7543 C       o     \       o     \                                                  C
7544 C       i             i                                                        C
7545 C                                                                              C
7546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7547 C
7548 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7549 C           energy moment and not to the cluster cumulant.
7550 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7551       iti=itortyp(itype(i))
7552       itj=itortyp(itype(j))
7553       if (j.lt.nres-1) then
7554         itj1=itortyp(itype(j+1))
7555       else
7556         itj1=ntortyp+1
7557       endif
7558       itk=itortyp(itype(k))
7559       if (k.lt.nres-1) then
7560         itk1=itortyp(itype(k+1))
7561       else
7562         itk1=ntortyp+1
7563       endif
7564       itl=itortyp(itype(l))
7565       if (l.lt.nres-1) then
7566         itl1=itortyp(itype(l+1))
7567       else
7568         itl1=ntortyp+1
7569       endif
7570 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7571 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7572 cd     & ' itl',itl,' itl1',itl1
7573 #ifdef MOMENT
7574       if (imat.eq.1) then
7575         s1=dip(3,jj,i)*dip(3,kk,k)
7576       else
7577         s1=dip(2,jj,j)*dip(2,kk,l)
7578       endif
7579 #endif
7580       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7581       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7582       if (j.eq.l+1) then
7583         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7584         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7585       else
7586         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7587         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7588       endif
7589       call transpose2(EUg(1,1,k),auxmat(1,1))
7590       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7591       vv(1)=pizda(1,1)-pizda(2,2)
7592       vv(2)=pizda(2,1)+pizda(1,2)
7593       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7594 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7595 #ifdef MOMENT
7596       eello6_graph4=-(s1+s2+s3+s4)
7597 #else
7598       eello6_graph4=-(s2+s3+s4)
7599 #endif
7600       if (.not. calc_grad) return
7601 C Derivatives in gamma(i-1)
7602       if (i.gt.1) then
7603 #ifdef MOMENT
7604         if (imat.eq.1) then
7605           s1=dipderg(2,jj,i)*dip(3,kk,k)
7606         else
7607           s1=dipderg(4,jj,j)*dip(2,kk,l)
7608         endif
7609 #endif
7610         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7611         if (j.eq.l+1) then
7612           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7613           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7614         else
7615           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7616           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7617         endif
7618         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7619         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7620 cd          write (2,*) 'turn6 derivatives'
7621 #ifdef MOMENT
7622           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7623 #else
7624           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7625 #endif
7626         else
7627 #ifdef MOMENT
7628           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7629 #else
7630           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7631 #endif
7632         endif
7633       endif
7634 C Derivatives in gamma(k-1)
7635 #ifdef MOMENT
7636       if (imat.eq.1) then
7637         s1=dip(3,jj,i)*dipderg(2,kk,k)
7638       else
7639         s1=dip(2,jj,j)*dipderg(4,kk,l)
7640       endif
7641 #endif
7642       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7643       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7644       if (j.eq.l+1) then
7645         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7646         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7647       else
7648         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7649         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7650       endif
7651       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7652       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7653       vv(1)=pizda(1,1)-pizda(2,2)
7654       vv(2)=pizda(2,1)+pizda(1,2)
7655       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7656       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7657 #ifdef MOMENT
7658         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7659 #else
7660         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7661 #endif
7662       else
7663 #ifdef MOMENT
7664         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7665 #else
7666         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7667 #endif
7668       endif
7669 C Derivatives in gamma(j-1) or gamma(l-1)
7670       if (l.eq.j+1 .and. l.gt.1) then
7671         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7672         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7673         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7674         vv(1)=pizda(1,1)-pizda(2,2)
7675         vv(2)=pizda(2,1)+pizda(1,2)
7676         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7677         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7678       else if (j.gt.1) then
7679         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7680         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7681         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7682         vv(1)=pizda(1,1)-pizda(2,2)
7683         vv(2)=pizda(2,1)+pizda(1,2)
7684         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7685         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7686           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7687         else
7688           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7689         endif
7690       endif
7691 C Cartesian derivatives.
7692       do iii=1,2
7693         do kkk=1,5
7694           do lll=1,3
7695 #ifdef MOMENT
7696             if (iii.eq.1) then
7697               if (imat.eq.1) then
7698                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7699               else
7700                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7701               endif
7702             else
7703               if (imat.eq.1) then
7704                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7705               else
7706                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7707               endif
7708             endif
7709 #endif
7710             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7711      &        auxvec(1))
7712             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7713             if (j.eq.l+1) then
7714               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7715      &          b1(1,itj1),auxvec(1))
7716               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7717             else
7718               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7719      &          b1(1,itl1),auxvec(1))
7720               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7721             endif
7722             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7723      &        pizda(1,1))
7724             vv(1)=pizda(1,1)-pizda(2,2)
7725             vv(2)=pizda(2,1)+pizda(1,2)
7726             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7727             if (swap) then
7728               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7729 #ifdef MOMENT
7730                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7731      &             -(s1+s2+s4)
7732 #else
7733                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7734      &             -(s2+s4)
7735 #endif
7736                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7737               else
7738 #ifdef MOMENT
7739                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7740 #else
7741                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7742 #endif
7743                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7744               endif
7745             else
7746 #ifdef MOMENT
7747               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7748 #else
7749               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7750 #endif
7751               if (l.eq.j+1) then
7752                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7753               else
7754                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7755               endif
7756             endif
7757           enddo
7758         enddo
7759       enddo
7760       return
7761       end
7762 c----------------------------------------------------------------------------
7763       double precision function eello_turn6(i,jj,kk)
7764       implicit real*8 (a-h,o-z)
7765       include 'DIMENSIONS'
7766       include 'DIMENSIONS.ZSCOPT'
7767       include 'COMMON.IOUNITS'
7768       include 'COMMON.CHAIN'
7769       include 'COMMON.DERIV'
7770       include 'COMMON.INTERACT'
7771       include 'COMMON.CONTACTS'
7772       include 'COMMON.TORSION'
7773       include 'COMMON.VAR'
7774       include 'COMMON.GEO'
7775       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7776      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7777      &  ggg1(3),ggg2(3)
7778       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7779      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7780 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7781 C           the respective energy moment and not to the cluster cumulant.
7782       eello_turn6=0.0d0
7783       j=i+4
7784       k=i+1
7785       l=i+3
7786       iti=itortyp(itype(i))
7787       itk=itortyp(itype(k))
7788       itk1=itortyp(itype(k+1))
7789       itl=itortyp(itype(l))
7790       itj=itortyp(itype(j))
7791 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7792 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7793 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7794 cd        eello6=0.0d0
7795 cd        return
7796 cd      endif
7797 cd      write (iout,*)
7798 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7799 cd     &   ' and',k,l
7800 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7801       do iii=1,2
7802         do kkk=1,5
7803           do lll=1,3
7804             derx_turn(lll,kkk,iii)=0.0d0
7805           enddo
7806         enddo
7807       enddo
7808 cd      eij=1.0d0
7809 cd      ekl=1.0d0
7810 cd      ekont=1.0d0
7811       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7812 cd      eello6_5=0.0d0
7813 cd      write (2,*) 'eello6_5',eello6_5
7814 #ifdef MOMENT
7815       call transpose2(AEA(1,1,1),auxmat(1,1))
7816       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7817       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7818       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7819 #else
7820       s1 = 0.0d0
7821 #endif
7822       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7823       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7824       s2 = scalar2(b1(1,itk),vtemp1(1))
7825 #ifdef MOMENT
7826       call transpose2(AEA(1,1,2),atemp(1,1))
7827       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7828       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7829       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7830 #else
7831       s8=0.0d0
7832 #endif
7833       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7834       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7835       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7836 #ifdef MOMENT
7837       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7838       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7839       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7840       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7841       ss13 = scalar2(b1(1,itk),vtemp4(1))
7842       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7843 #else
7844       s13=0.0d0
7845 #endif
7846 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7847 c      s1=0.0d0
7848 c      s2=0.0d0
7849 c      s8=0.0d0
7850 c      s12=0.0d0
7851 c      s13=0.0d0
7852       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7853       if (calc_grad) then
7854 C Derivatives in gamma(i+2)
7855 #ifdef MOMENT
7856       call transpose2(AEA(1,1,1),auxmatd(1,1))
7857       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7858       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7859       call transpose2(AEAderg(1,1,2),atempd(1,1))
7860       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7861       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7862 #else
7863       s8d=0.0d0
7864 #endif
7865       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7866       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7867       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7868 c      s1d=0.0d0
7869 c      s2d=0.0d0
7870 c      s8d=0.0d0
7871 c      s12d=0.0d0
7872 c      s13d=0.0d0
7873       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7874 C Derivatives in gamma(i+3)
7875 #ifdef MOMENT
7876       call transpose2(AEA(1,1,1),auxmatd(1,1))
7877       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7878       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7879       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7880 #else
7881       s1d=0.0d0
7882 #endif
7883       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7884       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7885       s2d = scalar2(b1(1,itk),vtemp1d(1))
7886 #ifdef MOMENT
7887       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7888       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7889 #endif
7890       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7891 #ifdef MOMENT
7892       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7893       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7894       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7895 #else
7896       s13d=0.0d0
7897 #endif
7898 c      s1d=0.0d0
7899 c      s2d=0.0d0
7900 c      s8d=0.0d0
7901 c      s12d=0.0d0
7902 c      s13d=0.0d0
7903 #ifdef MOMENT
7904       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7905      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7906 #else
7907       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7908      &               -0.5d0*ekont*(s2d+s12d)
7909 #endif
7910 C Derivatives in gamma(i+4)
7911       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7912       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7913       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7914 #ifdef MOMENT
7915       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7916       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7917       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7918 #else
7919       s13d = 0.0d0
7920 #endif
7921 c      s1d=0.0d0
7922 c      s2d=0.0d0
7923 c      s8d=0.0d0
7924 C      s12d=0.0d0
7925 c      s13d=0.0d0
7926 #ifdef MOMENT
7927       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7928 #else
7929       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7930 #endif
7931 C Derivatives in gamma(i+5)
7932 #ifdef MOMENT
7933       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7934       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7935       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7936 #else
7937       s1d = 0.0d0
7938 #endif
7939       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7940       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7941       s2d = scalar2(b1(1,itk),vtemp1d(1))
7942 #ifdef MOMENT
7943       call transpose2(AEA(1,1,2),atempd(1,1))
7944       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7945       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7946 #else
7947       s8d = 0.0d0
7948 #endif
7949       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7950       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7951 #ifdef MOMENT
7952       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7953       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7954       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7955 #else
7956       s13d = 0.0d0
7957 #endif
7958 c      s1d=0.0d0
7959 c      s2d=0.0d0
7960 c      s8d=0.0d0
7961 c      s12d=0.0d0
7962 c      s13d=0.0d0
7963 #ifdef MOMENT
7964       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7965      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7966 #else
7967       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7968      &               -0.5d0*ekont*(s2d+s12d)
7969 #endif
7970 C Cartesian derivatives
7971       do iii=1,2
7972         do kkk=1,5
7973           do lll=1,3
7974 #ifdef MOMENT
7975             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7976             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7977             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7978 #else
7979             s1d = 0.0d0
7980 #endif
7981             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7982             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7983      &          vtemp1d(1))
7984             s2d = scalar2(b1(1,itk),vtemp1d(1))
7985 #ifdef MOMENT
7986             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7987             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7988             s8d = -(atempd(1,1)+atempd(2,2))*
7989      &           scalar2(cc(1,1,itl),vtemp2(1))
7990 #else
7991             s8d = 0.0d0
7992 #endif
7993             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7994      &           auxmatd(1,1))
7995             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7996             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7997 c      s1d=0.0d0
7998 c      s2d=0.0d0
7999 c      s8d=0.0d0
8000 c      s12d=0.0d0
8001 c      s13d=0.0d0
8002 #ifdef MOMENT
8003             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8004      &        - 0.5d0*(s1d+s2d)
8005 #else
8006             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8007      &        - 0.5d0*s2d
8008 #endif
8009 #ifdef MOMENT
8010             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8011      &        - 0.5d0*(s8d+s12d)
8012 #else
8013             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8014      &        - 0.5d0*s12d
8015 #endif
8016           enddo
8017         enddo
8018       enddo
8019 #ifdef MOMENT
8020       do kkk=1,5
8021         do lll=1,3
8022           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8023      &      achuj_tempd(1,1))
8024           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8025           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8026           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8027           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8028           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8029      &      vtemp4d(1))
8030           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8031           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8032           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8033         enddo
8034       enddo
8035 #endif
8036 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8037 cd     &  16*eel_turn6_num
8038 cd      goto 1112
8039       if (j.lt.nres-1) then
8040         j1=j+1
8041         j2=j-1
8042       else
8043         j1=j-1
8044         j2=j-2
8045       endif
8046       if (l.lt.nres-1) then
8047         l1=l+1
8048         l2=l-1
8049       else
8050         l1=l-1
8051         l2=l-2
8052       endif
8053       do ll=1,3
8054         ggg1(ll)=eel_turn6*g_contij(ll,1)
8055         ggg2(ll)=eel_turn6*g_contij(ll,2)
8056         ghalf=0.5d0*ggg1(ll)
8057 cd        ghalf=0.0d0
8058         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8059      &    +ekont*derx_turn(ll,2,1)
8060         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8061         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8062      &    +ekont*derx_turn(ll,4,1)
8063         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8064         ghalf=0.5d0*ggg2(ll)
8065 cd        ghalf=0.0d0
8066         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8067      &    +ekont*derx_turn(ll,2,2)
8068         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8069         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8070      &    +ekont*derx_turn(ll,4,2)
8071         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8072       enddo
8073 cd      goto 1112
8074       do m=i+1,j-1
8075         do ll=1,3
8076           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8077         enddo
8078       enddo
8079       do m=k+1,l-1
8080         do ll=1,3
8081           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8082         enddo
8083       enddo
8084 1112  continue
8085       do m=i+2,j2
8086         do ll=1,3
8087           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8088         enddo
8089       enddo
8090       do m=k+2,l2
8091         do ll=1,3
8092           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8093         enddo
8094       enddo
8095 cd      do iii=1,nres-3
8096 cd        write (2,*) iii,g_corr6_loc(iii)
8097 cd      enddo
8098       endif
8099       eello_turn6=ekont*eel_turn6
8100 cd      write (2,*) 'ekont',ekont
8101 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8102       return
8103       end
8104 crc-------------------------------------------------
8105       SUBROUTINE MATVEC2(A1,V1,V2)
8106       implicit real*8 (a-h,o-z)
8107       include 'DIMENSIONS'
8108       DIMENSION A1(2,2),V1(2),V2(2)
8109 c      DO 1 I=1,2
8110 c        VI=0.0
8111 c        DO 3 K=1,2
8112 c    3     VI=VI+A1(I,K)*V1(K)
8113 c        Vaux(I)=VI
8114 c    1 CONTINUE
8115
8116       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8117       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8118
8119       v2(1)=vaux1
8120       v2(2)=vaux2
8121       END
8122 C---------------------------------------
8123       SUBROUTINE MATMAT2(A1,A2,A3)
8124       implicit real*8 (a-h,o-z)
8125       include 'DIMENSIONS'
8126       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8127 c      DIMENSION AI3(2,2)
8128 c        DO  J=1,2
8129 c          A3IJ=0.0
8130 c          DO K=1,2
8131 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8132 c          enddo
8133 c          A3(I,J)=A3IJ
8134 c       enddo
8135 c      enddo
8136
8137       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8138       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8139       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8140       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8141
8142       A3(1,1)=AI3_11
8143       A3(2,1)=AI3_21
8144       A3(1,2)=AI3_12
8145       A3(2,2)=AI3_22
8146       END
8147
8148 c-------------------------------------------------------------------------
8149       double precision function scalar2(u,v)
8150       implicit none
8151       double precision u(2),v(2)
8152       double precision sc
8153       integer i
8154       scalar2=u(1)*v(1)+u(2)*v(2)
8155       return
8156       end
8157
8158 C-----------------------------------------------------------------------------
8159
8160       subroutine transpose2(a,at)
8161       implicit none
8162       double precision a(2,2),at(2,2)
8163       at(1,1)=a(1,1)
8164       at(1,2)=a(2,1)
8165       at(2,1)=a(1,2)
8166       at(2,2)=a(2,2)
8167       return
8168       end
8169 c--------------------------------------------------------------------------
8170       subroutine transpose(n,a,at)
8171       implicit none
8172       integer n,i,j
8173       double precision a(n,n),at(n,n)
8174       do i=1,n
8175         do j=1,n
8176           at(j,i)=a(i,j)
8177         enddo
8178       enddo
8179       return
8180       end
8181 C---------------------------------------------------------------------------
8182       subroutine prodmat3(a1,a2,kk,transp,prod)
8183       implicit none
8184       integer i,j
8185       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8186       logical transp
8187 crc      double precision auxmat(2,2),prod_(2,2)
8188
8189       if (transp) then
8190 crc        call transpose2(kk(1,1),auxmat(1,1))
8191 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8192 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8193
8194            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8195      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8196            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8197      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8198            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8199      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8200            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8201      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8202
8203       else
8204 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8205 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8206
8207            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8208      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8209            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8210      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8211            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8212      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8213            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8214      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8215
8216       endif
8217 c      call transpose2(a2(1,1),a2t(1,1))
8218
8219 crc      print *,transp
8220 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8221 crc      print *,((prod(i,j),i=1,2),j=1,2)
8222
8223       return
8224       end
8225 C-----------------------------------------------------------------------------
8226       double precision function scalar(u,v)
8227       implicit none
8228       double precision u(3),v(3)
8229       double precision sc
8230       integer i
8231       sc=0.0d0
8232       do i=1,3
8233         sc=sc+u(i)*v(i)
8234       enddo
8235       scalar=sc
8236       return
8237       end
8238