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
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.CONTROL'
  26       double precision fact(6)
  27 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  28 cd    print *,'nnt=',nnt,' nct=',nct
  29 C
  30 C Compute the side-chain and electrostatic interaction energy
  31 C
  32       goto (101,102,103,104,105) ipot
  33 C Lennard-Jones potential.
  34   101 call elj(evdw,evdw_t)
  35 cd    print '(a)','Exit ELJ'
  36       goto 106
  37 C Lennard-Jones-Kihara potential (shifted).
  38   102 call eljk(evdw,evdw_t)
  39       goto 106
  40 C Berne-Pechukas potential (dilated LJ, angular dependence).
  41   103 call ebp(evdw,evdw_t)
  42       goto 106
  43 C Gay-Berne potential (shifted LJ, angular dependence).
  44   104 call egb(evdw,evdw_t)
  45       goto 106
  46 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  47   105 call egbv(evdw,evdw_t)
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  52 C
  53 C Calculate excluded-volume interaction energy between peptide groups
  54 C and side chains.
  55 C
  56       call escp(evdw2,evdw2_14)
  57 c
  58 c Calculate the bond-stretching energy
  59 c
  60       call ebond(estr)
  61 c      write (iout,*) "estr",estr
  62 C
  63 C Calculate the disulfide-bridge and other energy and the contributions
  64 C from other distance constraints.
  65 cd    print *,'Calling EHPB'
  66       call edis(ehpb)
  67 cd    print *,'EHPB exitted succesfully.'
  68 C
  69 C Calculate the virtual-bond-angle energy.
  70 C
  71       call ebend(ebe)
  72 cd    print *,'Bend energy finished.'
  73 C
  74 C Calculate the SC local energy.
  75 C
  76       call esc(escloc)
  77 cd    print *,'SCLOC energy finished.'
  78 C
  79 C Calculate the virtual-bond torsional energy.
  80 C
  81 cd    print *,'nterm=',nterm
  82       call etor(etors,edihcnstr,fact(1))
  83 C
  84 C 6/23/01 Calculate double-torsional energy
  85 C
  86       call etor_d(etors_d,fact(2))
  87 C
  88 C 21/5/07 Calculate local sicdechain correlation energy
  89 C
  90       call eback_sc_corr(esccor)
  91 C
  92 C 12/1/95 Multi-body terms
  93 C
  94       n_corr=0
  95       n_corr1=0
  96       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  97      &    .or. wturn6.gt.0.0d0) then
  98 c         print *,"calling multibody_eello"
  99          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 100 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 101 c         print *,ecorr,ecorr5,ecorr6,eturn6
 102       endif
 103       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 104          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 105       endif
 106
 107
 108 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 109       if (constr_homology.ge.1) then
 110         call e_modeller(ehomology_constr)
 111       else
 112         ehomology_constr=0.0d0
 113       endif
 114
 115 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 116
 117 C     BARTEK for dfa test!
 118       if (wdfa_dist.gt.0) call edfad(edfadis)
 119 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 120       if (wdfa_tor.gt.0) call edfat(edfator)
 121 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 122       if (wdfa_nei.gt.0) call edfan(edfanei)
 123 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 124       if (wdfa_beta.gt.0) call edfab(edfabet)
 125 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 126
 127 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 128 #ifdef SPLITELE
 129       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 130      & +wvdwpp*evdw1
 131      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 132      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 133      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 134      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 135      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 136      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 137      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 138      & +wdfa_beta*edfabet
 139 #else
 140       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 141      & +welec*fact(1)*(ees+evdw1)
 142      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 143      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 144      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 145      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 146      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 147      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 148      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 149      & +wdfa_beta*edfabet
 150 #endif
 151       energia(0)=etot
 152       energia(1)=evdw
 153 #ifdef SCP14
 154       energia(2)=evdw2-evdw2_14
 155       energia(17)=evdw2_14
 156 #else
 157       energia(2)=evdw2
 158       energia(17)=0.0d0
 159 #endif
 160 #ifdef SPLITELE
 161       energia(3)=ees
 162       energia(16)=evdw1
 163 #else
 164       energia(3)=ees+evdw1
 165       energia(16)=0.0d0
 166 #endif
 167       energia(4)=ecorr
 168       energia(5)=ecorr5
 169       energia(6)=ecorr6
 170       energia(7)=eel_loc
 171       energia(8)=eello_turn3
 172       energia(9)=eello_turn4
 173       energia(10)=eturn6
 174       energia(11)=ebe
 175       energia(12)=escloc
 176       energia(13)=etors
 177       energia(14)=etors_d
 178       energia(15)=ehpb
 179       energia(18)=estr
 180       energia(19)=esccor
 181       energia(20)=edihcnstr
 182       energia(21)=evdw_t
 183       energia(22)=ehomology_constr
 184       energia(23)=edfadis
 185       energia(24)=edfator
 186       energia(25)=edfanei
 187       energia(26)=edfabet
 188 c      if (dyn_ss) call dyn_set_nss
 189 c detecting NaNQ
 190 #ifdef ISNAN
 191 #ifdef AIX
 192       if (isnan(etot).ne.0) energia(0)=1.0d+99
 193 #else
 194       if (isnan(etot)) energia(0)=1.0d+99
 195 #endif
 196 #else
 197       i=0
 198 #ifdef WINPGI
 199       idumm=proc_proc(etot,i)
 200 #else
 201       call proc_proc(etot,i)
 202 #endif
 203       if(i.eq.1)energia(0)=1.0d+99
 204 #endif
 205 #ifdef MPL
 206 c     endif
 207 #endif
 208       if (calc_grad) then
 209 C
 210 C Sum up the components of the Cartesian gradient.
 211 C
 212 #ifdef SPLITELE
 213       do i=1,nct
 214         do j=1,3
 215           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 216      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 217      &                wbond*gradb(j,i)+
 218      &                wstrain*ghpbc(j,i)+
 219      &                wcorr*fact(3)*gradcorr(j,i)+
 220      &                wel_loc*fact(2)*gel_loc(j,i)+
 221      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 222      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 223      &                wcorr5*fact(4)*gradcorr5(j,i)+
 224      &                wcorr6*fact(5)*gradcorr6(j,i)+
 225      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 226      &                wsccor*fact(2)*gsccorc(j,i)+
 227      &                wdfa_dist*gdfad(j,i)+
 228      &                wdfa_tor*gdfat(j,i)+
 229      &                wdfa_nei*gdfan(j,i)+
 230      &                wdfa_beta*gdfab(j,i)
 231           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 232      &                  wbond*gradbx(j,i)+
 233      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 234      &                  wsccor*fact(2)*gsccorx(j,i)
 235         enddo
 236 #else
 237       do i=1,nct
 238         do j=1,3
 239           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 240      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 241      &                wbond*gradb(j,i)+
 242      &                wcorr*fact(3)*gradcorr(j,i)+
 243      &                wel_loc*fact(2)*gel_loc(j,i)+
 244      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 245      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 246      &                wcorr5*fact(4)*gradcorr5(j,i)+
 247      &                wcorr6*fact(5)*gradcorr6(j,i)+
 248      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 249      &                wsccor*fact(2)*gsccorc(j,i)+
 250      &                wdfa_dist*gdfad(j,i)+
 251      &                wdfa_tor*gdfat(j,i)+
 252      &                wdfa_nei*gdfan(j,i)+
 253      &                wdfa_beta*gdfab(j,i)
 254           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 255      &                  wbond*gradbx(j,i)+
 256      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 257      &                  wsccor*fact(1)*gsccorx(j,i)
 258         enddo
 259 #endif
 260       enddo
 261
 262
 263       do i=1,nres-3
 264         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 265      &   +wcorr5*fact(4)*g_corr5_loc(i)
 266      &   +wcorr6*fact(5)*g_corr6_loc(i)
 267      &   +wturn4*fact(3)*gel_loc_turn4(i)
 268      &   +wturn3*fact(2)*gel_loc_turn3(i)
 269      &   +wturn6*fact(5)*gel_loc_turn6(i)
 270      &   +wel_loc*fact(2)*gel_loc_loc(i)
 271      &   +wsccor*fact(1)*gsccor_loc(i)
 272       enddo
 273       endif
 274       return
 275       end
 276 C------------------------------------------------------------------------
 277       subroutine enerprint(energia,fact)
 278       implicit real*8 (a-h,o-z)
 279       include 'DIMENSIONS'
 280       include 'DIMENSIONS.ZSCOPT'
 281       include 'COMMON.IOUNITS'
 282       include 'COMMON.FFIELD'
 283       include 'COMMON.SBRIDGE'
 284       double precision energia(0:max_ene),fact(6)
 285       etot=energia(0)
 286       evdw=energia(1)+fact(6)*energia(21)
 287 #ifdef SCP14
 288       evdw2=energia(2)+energia(17)
 289 #else
 290       evdw2=energia(2)
 291 #endif
 292       ees=energia(3)
 293 #ifdef SPLITELE
 294       evdw1=energia(16)
 295 #endif
 296       ecorr=energia(4)
 297       ecorr5=energia(5)
 298       ecorr6=energia(6)
 299       eel_loc=energia(7)
 300       eello_turn3=energia(8)
 301       eello_turn4=energia(9)
 302       eello_turn6=energia(10)
 303       ebe=energia(11)
 304       escloc=energia(12)
 305       etors=energia(13)
 306       etors_d=energia(14)
 307       ehpb=energia(15)
 308       esccor=energia(19)
 309       edihcnstr=energia(20)
 310       estr=energia(18)
 311       ehomology_constr=energia(22)
 312       edfadis=energia(23)
 313       edfator=energia(24)
 314       edfanei=energia(25)
 315       edfabet=energia(26)
 316 #ifdef SPLITELE
 317       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 318      &  wvdwpp,
 319      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 320      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 321      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 322      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 323      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 324      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 325      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 326      &  wdfa_beta,etot
 327    10 format (/'Virtual-chain energies:'//
 328      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 329      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 330      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 331      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 332      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 333      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 334      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 335      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 336      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 337      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 338      & ' (SS bridges & dist. cnstr.)'/
 339      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 340      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 341      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 342      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 343      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 344      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 345      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 346      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 347      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 348      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 349      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 350      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 351      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 352      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 353      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 354      & 'ETOT=  ',1pE16.6,' (total)')
 355 #else
 356       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 357      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 358      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 359      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 360      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 361      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 362      &  edihcnstr,ehomology_constr,ebr*nss,
 363      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,edfabet,
 364      &  wdfa_beta,etot
 365    10 format (/'Virtual-chain energies:'//
 366      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 367      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 368      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 369      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 370      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 371      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 372      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 373      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 374      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 375      & ' (SS bridges & dist. cnstr.)'/
 376      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 377      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 378      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 379      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 380      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 381      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 382      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 383      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 384      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 385      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 386      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 387      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
 388      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
 389      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
 390      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
 391      & 'ETOT=  ',1pE16.6,' (total)')
 392 #endif
 393       return
 394       end
 395 C-----------------------------------------------------------------------
 396       subroutine elj(evdw,evdw_t)
 397 C
 398 C This subroutine calculates the interaction energy of nonbonded side chains
 399 C assuming the LJ potential of interaction.
 400 C
 401       implicit real*8 (a-h,o-z)
 402       include 'DIMENSIONS'
 403       include 'DIMENSIONS.ZSCOPT'
 404       include "DIMENSIONS.COMPAR"
 405       parameter (accur=1.0d-10)
 406       include 'COMMON.GEO'
 407       include 'COMMON.VAR'
 408       include 'COMMON.LOCAL'
 409       include 'COMMON.CHAIN'
 410       include 'COMMON.DERIV'
 411       include 'COMMON.INTERACT'
 412       include 'COMMON.TORSION'
 413       include 'COMMON.ENEPS'
 414       include 'COMMON.SBRIDGE'
 415       include 'COMMON.NAMES'
 416       include 'COMMON.IOUNITS'
 417       include 'COMMON.CONTACTS'
 418       dimension gg(3)
 419       integer icant
 420       external icant
 421 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 422       do i=1,210
 423         do j=1,2
 424           eneps_temp(j,i)=0.0d0
 425         enddo
 426       enddo
 427       evdw=0.0D0
 428       evdw_t=0.0d0
 429       do i=iatsc_s,iatsc_e
 430         itypi=itype(i)
 431         itypi1=itype(i+1)
 432         xi=c(1,nres+i)
 433         yi=c(2,nres+i)
 434         zi=c(3,nres+i)
 435 C Change 12/1/95
 436         num_conti=0
 437 C
 438 C Calculate SC interaction energy.
 439 C
 440         do iint=1,nint_gr(i)
 441 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 442 cd   &                  'iend=',iend(i,iint)
 443           do j=istart(i,iint),iend(i,iint)
 444             itypj=itype(j)
 445             xj=c(1,nres+j)-xi
 446             yj=c(2,nres+j)-yi
 447             zj=c(3,nres+j)-zi
 448 C Change 12/1/95 to calculate four-body interactions
 449             rij=xj*xj+yj*yj+zj*zj
 450             rrij=1.0D0/rij
 451 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 452             eps0ij=eps(itypi,itypj)
 453             fac=rrij**expon2
 454             e1=fac*fac*aa(itypi,itypj)
 455             e2=fac*bb(itypi,itypj)
 456             evdwij=e1+e2
 457             ij=icant(itypi,itypj)
 458             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 459             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 460 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 461 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 462 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 463 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 464 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 465 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 466             if (bb(itypi,itypj).gt.0.0d0) then
 467               evdw=evdw+evdwij
 468             else
 469               evdw_t=evdw_t+evdwij
 470             endif
 471             if (calc_grad) then
 472 C
 473 C Calculate the components of the gradient in DC and X
 474 C
 475             fac=-rrij*(e1+evdwij)
 476             gg(1)=xj*fac
 477             gg(2)=yj*fac
 478             gg(3)=zj*fac
 479             do k=1,3
 480               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 481               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 482             enddo
 483             do k=i,j-1
 484               do l=1,3
 485                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 486               enddo
 487             enddo
 488             endif
 489 C
 490 C 12/1/95, revised on 5/20/97
 491 C
 492 C Calculate the contact function. The ith column of the array JCONT will
 493 C contain the numbers of atoms that make contacts with the atom I (of numbers
 494 C greater than I). The arrays FACONT and GACONT will contain the values of
 495 C the contact function and its derivative.
 496 C
 497 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 498 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 499 C Uncomment next line, if the correlation interactions are contact function only
 500             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 501               rij=dsqrt(rij)
 502               sigij=sigma(itypi,itypj)
 503               r0ij=rs0(itypi,itypj)
 504 C
 505 C Check whether the SC's are not too far to make a contact.
 506 C
 507               rcut=1.5d0*r0ij
 508               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 509 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 510 C
 511               if (fcont.gt.0.0D0) then
 512 C If the SC-SC distance if close to sigma, apply spline.
 513 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 514 cAdam &             fcont1,fprimcont1)
 515 cAdam           fcont1=1.0d0-fcont1
 516 cAdam           if (fcont1.gt.0.0d0) then
 517 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 518 cAdam             fcont=fcont*fcont1
 519 cAdam           endif
 520 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 521 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 522 cga             do k=1,3
 523 cga               gg(k)=gg(k)*eps0ij
 524 cga             enddo
 525 cga             eps0ij=-evdwij*eps0ij
 526 C Uncomment for AL's type of SC correlation interactions.
 527 cadam           eps0ij=-evdwij
 528                 num_conti=num_conti+1
 529                 jcont(num_conti,i)=j
 530                 facont(num_conti,i)=fcont*eps0ij
 531                 fprimcont=eps0ij*fprimcont/rij
 532                 fcont=expon*fcont
 533 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 534 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 535 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 536 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 537                 gacont(1,num_conti,i)=-fprimcont*xj
 538                 gacont(2,num_conti,i)=-fprimcont*yj
 539                 gacont(3,num_conti,i)=-fprimcont*zj
 540 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 541 cd              write (iout,'(2i3,3f10.5)')
 542 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 543               endif
 544             endif
 545           enddo      ! j
 546         enddo        ! iint
 547 C Change 12/1/95
 548         num_cont(i)=num_conti
 549       enddo          ! i
 550       if (calc_grad) then
 551       do i=1,nct
 552         do j=1,3
 553           gvdwc(j,i)=expon*gvdwc(j,i)
 554           gvdwx(j,i)=expon*gvdwx(j,i)
 555         enddo
 556       enddo
 557       endif
 558 C******************************************************************************
 559 C
 560 C                              N O T E !!!
 561 C
 562 C To save time, the factor of EXPON has been extracted from ALL components
 563 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 564 C use!
 565 C
 566 C******************************************************************************
 567       return
 568       end
 569 C-----------------------------------------------------------------------------
 570       subroutine eljk(evdw,evdw_t)
 571 C
 572 C This subroutine calculates the interaction energy of nonbonded side chains
 573 C assuming the LJK potential of interaction.
 574 C
 575       implicit real*8 (a-h,o-z)
 576       include 'DIMENSIONS'
 577       include 'DIMENSIONS.ZSCOPT'
 578       include "DIMENSIONS.COMPAR"
 579       include 'COMMON.GEO'
 580       include 'COMMON.VAR'
 581       include 'COMMON.LOCAL'
 582       include 'COMMON.CHAIN'
 583       include 'COMMON.DERIV'
 584       include 'COMMON.INTERACT'
 585       include 'COMMON.ENEPS'
 586       include 'COMMON.IOUNITS'
 587       include 'COMMON.NAMES'
 588       dimension gg(3)
 589       logical scheck
 590       integer icant
 591       external icant
 592 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 593       do i=1,210
 594         do j=1,2
 595           eneps_temp(j,i)=0.0d0
 596         enddo
 597       enddo
 598       evdw=0.0D0
 599       evdw_t=0.0d0
 600       do i=iatsc_s,iatsc_e
 601         itypi=itype(i)
 602         itypi1=itype(i+1)
 603         xi=c(1,nres+i)
 604         yi=c(2,nres+i)
 605         zi=c(3,nres+i)
 606 C
 607 C Calculate SC interaction energy.
 608 C
 609         do iint=1,nint_gr(i)
 610           do j=istart(i,iint),iend(i,iint)
 611             itypj=itype(j)
 612             xj=c(1,nres+j)-xi
 613             yj=c(2,nres+j)-yi
 614             zj=c(3,nres+j)-zi
 615             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 616             fac_augm=rrij**expon
 617             e_augm=augm(itypi,itypj)*fac_augm
 618             r_inv_ij=dsqrt(rrij)
 619             rij=1.0D0/r_inv_ij
 620             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 621             fac=r_shift_inv**expon
 622             e1=fac*fac*aa(itypi,itypj)
 623             e2=fac*bb(itypi,itypj)
 624             evdwij=e_augm+e1+e2
 625             ij=icant(itypi,itypj)
 626             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 627      &        /dabs(eps(itypi,itypj))
 628             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 629 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 630 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 631 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 632 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 633 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 634 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 635 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 636             if (bb(itypi,itypj).gt.0.0d0) then
 637               evdw=evdw+evdwij
 638             else
 639               evdw_t=evdw_t+evdwij
 640             endif
 641             if (calc_grad) then
 642 C
 643 C Calculate the components of the gradient in DC and X
 644 C
 645             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 646             gg(1)=xj*fac
 647             gg(2)=yj*fac
 648             gg(3)=zj*fac
 649             do k=1,3
 650               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 651               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 652             enddo
 653             do k=i,j-1
 654               do l=1,3
 655                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 656               enddo
 657             enddo
 658             endif
 659           enddo      ! j
 660         enddo        ! iint
 661       enddo          ! i
 662       if (calc_grad) then
 663       do i=1,nct
 664         do j=1,3
 665           gvdwc(j,i)=expon*gvdwc(j,i)
 666           gvdwx(j,i)=expon*gvdwx(j,i)
 667         enddo
 668       enddo
 669       endif
 670       return
 671       end
 672 C-----------------------------------------------------------------------------
 673       subroutine ebp(evdw,evdw_t)
 674 C
 675 C This subroutine calculates the interaction energy of nonbonded side chains
 676 C assuming the Berne-Pechukas potential of interaction.
 677 C
 678       implicit real*8 (a-h,o-z)
 679       include 'DIMENSIONS'
 680       include 'DIMENSIONS.ZSCOPT'
 681       include "DIMENSIONS.COMPAR"
 682       include 'COMMON.GEO'
 683       include 'COMMON.VAR'
 684       include 'COMMON.LOCAL'
 685       include 'COMMON.CHAIN'
 686       include 'COMMON.DERIV'
 687       include 'COMMON.NAMES'
 688       include 'COMMON.INTERACT'
 689       include 'COMMON.ENEPS'
 690       include 'COMMON.IOUNITS'
 691       include 'COMMON.CALC'
 692       common /srutu/ icall
 693 c     double precision rrsave(maxdim)
 694       logical lprn
 695       integer icant
 696       external icant
 697       do i=1,210
 698         do j=1,2
 699           eneps_temp(j,i)=0.0d0
 700         enddo
 701       enddo
 702       evdw=0.0D0
 703       evdw_t=0.0d0
 704 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 705 c     if (icall.eq.0) then
 706 c       lprn=.true.
 707 c     else
 708         lprn=.false.
 709 c     endif
 710       ind=0
 711       do i=iatsc_s,iatsc_e
 712         itypi=itype(i)
 713         itypi1=itype(i+1)
 714         xi=c(1,nres+i)
 715         yi=c(2,nres+i)
 716         zi=c(3,nres+i)
 717         dxi=dc_norm(1,nres+i)
 718         dyi=dc_norm(2,nres+i)
 719         dzi=dc_norm(3,nres+i)
 720         dsci_inv=vbld_inv(i+nres)
 721 C
 722 C Calculate SC interaction energy.
 723 C
 724         do iint=1,nint_gr(i)
 725           do j=istart(i,iint),iend(i,iint)
 726             ind=ind+1
 727             itypj=itype(j)
 728             dscj_inv=vbld_inv(j+nres)
 729             chi1=chi(itypi,itypj)
 730             chi2=chi(itypj,itypi)
 731             chi12=chi1*chi2
 732             chip1=chip(itypi)
 733             chip2=chip(itypj)
 734             chip12=chip1*chip2
 735             alf1=alp(itypi)
 736             alf2=alp(itypj)
 737             alf12=0.5D0*(alf1+alf2)
 738 C For diagnostics only!!!
 739 c           chi1=0.0D0
 740 c           chi2=0.0D0
 741 c           chi12=0.0D0
 742 c           chip1=0.0D0
 743 c           chip2=0.0D0
 744 c           chip12=0.0D0
 745 c           alf1=0.0D0
 746 c           alf2=0.0D0
 747 c           alf12=0.0D0
 748             xj=c(1,nres+j)-xi
 749             yj=c(2,nres+j)-yi
 750             zj=c(3,nres+j)-zi
 751             dxj=dc_norm(1,nres+j)
 752             dyj=dc_norm(2,nres+j)
 753             dzj=dc_norm(3,nres+j)
 754             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 755 cd          if (icall.eq.0) then
 756 cd            rrsave(ind)=rrij
 757 cd          else
 758 cd            rrij=rrsave(ind)
 759 cd          endif
 760             rij=dsqrt(rrij)
 761 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 762             call sc_angular
 763 C Calculate whole angle-dependent part of epsilon and contributions
 764 C to its derivatives
 765             fac=(rrij*sigsq)**expon2
 766             e1=fac*fac*aa(itypi,itypj)
 767             e2=fac*bb(itypi,itypj)
 768             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 769             eps2der=evdwij*eps3rt
 770             eps3der=evdwij*eps2rt
 771             evdwij=evdwij*eps2rt*eps3rt
 772             ij=icant(itypi,itypj)
 773             aux=eps1*eps2rt**2*eps3rt**2
 774             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 775      &        /dabs(eps(itypi,itypj))
 776             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 777             if (bb(itypi,itypj).gt.0.0d0) then
 778               evdw=evdw+evdwij
 779             else
 780               evdw_t=evdw_t+evdwij
 781             endif
 782             if (calc_grad) then
 783             if (lprn) then
 784             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 785             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 786 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 787 cd     &        restyp(itypi),i,restyp(itypj),j,
 788 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 789 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 790 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 791 cd     &        evdwij
 792             endif
 793 C Calculate gradient components.
 794             e1=e1*eps1*eps2rt**2*eps3rt**2
 795             fac=-expon*(e1+evdwij)
 796             sigder=fac/sigsq
 797             fac=rrij*fac
 798 C Calculate radial part of the gradient
 799             gg(1)=xj*fac
 800             gg(2)=yj*fac
 801             gg(3)=zj*fac
 802 C Calculate the angular part of the gradient and sum add the contributions
 803 C to the appropriate components of the Cartesian gradient.
 804             call sc_grad
 805             endif
 806           enddo      ! j
 807         enddo        ! iint
 808       enddo          ! i
 809 c     stop
 810       return
 811       end
 812 C-----------------------------------------------------------------------------
 813       subroutine egb(evdw,evdw_t)
 814 C
 815 C This subroutine calculates the interaction energy of nonbonded side chains
 816 C assuming the Gay-Berne potential of interaction.
 817 C
 818       implicit real*8 (a-h,o-z)
 819       include 'DIMENSIONS'
 820       include 'DIMENSIONS.ZSCOPT'
 821       include "DIMENSIONS.COMPAR"
 822       include 'COMMON.GEO'
 823       include 'COMMON.VAR'
 824       include 'COMMON.LOCAL'
 825       include 'COMMON.CHAIN'
 826       include 'COMMON.DERIV'
 827       include 'COMMON.NAMES'
 828       include 'COMMON.INTERACT'
 829       include 'COMMON.ENEPS'
 830       include 'COMMON.IOUNITS'
 831       include 'COMMON.CALC'
 832       include 'COMMON.SBRIDGE'
 833       logical lprn
 834       common /srutu/icall
 835       integer icant
 836       external icant
 837       do i=1,210
 838         do j=1,2
 839           eneps_temp(j,i)=0.0d0
 840         enddo
 841       enddo
 842 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 843       evdw=0.0D0
 844       evdw_t=0.0d0
 845       lprn=.false.
 846 c      if (icall.gt.0) lprn=.true.
 847       ind=0
 848       do i=iatsc_s,iatsc_e
 849         itypi=itype(i)
 850         itypi1=itype(i+1)
 851         xi=c(1,nres+i)
 852         yi=c(2,nres+i)
 853         zi=c(3,nres+i)
 854         dxi=dc_norm(1,nres+i)
 855         dyi=dc_norm(2,nres+i)
 856         dzi=dc_norm(3,nres+i)
 857         dsci_inv=vbld_inv(i+nres)
 858 C
 859 C Calculate SC interaction energy.
 860 C
 861         do iint=1,nint_gr(i)
 862           do j=istart(i,iint),iend(i,iint)
 863 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 864 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 865 C formation no electrostatic interactions should be calculated. If it
 866 C would be allowed NaN would appear
 867             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 868 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 869 C residue can or cannot form disulfide bond. There is still bug allowing
 870 C Cys...Cys...Cys bond formation
 871               call dyn_ssbond_ene(i,j,evdwij)
 872 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 873 C function in ssMD.F
 874               evdw=evdw+evdwij
 875 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 876 c     &                        'evdw',i,j,evdwij,' ss'
 877             ELSE
 878             ind=ind+1
 879             itypj=itype(j)
 880             dscj_inv=vbld_inv(j+nres)
 881             sig0ij=sigma(itypi,itypj)
 882             chi1=chi(itypi,itypj)
 883             chi2=chi(itypj,itypi)
 884             chi12=chi1*chi2
 885             chip1=chip(itypi)
 886             chip2=chip(itypj)
 887             chip12=chip1*chip2
 888             alf1=alp(itypi)
 889             alf2=alp(itypj)
 890             alf12=0.5D0*(alf1+alf2)
 891 C For diagnostics only!!!
 892 c           chi1=0.0D0
 893 c           chi2=0.0D0
 894 c           chi12=0.0D0
 895 c           chip1=0.0D0
 896 c           chip2=0.0D0
 897 c           chip12=0.0D0
 898 c           alf1=0.0D0
 899 c           alf2=0.0D0
 900 c           alf12=0.0D0
 901             xj=c(1,nres+j)-xi
 902             yj=c(2,nres+j)-yi
 903             zj=c(3,nres+j)-zi
 904             dxj=dc_norm(1,nres+j)
 905             dyj=dc_norm(2,nres+j)
 906             dzj=dc_norm(3,nres+j)
 907 c            write (iout,*) i,j,xj,yj,zj
 908             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 909             rij=dsqrt(rrij)
 910 C Calculate angle-dependent terms of energy and contributions to their
 911 C derivatives.
 912             call sc_angular
 913             sigsq=1.0D0/sigsq
 914             sig=sig0ij*dsqrt(sigsq)
 915             rij_shift=1.0D0/rij-sig+sig0ij
 916 C I hate to put IF's in the loops, but here don't have another choice!!!!
 917             if (rij_shift.le.0.0D0) then
 918               evdw=1.0D20
 919               return
 920             endif
 921             sigder=-sig*sigsq
 922 c---------------------------------------------------------------
 923             rij_shift=1.0D0/rij_shift
 924             fac=rij_shift**expon
 925             e1=fac*fac*aa(itypi,itypj)
 926             e2=fac*bb(itypi,itypj)
 927             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 928             eps2der=evdwij*eps3rt
 929             eps3der=evdwij*eps2rt
 930             evdwij=evdwij*eps2rt*eps3rt
 931             if (bb(itypi,itypj).gt.0) then
 932               evdw=evdw+evdwij
 933             else
 934               evdw_t=evdw_t+evdwij
 935             endif
 936             ij=icant(itypi,itypj)
 937             aux=eps1*eps2rt**2*eps3rt**2
 938             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 939      &        /dabs(eps(itypi,itypj))
 940             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 941 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 942 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 943 c     &         aux*e2/eps(itypi,itypj)
 944 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 945             if (lprn) then
 946             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 947             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 948             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 949      &        restyp(itypi),i,restyp(itypj),j,
 950      &        epsi,sigm,chi1,chi2,chip1,chip2,
 951      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 952      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 953      &        evdwij
 954             endif
 955             if (calc_grad) then
 956 C Calculate gradient components.
 957             e1=e1*eps1*eps2rt**2*eps3rt**2
 958             fac=-expon*(e1+evdwij)*rij_shift
 959             sigder=fac*sigder
 960             fac=rij*fac
 961 C Calculate the radial part of the gradient
 962             gg(1)=xj*fac
 963             gg(2)=yj*fac
 964             gg(3)=zj*fac
 965 C Calculate angular part of the gradient.
 966             call sc_grad
 967             endif
 968             ENDIF    ! dyn_ss
 969           enddo      ! j
 970         enddo        ! iint
 971       enddo          ! i
 972       return
 973       end
 974 C-----------------------------------------------------------------------------
 975       subroutine egbv(evdw,evdw_t)
 976 C
 977 C This subroutine calculates the interaction energy of nonbonded side chains
 978 C assuming the Gay-Berne-Vorobjev potential of interaction.
 979 C
 980       implicit real*8 (a-h,o-z)
 981       include 'DIMENSIONS'
 982       include 'DIMENSIONS.ZSCOPT'
 983       include "DIMENSIONS.COMPAR"
 984       include 'COMMON.GEO'
 985       include 'COMMON.VAR'
 986       include 'COMMON.LOCAL'
 987       include 'COMMON.CHAIN'
 988       include 'COMMON.DERIV'
 989       include 'COMMON.NAMES'
 990       include 'COMMON.INTERACT'
 991       include 'COMMON.ENEPS'
 992       include 'COMMON.IOUNITS'
 993       include 'COMMON.CALC'
 994       common /srutu/ icall
 995       logical lprn
 996       integer icant
 997       external icant
 998       do i=1,210
 999         do j=1,2
1000           eneps_temp(j,i)=0.0d0
1001         enddo
1002       enddo
1003       evdw=0.0D0
1004       evdw_t=0.0d0
1005 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1006       evdw=0.0D0
1007       lprn=.false.
1008 c      if (icall.gt.0) lprn=.true.
1009       ind=0
1010       do i=iatsc_s,iatsc_e
1011         itypi=itype(i)
1012         itypi1=itype(i+1)
1013         xi=c(1,nres+i)
1014         yi=c(2,nres+i)
1015         zi=c(3,nres+i)
1016         dxi=dc_norm(1,nres+i)
1017         dyi=dc_norm(2,nres+i)
1018         dzi=dc_norm(3,nres+i)
1019         dsci_inv=vbld_inv(i+nres)
1020 C
1021 C Calculate SC interaction energy.
1022 C
1023         do iint=1,nint_gr(i)
1024           do j=istart(i,iint),iend(i,iint)
1025             ind=ind+1
1026             itypj=itype(j)
1027             dscj_inv=vbld_inv(j+nres)
1028             sig0ij=sigma(itypi,itypj)
1029             r0ij=r0(itypi,itypj)
1030             chi1=chi(itypi,itypj)
1031             chi2=chi(itypj,itypi)
1032             chi12=chi1*chi2
1033             chip1=chip(itypi)
1034             chip2=chip(itypj)
1035             chip12=chip1*chip2
1036             alf1=alp(itypi)
1037             alf2=alp(itypj)
1038             alf12=0.5D0*(alf1+alf2)
1039 C For diagnostics only!!!
1040 c           chi1=0.0D0
1041 c           chi2=0.0D0
1042 c           chi12=0.0D0
1043 c           chip1=0.0D0
1044 c           chip2=0.0D0
1045 c           chip12=0.0D0
1046 c           alf1=0.0D0
1047 c           alf2=0.0D0
1048 c           alf12=0.0D0
1049             xj=c(1,nres+j)-xi
1050             yj=c(2,nres+j)-yi
1051             zj=c(3,nres+j)-zi
1052             dxj=dc_norm(1,nres+j)
1053             dyj=dc_norm(2,nres+j)
1054             dzj=dc_norm(3,nres+j)
1055             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1056             rij=dsqrt(rrij)
1057 C Calculate angle-dependent terms of energy and contributions to their
1058 C derivatives.
1059             call sc_angular
1060             sigsq=1.0D0/sigsq
1061             sig=sig0ij*dsqrt(sigsq)
1062             rij_shift=1.0D0/rij-sig+r0ij
1063 C I hate to put IF's in the loops, but here don't have another choice!!!!
1064             if (rij_shift.le.0.0D0) then
1065               evdw=1.0D20
1066               return
1067             endif
1068             sigder=-sig*sigsq
1069 c---------------------------------------------------------------
1070             rij_shift=1.0D0/rij_shift
1071             fac=rij_shift**expon
1072             e1=fac*fac*aa(itypi,itypj)
1073             e2=fac*bb(itypi,itypj)
1074             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1075             eps2der=evdwij*eps3rt
1076             eps3der=evdwij*eps2rt
1077             fac_augm=rrij**expon
1078             e_augm=augm(itypi,itypj)*fac_augm
1079             evdwij=evdwij*eps2rt*eps3rt
1080             if (bb(itypi,itypj).gt.0.0d0) then
1081               evdw=evdw+evdwij+e_augm
1082             else
1083               evdw_t=evdw_t+evdwij+e_augm
1084             endif
1085             ij=icant(itypi,itypj)
1086             aux=eps1*eps2rt**2*eps3rt**2
1087             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1088      &        /dabs(eps(itypi,itypj))
1089             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1090 c            eneps_temp(ij)=eneps_temp(ij)
1091 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1092 c            if (lprn) then
1093 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1094 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1095 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1096 c     &        restyp(itypi),i,restyp(itypj),j,
1097 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1098 c     &        chi1,chi2,chip1,chip2,
1099 c     &        eps1,eps2rt**2,eps3rt**2,
1100 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1101 c     &        evdwij+e_augm
1102 c            endif
1103             if (calc_grad) then
1104 C Calculate gradient components.
1105             e1=e1*eps1*eps2rt**2*eps3rt**2
1106             fac=-expon*(e1+evdwij)*rij_shift
1107             sigder=fac*sigder
1108             fac=rij*fac-2*expon*rrij*e_augm
1109 C Calculate the radial part of the gradient
1110             gg(1)=xj*fac
1111             gg(2)=yj*fac
1112             gg(3)=zj*fac
1113 C Calculate angular part of the gradient.
1114             call sc_grad
1115             endif
1116           enddo      ! j
1117         enddo        ! iint
1118       enddo          ! i
1119       return
1120       end
1121 C-----------------------------------------------------------------------------
1122       subroutine sc_angular
1123 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1124 C om12. Called by ebp, egb, and egbv.
1125       implicit none
1126       include 'COMMON.CALC'
1127       erij(1)=xj*rij
1128       erij(2)=yj*rij
1129       erij(3)=zj*rij
1130       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1131       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1132       om12=dxi*dxj+dyi*dyj+dzi*dzj
1133       chiom12=chi12*om12
1134 C Calculate eps1(om12) and its derivative in om12
1135       faceps1=1.0D0-om12*chiom12
1136       faceps1_inv=1.0D0/faceps1
1137       eps1=dsqrt(faceps1_inv)
1138 C Following variable is eps1*deps1/dom12
1139       eps1_om12=faceps1_inv*chiom12
1140 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1141 C and om12.
1142       om1om2=om1*om2
1143       chiom1=chi1*om1
1144       chiom2=chi2*om2
1145       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1146       sigsq=1.0D0-facsig*faceps1_inv
1147       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1148       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1149       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1150 C Calculate eps2 and its derivatives in om1, om2, and om12.
1151       chipom1=chip1*om1
1152       chipom2=chip2*om2
1153       chipom12=chip12*om12
1154       facp=1.0D0-om12*chipom12
1155       facp_inv=1.0D0/facp
1156       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1157 C Following variable is the square root of eps2
1158       eps2rt=1.0D0-facp1*facp_inv
1159 C Following three variables are the derivatives of the square root of eps
1160 C in om1, om2, and om12.
1161       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1162       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1163       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1164 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1165       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1166 C Calculate whole angle-dependent part of epsilon and contributions
1167 C to its derivatives
1168       return
1169       end
1170 C----------------------------------------------------------------------------
1171       subroutine sc_grad
1172       implicit real*8 (a-h,o-z)
1173       include 'DIMENSIONS'
1174       include 'DIMENSIONS.ZSCOPT'
1175       include 'COMMON.CHAIN'
1176       include 'COMMON.DERIV'
1177       include 'COMMON.CALC'
1178       double precision dcosom1(3),dcosom2(3)
1179       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1180       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1181       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1182      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1183       do k=1,3
1184         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1185         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1186       enddo
1187       do k=1,3
1188         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1189       enddo
1190       do k=1,3
1191         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1192      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1193      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1194         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1196      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1197       enddo
1198 C
1199 C Calculate the components of the gradient in DC and X
1200 C
1201       do k=i,j-1
1202         do l=1,3
1203           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1204         enddo
1205       enddo
1206       return
1207       end
1208 c------------------------------------------------------------------------------
1209       subroutine vec_and_deriv
1210       implicit real*8 (a-h,o-z)
1211       include 'DIMENSIONS'
1212       include 'DIMENSIONS.ZSCOPT'
1213       include 'COMMON.IOUNITS'
1214       include 'COMMON.GEO'
1215       include 'COMMON.VAR'
1216       include 'COMMON.LOCAL'
1217       include 'COMMON.CHAIN'
1218       include 'COMMON.VECTORS'
1219       include 'COMMON.DERIV'
1220       include 'COMMON.INTERACT'
1221       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1222 C Compute the local reference systems. For reference system (i), the
1223 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1224 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1225       do i=1,nres-1
1226 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1227           if (i.eq.nres-1) then
1228 C Case of the last full residue
1229 C Compute the Z-axis
1230             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1231             costh=dcos(pi-theta(nres))
1232             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1233             do k=1,3
1234               uz(k,i)=fac*uz(k,i)
1235             enddo
1236             if (calc_grad) then
1237 C Compute the derivatives of uz
1238             uzder(1,1,1)= 0.0d0
1239             uzder(2,1,1)=-dc_norm(3,i-1)
1240             uzder(3,1,1)= dc_norm(2,i-1)
1241             uzder(1,2,1)= dc_norm(3,i-1)
1242             uzder(2,2,1)= 0.0d0
1243             uzder(3,2,1)=-dc_norm(1,i-1)
1244             uzder(1,3,1)=-dc_norm(2,i-1)
1245             uzder(2,3,1)= dc_norm(1,i-1)
1246             uzder(3,3,1)= 0.0d0
1247             uzder(1,1,2)= 0.0d0
1248             uzder(2,1,2)= dc_norm(3,i)
1249             uzder(3,1,2)=-dc_norm(2,i)
1250             uzder(1,2,2)=-dc_norm(3,i)
1251             uzder(2,2,2)= 0.0d0
1252             uzder(3,2,2)= dc_norm(1,i)
1253             uzder(1,3,2)= dc_norm(2,i)
1254             uzder(2,3,2)=-dc_norm(1,i)
1255             uzder(3,3,2)= 0.0d0
1256             endif
1257 C Compute the Y-axis
1258             facy=fac
1259             do k=1,3
1260               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1261             enddo
1262             if (calc_grad) then
1263 C Compute the derivatives of uy
1264             do j=1,3
1265               do k=1,3
1266                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1267      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1268                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1269               enddo
1270               uyder(j,j,1)=uyder(j,j,1)-costh
1271               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1272             enddo
1273             do j=1,2
1274               do k=1,3
1275                 do l=1,3
1276                   uygrad(l,k,j,i)=uyder(l,k,j)
1277                   uzgrad(l,k,j,i)=uzder(l,k,j)
1278                 enddo
1279               enddo
1280             enddo
1281             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1282             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1283             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1284             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1285             endif
1286           else
1287 C Other residues
1288 C Compute the Z-axis
1289             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1290             costh=dcos(pi-theta(i+2))
1291             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1292             do k=1,3
1293               uz(k,i)=fac*uz(k,i)
1294             enddo
1295             if (calc_grad) then
1296 C Compute the derivatives of uz
1297             uzder(1,1,1)= 0.0d0
1298             uzder(2,1,1)=-dc_norm(3,i+1)
1299             uzder(3,1,1)= dc_norm(2,i+1)
1300             uzder(1,2,1)= dc_norm(3,i+1)
1301             uzder(2,2,1)= 0.0d0
1302             uzder(3,2,1)=-dc_norm(1,i+1)
1303             uzder(1,3,1)=-dc_norm(2,i+1)
1304             uzder(2,3,1)= dc_norm(1,i+1)
1305             uzder(3,3,1)= 0.0d0
1306             uzder(1,1,2)= 0.0d0
1307             uzder(2,1,2)= dc_norm(3,i)
1308             uzder(3,1,2)=-dc_norm(2,i)
1309             uzder(1,2,2)=-dc_norm(3,i)
1310             uzder(2,2,2)= 0.0d0
1311             uzder(3,2,2)= dc_norm(1,i)
1312             uzder(1,3,2)= dc_norm(2,i)
1313             uzder(2,3,2)=-dc_norm(1,i)
1314             uzder(3,3,2)= 0.0d0
1315             endif
1316 C Compute the Y-axis
1317             facy=fac
1318             do k=1,3
1319               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1320             enddo
1321             if (calc_grad) then
1322 C Compute the derivatives of uy
1323             do j=1,3
1324               do k=1,3
1325                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1326      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1327                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1328               enddo
1329               uyder(j,j,1)=uyder(j,j,1)-costh
1330               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1331             enddo
1332             do j=1,2
1333               do k=1,3
1334                 do l=1,3
1335                   uygrad(l,k,j,i)=uyder(l,k,j)
1336                   uzgrad(l,k,j,i)=uzder(l,k,j)
1337                 enddo
1338               enddo
1339             enddo
1340             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1341             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1342             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1343             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1344           endif
1345           endif
1346       enddo
1347       if (calc_grad) then
1348       do i=1,nres-1
1349         vbld_inv_temp(1)=vbld_inv(i+1)
1350         if (i.lt.nres-1) then
1351           vbld_inv_temp(2)=vbld_inv(i+2)
1352         else
1353           vbld_inv_temp(2)=vbld_inv(i)
1354         endif
1355         do j=1,2
1356           do k=1,3
1357             do l=1,3
1358               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1359               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1360             enddo
1361           enddo
1362         enddo
1363       enddo
1364       endif
1365       return
1366       end
1367 C-----------------------------------------------------------------------------
1368       subroutine vec_and_deriv_test
1369       implicit real*8 (a-h,o-z)
1370       include 'DIMENSIONS'
1371       include 'DIMENSIONS.ZSCOPT'
1372       include 'COMMON.IOUNITS'
1373       include 'COMMON.GEO'
1374       include 'COMMON.VAR'
1375       include 'COMMON.LOCAL'
1376       include 'COMMON.CHAIN'
1377       include 'COMMON.VECTORS'
1378       dimension uyder(3,3,2),uzder(3,3,2)
1379 C Compute the local reference systems. For reference system (i), the
1380 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1381 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1382       do i=1,nres-1
1383           if (i.eq.nres-1) then
1384 C Case of the last full residue
1385 C Compute the Z-axis
1386             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1387             costh=dcos(pi-theta(nres))
1388             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1389 c            write (iout,*) 'fac',fac,
1390 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1391             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1392             do k=1,3
1393               uz(k,i)=fac*uz(k,i)
1394             enddo
1395 C Compute the derivatives of uz
1396             uzder(1,1,1)= 0.0d0
1397             uzder(2,1,1)=-dc_norm(3,i-1)
1398             uzder(3,1,1)= dc_norm(2,i-1)
1399             uzder(1,2,1)= dc_norm(3,i-1)
1400             uzder(2,2,1)= 0.0d0
1401             uzder(3,2,1)=-dc_norm(1,i-1)
1402             uzder(1,3,1)=-dc_norm(2,i-1)
1403             uzder(2,3,1)= dc_norm(1,i-1)
1404             uzder(3,3,1)= 0.0d0
1405             uzder(1,1,2)= 0.0d0
1406             uzder(2,1,2)= dc_norm(3,i)
1407             uzder(3,1,2)=-dc_norm(2,i)
1408             uzder(1,2,2)=-dc_norm(3,i)
1409             uzder(2,2,2)= 0.0d0
1410             uzder(3,2,2)= dc_norm(1,i)
1411             uzder(1,3,2)= dc_norm(2,i)
1412             uzder(2,3,2)=-dc_norm(1,i)
1413             uzder(3,3,2)= 0.0d0
1414 C Compute the Y-axis
1415             do k=1,3
1416               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1417             enddo
1418             facy=fac
1419             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1420      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1421      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1422             do k=1,3
1423 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1424               uy(k,i)=
1425 c     &        facy*(
1426      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1427      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1428 c     &        )
1429             enddo
1430 c            write (iout,*) 'facy',facy,
1431 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1432             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1433             do k=1,3
1434               uy(k,i)=facy*uy(k,i)
1435             enddo
1436 C Compute the derivatives of uy
1437             do j=1,3
1438               do k=1,3
1439                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1440      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1441                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1442               enddo
1443 c              uyder(j,j,1)=uyder(j,j,1)-costh
1444 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1445               uyder(j,j,1)=uyder(j,j,1)
1446      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1447               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1448      &          +uyder(j,j,2)
1449             enddo
1450             do j=1,2
1451               do k=1,3
1452                 do l=1,3
1453                   uygrad(l,k,j,i)=uyder(l,k,j)
1454                   uzgrad(l,k,j,i)=uzder(l,k,j)
1455                 enddo
1456               enddo
1457             enddo
1458             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1459             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1460             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1461             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1462           else
1463 C Other residues
1464 C Compute the Z-axis
1465             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1466             costh=dcos(pi-theta(i+2))
1467             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1468             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1469             do k=1,3
1470               uz(k,i)=fac*uz(k,i)
1471             enddo
1472 C Compute the derivatives of uz
1473             uzder(1,1,1)= 0.0d0
1474             uzder(2,1,1)=-dc_norm(3,i+1)
1475             uzder(3,1,1)= dc_norm(2,i+1)
1476             uzder(1,2,1)= dc_norm(3,i+1)
1477             uzder(2,2,1)= 0.0d0
1478             uzder(3,2,1)=-dc_norm(1,i+1)
1479             uzder(1,3,1)=-dc_norm(2,i+1)
1480             uzder(2,3,1)= dc_norm(1,i+1)
1481             uzder(3,3,1)= 0.0d0
1482             uzder(1,1,2)= 0.0d0
1483             uzder(2,1,2)= dc_norm(3,i)
1484             uzder(3,1,2)=-dc_norm(2,i)
1485             uzder(1,2,2)=-dc_norm(3,i)
1486             uzder(2,2,2)= 0.0d0
1487             uzder(3,2,2)= dc_norm(1,i)
1488             uzder(1,3,2)= dc_norm(2,i)
1489             uzder(2,3,2)=-dc_norm(1,i)
1490             uzder(3,3,2)= 0.0d0
1491 C Compute the Y-axis
1492             facy=fac
1493             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1494      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1495      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1496             do k=1,3
1497 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1498               uy(k,i)=
1499 c     &        facy*(
1500      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1501      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1502 c     &        )
1503             enddo
1504 c            write (iout,*) 'facy',facy,
1505 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1506             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1507             do k=1,3
1508               uy(k,i)=facy*uy(k,i)
1509             enddo
1510 C Compute the derivatives of uy
1511             do j=1,3
1512               do k=1,3
1513                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1514      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1515                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1516               enddo
1517 c              uyder(j,j,1)=uyder(j,j,1)-costh
1518 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1519               uyder(j,j,1)=uyder(j,j,1)
1520      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1521               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1522      &          +uyder(j,j,2)
1523             enddo
1524             do j=1,2
1525               do k=1,3
1526                 do l=1,3
1527                   uygrad(l,k,j,i)=uyder(l,k,j)
1528                   uzgrad(l,k,j,i)=uzder(l,k,j)
1529                 enddo
1530               enddo
1531             enddo
1532             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1533             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1534             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1535             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1536           endif
1537       enddo
1538       do i=1,nres-1
1539         do j=1,2
1540           do k=1,3
1541             do l=1,3
1542               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1543               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1544             enddo
1545           enddo
1546         enddo
1547       enddo
1548       return
1549       end
1550 C-----------------------------------------------------------------------------
1551       subroutine check_vecgrad
1552       implicit real*8 (a-h,o-z)
1553       include 'DIMENSIONS'
1554       include 'DIMENSIONS.ZSCOPT'
1555       include 'COMMON.IOUNITS'
1556       include 'COMMON.GEO'
1557       include 'COMMON.VAR'
1558       include 'COMMON.LOCAL'
1559       include 'COMMON.CHAIN'
1560       include 'COMMON.VECTORS'
1561       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1562       dimension uyt(3,maxres),uzt(3,maxres)
1563       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1564       double precision delta /1.0d-7/
1565       call vec_and_deriv
1566 cd      do i=1,nres
1567 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1568 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1569 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1570 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1571 cd     &     (dc_norm(if90,i),if90=1,3)
1572 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1573 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1574 cd          write(iout,'(a)')
1575 cd      enddo
1576       do i=1,nres
1577         do j=1,2
1578           do k=1,3
1579             do l=1,3
1580               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1581               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1582             enddo
1583           enddo
1584         enddo
1585       enddo
1586       call vec_and_deriv
1587       do i=1,nres
1588         do j=1,3
1589           uyt(j,i)=uy(j,i)
1590           uzt(j,i)=uz(j,i)
1591         enddo
1592       enddo
1593       do i=1,nres
1594 cd        write (iout,*) 'i=',i
1595         do k=1,3
1596           erij(k)=dc_norm(k,i)
1597         enddo
1598         do j=1,3
1599           do k=1,3
1600             dc_norm(k,i)=erij(k)
1601           enddo
1602           dc_norm(j,i)=dc_norm(j,i)+delta
1603 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1604 c          do k=1,3
1605 c            dc_norm(k,i)=dc_norm(k,i)/fac
1606 c          enddo
1607 c          write (iout,*) (dc_norm(k,i),k=1,3)
1608 c          write (iout,*) (erij(k),k=1,3)
1609           call vec_and_deriv
1610           do k=1,3
1611             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1612             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1613             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1614             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1615           enddo
1616 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1617 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1618 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1619         enddo
1620         do k=1,3
1621           dc_norm(k,i)=erij(k)
1622         enddo
1623 cd        do k=1,3
1624 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1625 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1626 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1627 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1628 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1629 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1630 cd          write (iout,'(a)')
1631 cd        enddo
1632       enddo
1633       return
1634       end
1635 C--------------------------------------------------------------------------
1636       subroutine set_matrices
1637       implicit real*8 (a-h,o-z)
1638       include 'DIMENSIONS'
1639       include 'DIMENSIONS.ZSCOPT'
1640       include 'COMMON.IOUNITS'
1641       include 'COMMON.GEO'
1642       include 'COMMON.VAR'
1643       include 'COMMON.LOCAL'
1644       include 'COMMON.CHAIN'
1645       include 'COMMON.DERIV'
1646       include 'COMMON.INTERACT'
1647       include 'COMMON.CONTACTS'
1648       include 'COMMON.TORSION'
1649       include 'COMMON.VECTORS'
1650       include 'COMMON.FFIELD'
1651       double precision auxvec(2),auxmat(2,2)
1652 C
1653 C Compute the virtual-bond-torsional-angle dependent quantities needed
1654 C to calculate the el-loc multibody terms of various order.
1655 C
1656       do i=3,nres+1
1657         if (i .lt. nres+1) then
1658           sin1=dsin(phi(i))
1659           cos1=dcos(phi(i))
1660           sintab(i-2)=sin1
1661           costab(i-2)=cos1
1662           obrot(1,i-2)=cos1
1663           obrot(2,i-2)=sin1
1664           sin2=dsin(2*phi(i))
1665           cos2=dcos(2*phi(i))
1666           sintab2(i-2)=sin2
1667           costab2(i-2)=cos2
1668           obrot2(1,i-2)=cos2
1669           obrot2(2,i-2)=sin2
1670           Ug(1,1,i-2)=-cos1
1671           Ug(1,2,i-2)=-sin1
1672           Ug(2,1,i-2)=-sin1
1673           Ug(2,2,i-2)= cos1
1674           Ug2(1,1,i-2)=-cos2
1675           Ug2(1,2,i-2)=-sin2
1676           Ug2(2,1,i-2)=-sin2
1677           Ug2(2,2,i-2)= cos2
1678         else
1679           costab(i-2)=1.0d0
1680           sintab(i-2)=0.0d0
1681           obrot(1,i-2)=1.0d0
1682           obrot(2,i-2)=0.0d0
1683           obrot2(1,i-2)=0.0d0
1684           obrot2(2,i-2)=0.0d0
1685           Ug(1,1,i-2)=1.0d0
1686           Ug(1,2,i-2)=0.0d0
1687           Ug(2,1,i-2)=0.0d0
1688           Ug(2,2,i-2)=1.0d0
1689           Ug2(1,1,i-2)=0.0d0
1690           Ug2(1,2,i-2)=0.0d0
1691           Ug2(2,1,i-2)=0.0d0
1692           Ug2(2,2,i-2)=0.0d0
1693         endif
1694         if (i .gt. 3 .and. i .lt. nres+1) then
1695           obrot_der(1,i-2)=-sin1
1696           obrot_der(2,i-2)= cos1
1697           Ugder(1,1,i-2)= sin1
1698           Ugder(1,2,i-2)=-cos1
1699           Ugder(2,1,i-2)=-cos1
1700           Ugder(2,2,i-2)=-sin1
1701           dwacos2=cos2+cos2
1702           dwasin2=sin2+sin2
1703           obrot2_der(1,i-2)=-dwasin2
1704           obrot2_der(2,i-2)= dwacos2
1705           Ug2der(1,1,i-2)= dwasin2
1706           Ug2der(1,2,i-2)=-dwacos2
1707           Ug2der(2,1,i-2)=-dwacos2
1708           Ug2der(2,2,i-2)=-dwasin2
1709         else
1710           obrot_der(1,i-2)=0.0d0
1711           obrot_der(2,i-2)=0.0d0
1712           Ugder(1,1,i-2)=0.0d0
1713           Ugder(1,2,i-2)=0.0d0
1714           Ugder(2,1,i-2)=0.0d0
1715           Ugder(2,2,i-2)=0.0d0
1716           obrot2_der(1,i-2)=0.0d0
1717           obrot2_der(2,i-2)=0.0d0
1718           Ug2der(1,1,i-2)=0.0d0
1719           Ug2der(1,2,i-2)=0.0d0
1720           Ug2der(2,1,i-2)=0.0d0
1721           Ug2der(2,2,i-2)=0.0d0
1722         endif
1723         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1724           iti = itortyp(itype(i-2))
1725         else
1726           iti=ntortyp+1
1727         endif
1728         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1729           iti1 = itortyp(itype(i-1))
1730         else
1731           iti1=ntortyp+1
1732         endif
1733 cd        write (iout,*) '*******i',i,' iti1',iti
1734 cd        write (iout,*) 'b1',b1(:,iti)
1735 cd        write (iout,*) 'b2',b2(:,iti)
1736 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1737         if (i .gt. iatel_s+2) then
1738           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1739           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1740           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1741           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1742           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1743           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1744           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1745         else
1746           do k=1,2
1747             Ub2(k,i-2)=0.0d0
1748             Ctobr(k,i-2)=0.0d0
1749             Dtobr2(k,i-2)=0.0d0
1750             do l=1,2
1751               EUg(l,k,i-2)=0.0d0
1752               CUg(l,k,i-2)=0.0d0
1753               DUg(l,k,i-2)=0.0d0
1754               DtUg2(l,k,i-2)=0.0d0
1755             enddo
1756           enddo
1757         endif
1758         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1759         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1760         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1761         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1762         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1763         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1764         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1765         do k=1,2
1766           muder(k,i-2)=Ub2der(k,i-2)
1767         enddo
1768         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1769           iti1 = itortyp(itype(i-1))
1770         else
1771           iti1=ntortyp+1
1772         endif
1773         do k=1,2
1774           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1775         enddo
1776 C Vectors and matrices dependent on a single virtual-bond dihedral.
1777         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1778         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1779         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1780         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1781         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1782         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1783         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1784         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1785         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1786 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1787 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1788       enddo
1789 C Matrices dependent on two consecutive virtual-bond dihedrals.
1790 C The order of matrices is from left to right.
1791       do i=2,nres-1
1792         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1793         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1794         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1795         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1796         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1797         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1798         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1799         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1800       enddo
1801 cd      do i=1,nres
1802 cd        iti = itortyp(itype(i))
1803 cd        write (iout,*) i
1804 cd        do j=1,2
1805 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1806 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1807 cd        enddo
1808 cd      enddo
1809       return
1810       end
1811 C--------------------------------------------------------------------------
1812       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1813 C
1814 C This subroutine calculates the average interaction energy and its gradient
1815 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1816 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1817 C The potential depends both on the distance of peptide-group centers and on
1818 C the orientation of the CA-CA virtual bonds.
1819 C
1820       implicit real*8 (a-h,o-z)
1821       include 'DIMENSIONS'
1822       include 'DIMENSIONS.ZSCOPT'
1823       include 'COMMON.CONTROL'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.GEO'
1826       include 'COMMON.VAR'
1827       include 'COMMON.LOCAL'
1828       include 'COMMON.CHAIN'
1829       include 'COMMON.DERIV'
1830       include 'COMMON.INTERACT'
1831       include 'COMMON.CONTACTS'
1832       include 'COMMON.TORSION'
1833       include 'COMMON.VECTORS'
1834       include 'COMMON.FFIELD'
1835       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1836      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1837       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1838      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1839       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1840 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1841       double precision scal_el /0.5d0/
1842 C 12/13/98
1843 C 13-go grudnia roku pamietnego...
1844       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1845      &                   0.0d0,1.0d0,0.0d0,
1846      &                   0.0d0,0.0d0,1.0d0/
1847 cd      write(iout,*) 'In EELEC'
1848 cd      do i=1,nloctyp
1849 cd        write(iout,*) 'Type',i
1850 cd        write(iout,*) 'B1',B1(:,i)
1851 cd        write(iout,*) 'B2',B2(:,i)
1852 cd        write(iout,*) 'CC',CC(:,:,i)
1853 cd        write(iout,*) 'DD',DD(:,:,i)
1854 cd        write(iout,*) 'EE',EE(:,:,i)
1855 cd      enddo
1856 cd      call check_vecgrad
1857 cd      stop
1858       if (icheckgrad.eq.1) then
1859         do i=1,nres-1
1860           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1861           do k=1,3
1862             dc_norm(k,i)=dc(k,i)*fac
1863           enddo
1864 c          write (iout,*) 'i',i,' fac',fac
1865         enddo
1866       endif
1867       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1868      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1869      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1870 cd      if (wel_loc.gt.0.0d0) then
1871         if (icheckgrad.eq.1) then
1872         call vec_and_deriv_test
1873         else
1874         call vec_and_deriv
1875         endif
1876         call set_matrices
1877       endif
1878 cd      do i=1,nres-1
1879 cd        write (iout,*) 'i=',i
1880 cd        do k=1,3
1881 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1882 cd        enddo
1883 cd        do k=1,3
1884 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1885 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1886 cd        enddo
1887 cd      enddo
1888       num_conti_hb=0
1889       ees=0.0D0
1890       evdw1=0.0D0
1891       eel_loc=0.0d0
1892       eello_turn3=0.0d0
1893       eello_turn4=0.0d0
1894       ind=0
1895       do i=1,nres
1896         num_cont_hb(i)=0
1897       enddo
1898 cd      print '(a)','Enter EELEC'
1899 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1900       do i=1,nres
1901         gel_loc_loc(i)=0.0d0
1902         gcorr_loc(i)=0.0d0
1903       enddo
1904       do i=iatel_s,iatel_e
1905         if (itel(i).eq.0) goto 1215
1906         dxi=dc(1,i)
1907         dyi=dc(2,i)
1908         dzi=dc(3,i)
1909         dx_normi=dc_norm(1,i)
1910         dy_normi=dc_norm(2,i)
1911         dz_normi=dc_norm(3,i)
1912         xmedi=c(1,i)+0.5d0*dxi
1913         ymedi=c(2,i)+0.5d0*dyi
1914         zmedi=c(3,i)+0.5d0*dzi
1915         num_conti=0
1916 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1917         do j=ielstart(i),ielend(i)
1918           if (itel(j).eq.0) goto 1216
1919           ind=ind+1
1920           iteli=itel(i)
1921           itelj=itel(j)
1922           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1923           aaa=app(iteli,itelj)
1924           bbb=bpp(iteli,itelj)
1925 C Diagnostics only!!!
1926 c         aaa=0.0D0
1927 c         bbb=0.0D0
1928 c         ael6i=0.0D0
1929 c         ael3i=0.0D0
1930 C End diagnostics
1931           ael6i=ael6(iteli,itelj)
1932           ael3i=ael3(iteli,itelj)
1933           dxj=dc(1,j)
1934           dyj=dc(2,j)
1935           dzj=dc(3,j)
1936           dx_normj=dc_norm(1,j)
1937           dy_normj=dc_norm(2,j)
1938           dz_normj=dc_norm(3,j)
1939           xj=c(1,j)+0.5D0*dxj-xmedi
1940           yj=c(2,j)+0.5D0*dyj-ymedi
1941           zj=c(3,j)+0.5D0*dzj-zmedi
1942           rij=xj*xj+yj*yj+zj*zj
1943           rrmij=1.0D0/rij
1944           rij=dsqrt(rij)
1945           rmij=1.0D0/rij
1946           r3ij=rrmij*rmij
1947           r6ij=r3ij*r3ij
1948           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1949           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1950           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1951           fac=cosa-3.0D0*cosb*cosg
1952           ev1=aaa*r6ij*r6ij
1953 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1954           if (j.eq.i+2) ev1=scal_el*ev1
1955           ev2=bbb*r6ij
1956           fac3=ael6i*r6ij
1957           fac4=ael3i*r3ij
1958           evdwij=ev1+ev2
1959           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1960           el2=fac4*fac
1961           eesij=el1+el2
1962 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1963 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1964           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1965           ees=ees+eesij
1966           evdw1=evdw1+evdwij
1967 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1968 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1969 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1970 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1971 C
1972 C Calculate contributions to the Cartesian gradient.
1973 C
1974 #ifdef SPLITELE
1975           facvdw=-6*rrmij*(ev1+evdwij)
1976           facel=-3*rrmij*(el1+eesij)
1977           fac1=fac
1978           erij(1)=xj*rmij
1979           erij(2)=yj*rmij
1980           erij(3)=zj*rmij
1981           if (calc_grad) then
1982 *
1983 * Radial derivatives. First process both termini of the fragment (i,j)
1984 *
1985           ggg(1)=facel*xj
1986           ggg(2)=facel*yj
1987           ggg(3)=facel*zj
1988           do k=1,3
1989             ghalf=0.5D0*ggg(k)
1990             gelc(k,i)=gelc(k,i)+ghalf
1991             gelc(k,j)=gelc(k,j)+ghalf
1992           enddo
1993 *
1994 * Loop over residues i+1 thru j-1.
1995 *
1996           do k=i+1,j-1
1997             do l=1,3
1998               gelc(l,k)=gelc(l,k)+ggg(l)
1999             enddo
2000           enddo
2001           ggg(1)=facvdw*xj
2002           ggg(2)=facvdw*yj
2003           ggg(3)=facvdw*zj
2004           do k=1,3
2005             ghalf=0.5D0*ggg(k)
2006             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2007             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2008           enddo
2009 *
2010 * Loop over residues i+1 thru j-1.
2011 *
2012           do k=i+1,j-1
2013             do l=1,3
2014               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2015             enddo
2016           enddo
2017 #else
2018           facvdw=ev1+evdwij
2019           facel=el1+eesij
2020           fac1=fac
2021           fac=-3*rrmij*(facvdw+facvdw+facel)
2022           erij(1)=xj*rmij
2023           erij(2)=yj*rmij
2024           erij(3)=zj*rmij
2025           if (calc_grad) then
2026 *
2027 * Radial derivatives. First process both termini of the fragment (i,j)
2028 *
2029           ggg(1)=fac*xj
2030           ggg(2)=fac*yj
2031           ggg(3)=fac*zj
2032           do k=1,3
2033             ghalf=0.5D0*ggg(k)
2034             gelc(k,i)=gelc(k,i)+ghalf
2035             gelc(k,j)=gelc(k,j)+ghalf
2036           enddo
2037 *
2038 * Loop over residues i+1 thru j-1.
2039 *
2040           do k=i+1,j-1
2041             do l=1,3
2042               gelc(l,k)=gelc(l,k)+ggg(l)
2043             enddo
2044           enddo
2045 #endif
2046 *
2047 * Angular part
2048 *
2049           ecosa=2.0D0*fac3*fac1+fac4
2050           fac4=-3.0D0*fac4
2051           fac3=-6.0D0*fac3
2052           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2053           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2054           do k=1,3
2055             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2056             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2057           enddo
2058 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2059 cd   &          (dcosg(k),k=1,3)
2060           do k=1,3
2061             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2062           enddo
2063           do k=1,3
2064             ghalf=0.5D0*ggg(k)
2065             gelc(k,i)=gelc(k,i)+ghalf
2066      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2067      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2068             gelc(k,j)=gelc(k,j)+ghalf
2069      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2070      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2071           enddo
2072           do k=i+1,j-1
2073             do l=1,3
2074               gelc(l,k)=gelc(l,k)+ggg(l)
2075             enddo
2076           enddo
2077           endif
2078
2079           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2080      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2081      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2082 C
2083 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2084 C   energy of a peptide unit is assumed in the form of a second-order
2085 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2086 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2087 C   are computed for EVERY pair of non-contiguous peptide groups.
2088 C
2089           if (j.lt.nres-1) then
2090             j1=j+1
2091             j2=j-1
2092           else
2093             j1=j-1
2094             j2=j-2
2095           endif
2096           kkk=0
2097           do k=1,2
2098             do l=1,2
2099               kkk=kkk+1
2100               muij(kkk)=mu(k,i)*mu(l,j)
2101             enddo
2102           enddo
2103 cd         write (iout,*) 'EELEC: i',i,' j',j
2104 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2105 cd          write(iout,*) 'muij',muij
2106           ury=scalar(uy(1,i),erij)
2107           urz=scalar(uz(1,i),erij)
2108           vry=scalar(uy(1,j),erij)
2109           vrz=scalar(uz(1,j),erij)
2110           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2111           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2112           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2113           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2114 C For diagnostics only
2115 cd          a22=1.0d0
2116 cd          a23=1.0d0
2117 cd          a32=1.0d0
2118 cd          a33=1.0d0
2119           fac=dsqrt(-ael6i)*r3ij
2120 cd          write (2,*) 'fac=',fac
2121 C For diagnostics only
2122 cd          fac=1.0d0
2123           a22=a22*fac
2124           a23=a23*fac
2125           a32=a32*fac
2126           a33=a33*fac
2127 cd          write (iout,'(4i5,4f10.5)')
2128 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2129 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2130 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2131 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2132 cd          write (iout,'(4f10.5)')
2133 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2134 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2135 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2136 cd           write (iout,'(2i3,9f10.5/)') i,j,
2137 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2138           if (calc_grad) then
2139 C Derivatives of the elements of A in virtual-bond vectors
2140           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2141 cd          do k=1,3
2142 cd            do l=1,3
2143 cd              erder(k,l)=0.0d0
2144 cd            enddo
2145 cd          enddo
2146           do k=1,3
2147             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2148             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2149             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2150             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2151             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2152             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2153             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2154             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2155             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2156             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2157             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2158             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2159           enddo
2160 cd          do k=1,3
2161 cd            do l=1,3
2162 cd              uryg(k,l)=0.0d0
2163 cd              urzg(k,l)=0.0d0
2164 cd              vryg(k,l)=0.0d0
2165 cd              vrzg(k,l)=0.0d0
2166 cd            enddo
2167 cd          enddo
2168 C Compute radial contributions to the gradient
2169           facr=-3.0d0*rrmij
2170           a22der=a22*facr
2171           a23der=a23*facr
2172           a32der=a32*facr
2173           a33der=a33*facr
2174 cd          a22der=0.0d0
2175 cd          a23der=0.0d0
2176 cd          a32der=0.0d0
2177 cd          a33der=0.0d0
2178           agg(1,1)=a22der*xj
2179           agg(2,1)=a22der*yj
2180           agg(3,1)=a22der*zj
2181           agg(1,2)=a23der*xj
2182           agg(2,2)=a23der*yj
2183           agg(3,2)=a23der*zj
2184           agg(1,3)=a32der*xj
2185           agg(2,3)=a32der*yj
2186           agg(3,3)=a32der*zj
2187           agg(1,4)=a33der*xj
2188           agg(2,4)=a33der*yj
2189           agg(3,4)=a33der*zj
2190 C Add the contributions coming from er
2191           fac3=-3.0d0*fac
2192           do k=1,3
2193             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2194             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2195             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2196             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2197           enddo
2198           do k=1,3
2199 C Derivatives in DC(i)
2200             ghalf1=0.5d0*agg(k,1)
2201             ghalf2=0.5d0*agg(k,2)
2202             ghalf3=0.5d0*agg(k,3)
2203             ghalf4=0.5d0*agg(k,4)
2204             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2205      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2206             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2207      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2208             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2209      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2210             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2211      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2212 C Derivatives in DC(i+1)
2213             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2214      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2215             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2216      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2217             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2218      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2219             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2220      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2221 C Derivatives in DC(j)
2222             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2223      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2224             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2225      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2226             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2227      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2228             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2229      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2230 C Derivatives in DC(j+1) or DC(nres-1)
2231             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2232      &      -3.0d0*vryg(k,3)*ury)
2233             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2234      &      -3.0d0*vrzg(k,3)*ury)
2235             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2236      &      -3.0d0*vryg(k,3)*urz)
2237             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2238      &      -3.0d0*vrzg(k,3)*urz)
2239 cd            aggi(k,1)=ghalf1
2240 cd            aggi(k,2)=ghalf2
2241 cd            aggi(k,3)=ghalf3
2242 cd            aggi(k,4)=ghalf4
2243 C Derivatives in DC(i+1)
2244 cd            aggi1(k,1)=agg(k,1)
2245 cd            aggi1(k,2)=agg(k,2)
2246 cd            aggi1(k,3)=agg(k,3)
2247 cd            aggi1(k,4)=agg(k,4)
2248 C Derivatives in DC(j)
2249 cd            aggj(k,1)=ghalf1
2250 cd            aggj(k,2)=ghalf2
2251 cd            aggj(k,3)=ghalf3
2252 cd            aggj(k,4)=ghalf4
2253 C Derivatives in DC(j+1)
2254 cd            aggj1(k,1)=0.0d0
2255 cd            aggj1(k,2)=0.0d0
2256 cd            aggj1(k,3)=0.0d0
2257 cd            aggj1(k,4)=0.0d0
2258             if (j.eq.nres-1 .and. i.lt.j-2) then
2259               do l=1,4
2260                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2261 cd                aggj1(k,l)=agg(k,l)
2262               enddo
2263             endif
2264           enddo
2265           endif
2266 c          goto 11111
2267 C Check the loc-el terms by numerical integration
2268           acipa(1,1)=a22
2269           acipa(1,2)=a23
2270           acipa(2,1)=a32
2271           acipa(2,2)=a33
2272           a22=-a22
2273           a23=-a23
2274           do l=1,2
2275             do k=1,3
2276               agg(k,l)=-agg(k,l)
2277               aggi(k,l)=-aggi(k,l)
2278               aggi1(k,l)=-aggi1(k,l)
2279               aggj(k,l)=-aggj(k,l)
2280               aggj1(k,l)=-aggj1(k,l)
2281             enddo
2282           enddo
2283           if (j.lt.nres-1) then
2284             a22=-a22
2285             a32=-a32
2286             do l=1,3,2
2287               do k=1,3
2288                 agg(k,l)=-agg(k,l)
2289                 aggi(k,l)=-aggi(k,l)
2290                 aggi1(k,l)=-aggi1(k,l)
2291                 aggj(k,l)=-aggj(k,l)
2292                 aggj1(k,l)=-aggj1(k,l)
2293               enddo
2294             enddo
2295           else
2296             a22=-a22
2297             a23=-a23
2298             a32=-a32
2299             a33=-a33
2300             do l=1,4
2301               do k=1,3
2302                 agg(k,l)=-agg(k,l)
2303                 aggi(k,l)=-aggi(k,l)
2304                 aggi1(k,l)=-aggi1(k,l)
2305                 aggj(k,l)=-aggj(k,l)
2306                 aggj1(k,l)=-aggj1(k,l)
2307               enddo
2308             enddo
2309           endif
2310           ENDIF ! WCORR
2311 11111     continue
2312           IF (wel_loc.gt.0.0d0) THEN
2313 C Contribution to the local-electrostatic energy coming from the i-j pair
2314           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2315      &     +a33*muij(4)
2316 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2317 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2318           eel_loc=eel_loc+eel_loc_ij
2319 C Partial derivatives in virtual-bond dihedral angles gamma
2320           if (calc_grad) then
2321           if (i.gt.1)
2322      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2323      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2324      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2325           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2326      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2327      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2328 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2329 cd          write(iout,*) 'agg  ',agg
2330 cd          write(iout,*) 'aggi ',aggi
2331 cd          write(iout,*) 'aggi1',aggi1
2332 cd          write(iout,*) 'aggj ',aggj
2333 cd          write(iout,*) 'aggj1',aggj1
2334
2335 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2336           do l=1,3
2337             ggg(l)=agg(l,1)*muij(1)+
2338      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2339           enddo
2340           do k=i+2,j2
2341             do l=1,3
2342               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2343             enddo
2344           enddo
2345 C Remaining derivatives of eello
2346           do l=1,3
2347             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2348      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2349             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2350      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2351             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2352      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2353             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2354      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2355           enddo
2356           endif
2357           ENDIF
2358           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2359 C Contributions from turns
2360             a_temp(1,1)=a22
2361             a_temp(1,2)=a23
2362             a_temp(2,1)=a32
2363             a_temp(2,2)=a33
2364             call eturn34(i,j,eello_turn3,eello_turn4)
2365           endif
2366 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2367           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2368 C
2369 C Calculate the contact function. The ith column of the array JCONT will
2370 C contain the numbers of atoms that make contacts with the atom I (of numbers
2371 C greater than I). The arrays FACONT and GACONT will contain the values of
2372 C the contact function and its derivative.
2373 c           r0ij=1.02D0*rpp(iteli,itelj)
2374 c           r0ij=1.11D0*rpp(iteli,itelj)
2375             r0ij=2.20D0*rpp(iteli,itelj)
2376 c           r0ij=1.55D0*rpp(iteli,itelj)
2377             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2378             if (fcont.gt.0.0D0) then
2379               num_conti=num_conti+1
2380               if (num_conti.gt.maxconts) then
2381                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2382      &                         ' will skip next contacts for this conf.'
2383               else
2384                 jcont_hb(num_conti,i)=j
2385                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2386      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2387 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2388 C  terms.
2389                 d_cont(num_conti,i)=rij
2390 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2391 C     --- Electrostatic-interaction matrix ---
2392                 a_chuj(1,1,num_conti,i)=a22
2393                 a_chuj(1,2,num_conti,i)=a23
2394                 a_chuj(2,1,num_conti,i)=a32
2395                 a_chuj(2,2,num_conti,i)=a33
2396 C     --- Gradient of rij
2397                 do kkk=1,3
2398                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2399                 enddo
2400 c             if (i.eq.1) then
2401 c                a_chuj(1,1,num_conti,i)=-0.61d0
2402 c                a_chuj(1,2,num_conti,i)= 0.4d0
2403 c                a_chuj(2,1,num_conti,i)= 0.65d0
2404 c                a_chuj(2,2,num_conti,i)= 0.50d0
2405 c             else if (i.eq.2) then
2406 c                a_chuj(1,1,num_conti,i)= 0.0d0
2407 c                a_chuj(1,2,num_conti,i)= 0.0d0
2408 c                a_chuj(2,1,num_conti,i)= 0.0d0
2409 c                a_chuj(2,2,num_conti,i)= 0.0d0
2410 c             endif
2411 C     --- and its gradients
2412 cd                write (iout,*) 'i',i,' j',j
2413 cd                do kkk=1,3
2414 cd                write (iout,*) 'iii 1 kkk',kkk
2415 cd                write (iout,*) agg(kkk,:)
2416 cd                enddo
2417 cd                do kkk=1,3
2418 cd                write (iout,*) 'iii 2 kkk',kkk
2419 cd                write (iout,*) aggi(kkk,:)
2420 cd                enddo
2421 cd                do kkk=1,3
2422 cd                write (iout,*) 'iii 3 kkk',kkk
2423 cd                write (iout,*) aggi1(kkk,:)
2424 cd                enddo
2425 cd                do kkk=1,3
2426 cd                write (iout,*) 'iii 4 kkk',kkk
2427 cd                write (iout,*) aggj(kkk,:)
2428 cd                enddo
2429 cd                do kkk=1,3
2430 cd                write (iout,*) 'iii 5 kkk',kkk
2431 cd                write (iout,*) aggj1(kkk,:)
2432 cd                enddo
2433                 kkll=0
2434                 do k=1,2
2435                   do l=1,2
2436                     kkll=kkll+1
2437                     do m=1,3
2438                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2439                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2440                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2441                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2442                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2443 c                      do mm=1,5
2444 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2445 c                      enddo
2446                     enddo
2447                   enddo
2448                 enddo
2449                 ENDIF
2450                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2451 C Calculate contact energies
2452                 cosa4=4.0D0*cosa
2453                 wij=cosa-3.0D0*cosb*cosg
2454                 cosbg1=cosb+cosg
2455                 cosbg2=cosb-cosg
2456 c               fac3=dsqrt(-ael6i)/r0ij**3
2457                 fac3=dsqrt(-ael6i)*r3ij
2458                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2459                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2460 c               ees0mij=0.0D0
2461                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2462                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2463 C Diagnostics. Comment out or remove after debugging!
2464 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2465 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2466 c               ees0m(num_conti,i)=0.0D0
2467 C End diagnostics.
2468 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2469 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2470                 facont_hb(num_conti,i)=fcont
2471                 if (calc_grad) then
2472 C Angular derivatives of the contact function
2473                 ees0pij1=fac3/ees0pij
2474                 ees0mij1=fac3/ees0mij
2475                 fac3p=-3.0D0*fac3*rrmij
2476                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2477                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2478 c               ees0mij1=0.0D0
2479                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2480                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2481                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2482                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2483                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2484                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2485                 ecosap=ecosa1+ecosa2
2486                 ecosbp=ecosb1+ecosb2
2487                 ecosgp=ecosg1+ecosg2
2488                 ecosam=ecosa1-ecosa2
2489                 ecosbm=ecosb1-ecosb2
2490                 ecosgm=ecosg1-ecosg2
2491 C Diagnostics
2492 c               ecosap=ecosa1
2493 c               ecosbp=ecosb1
2494 c               ecosgp=ecosg1
2495 c               ecosam=0.0D0
2496 c               ecosbm=0.0D0
2497 c               ecosgm=0.0D0
2498 C End diagnostics
2499                 fprimcont=fprimcont/rij
2500 cd              facont_hb(num_conti,i)=1.0D0
2501 C Following line is for diagnostics.
2502 cd              fprimcont=0.0D0
2503                 do k=1,3
2504                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2505                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2506                 enddo
2507                 do k=1,3
2508                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2509                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2510                 enddo
2511                 gggp(1)=gggp(1)+ees0pijp*xj
2512                 gggp(2)=gggp(2)+ees0pijp*yj
2513                 gggp(3)=gggp(3)+ees0pijp*zj
2514                 gggm(1)=gggm(1)+ees0mijp*xj
2515                 gggm(2)=gggm(2)+ees0mijp*yj
2516                 gggm(3)=gggm(3)+ees0mijp*zj
2517 C Derivatives due to the contact function
2518                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2519                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2520                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2521                 do k=1,3
2522                   ghalfp=0.5D0*gggp(k)
2523                   ghalfm=0.5D0*gggm(k)
2524                   gacontp_hb1(k,num_conti,i)=ghalfp
2525      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2526      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2527                   gacontp_hb2(k,num_conti,i)=ghalfp
2528      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2529      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2530                   gacontp_hb3(k,num_conti,i)=gggp(k)
2531                   gacontm_hb1(k,num_conti,i)=ghalfm
2532      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2533      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2534                   gacontm_hb2(k,num_conti,i)=ghalfm
2535      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2536      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2537                   gacontm_hb3(k,num_conti,i)=gggm(k)
2538                 enddo
2539                 endif
2540 C Diagnostics. Comment out or remove after debugging!
2541 cdiag           do k=1,3
2542 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2543 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2544 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2545 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2546 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2547 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2548 cdiag           enddo
2549               ENDIF ! wcorr
2550               endif  ! num_conti.le.maxconts
2551             endif  ! fcont.gt.0
2552           endif    ! j.gt.i+1
2553  1216     continue
2554         enddo ! j
2555         num_cont_hb(i)=num_conti
2556  1215   continue
2557       enddo   ! i
2558 cd      do i=1,nres
2559 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2560 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2561 cd      enddo
2562 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2563 ccc      eel_loc=eel_loc+eello_turn3
2564       return
2565       end
2566 C-----------------------------------------------------------------------------
2567       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2568 C Third- and fourth-order contributions from turns
2569       implicit real*8 (a-h,o-z)
2570       include 'DIMENSIONS'
2571       include 'DIMENSIONS.ZSCOPT'
2572       include 'COMMON.IOUNITS'
2573       include 'COMMON.GEO'
2574       include 'COMMON.VAR'
2575       include 'COMMON.LOCAL'
2576       include 'COMMON.CHAIN'
2577       include 'COMMON.DERIV'
2578       include 'COMMON.INTERACT'
2579       include 'COMMON.CONTACTS'
2580       include 'COMMON.TORSION'
2581       include 'COMMON.VECTORS'
2582       include 'COMMON.FFIELD'
2583       dimension ggg(3)
2584       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2585      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2586      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2587       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2588      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2589       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2590       if (j.eq.i+2) then
2591 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2592 C
2593 C               Third-order contributions
2594 C
2595 C                 (i+2)o----(i+3)
2596 C                      | |
2597 C                      | |
2598 C                 (i+1)o----i
2599 C
2600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2601 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2602         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2603         call transpose2(auxmat(1,1),auxmat1(1,1))
2604         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2605         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2606 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2607 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2608 cd     &    ' eello_turn3_num',4*eello_turn3_num
2609         if (calc_grad) then
2610 C Derivatives in gamma(i)
2611         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2612         call transpose2(auxmat2(1,1),pizda(1,1))
2613         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2614         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2615 C Derivatives in gamma(i+1)
2616         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2617         call transpose2(auxmat2(1,1),pizda(1,1))
2618         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2619         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2620      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2621 C Cartesian derivatives
2622         do l=1,3
2623           a_temp(1,1)=aggi(l,1)
2624           a_temp(1,2)=aggi(l,2)
2625           a_temp(2,1)=aggi(l,3)
2626           a_temp(2,2)=aggi(l,4)
2627           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2628           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2629      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2630           a_temp(1,1)=aggi1(l,1)
2631           a_temp(1,2)=aggi1(l,2)
2632           a_temp(2,1)=aggi1(l,3)
2633           a_temp(2,2)=aggi1(l,4)
2634           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2635           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2636      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2637           a_temp(1,1)=aggj(l,1)
2638           a_temp(1,2)=aggj(l,2)
2639           a_temp(2,1)=aggj(l,3)
2640           a_temp(2,2)=aggj(l,4)
2641           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2642           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2643      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2644           a_temp(1,1)=aggj1(l,1)
2645           a_temp(1,2)=aggj1(l,2)
2646           a_temp(2,1)=aggj1(l,3)
2647           a_temp(2,2)=aggj1(l,4)
2648           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2649           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2650      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2651         enddo
2652         endif
2653       else if (j.eq.i+3) then
2654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2655 C
2656 C               Fourth-order contributions
2657 C
2658 C                 (i+3)o----(i+4)
2659 C                     /  |
2660 C               (i+2)o   |
2661 C                     \  |
2662 C                 (i+1)o----i
2663 C
2664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2665 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2666         iti1=itortyp(itype(i+1))
2667         iti2=itortyp(itype(i+2))
2668         iti3=itortyp(itype(i+3))
2669         call transpose2(EUg(1,1,i+1),e1t(1,1))
2670         call transpose2(Eug(1,1,i+2),e2t(1,1))
2671         call transpose2(Eug(1,1,i+3),e3t(1,1))
2672         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2673         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2674         s1=scalar2(b1(1,iti2),auxvec(1))
2675         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2676         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2677         s2=scalar2(b1(1,iti1),auxvec(1))
2678         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2679         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2681         eello_turn4=eello_turn4-(s1+s2+s3)
2682 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2683 cd     &    ' eello_turn4_num',8*eello_turn4_num
2684 C Derivatives in gamma(i)
2685         if (calc_grad) then
2686         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2687         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2688         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2689         s1=scalar2(b1(1,iti2),auxvec(1))
2690         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2691         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2692         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2693 C Derivatives in gamma(i+1)
2694         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2695         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2696         s2=scalar2(b1(1,iti1),auxvec(1))
2697         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2698         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2699         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2700         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2701 C Derivatives in gamma(i+2)
2702         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2703         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2704         s1=scalar2(b1(1,iti2),auxvec(1))
2705         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2706         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2707         s2=scalar2(b1(1,iti1),auxvec(1))
2708         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2709         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2710         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2711         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2712 C Cartesian derivatives
2713 C Derivatives of this turn contributions in DC(i+2)
2714         if (j.lt.nres-1) then
2715           do l=1,3
2716             a_temp(1,1)=agg(l,1)
2717             a_temp(1,2)=agg(l,2)
2718             a_temp(2,1)=agg(l,3)
2719             a_temp(2,2)=agg(l,4)
2720             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2721             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2722             s1=scalar2(b1(1,iti2),auxvec(1))
2723             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2724             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2725             s2=scalar2(b1(1,iti1),auxvec(1))
2726             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2727             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2728             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2729             ggg(l)=-(s1+s2+s3)
2730             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2731           enddo
2732         endif
2733 C Remaining derivatives of this turn contribution
2734         do l=1,3
2735           a_temp(1,1)=aggi(l,1)
2736           a_temp(1,2)=aggi(l,2)
2737           a_temp(2,1)=aggi(l,3)
2738           a_temp(2,2)=aggi(l,4)
2739           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2740           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2741           s1=scalar2(b1(1,iti2),auxvec(1))
2742           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2743           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2744           s2=scalar2(b1(1,iti1),auxvec(1))
2745           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2746           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2747           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2748           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2749           a_temp(1,1)=aggi1(l,1)
2750           a_temp(1,2)=aggi1(l,2)
2751           a_temp(2,1)=aggi1(l,3)
2752           a_temp(2,2)=aggi1(l,4)
2753           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2754           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2755           s1=scalar2(b1(1,iti2),auxvec(1))
2756           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2757           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2758           s2=scalar2(b1(1,iti1),auxvec(1))
2759           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2760           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2761           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2762           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2763           a_temp(1,1)=aggj(l,1)
2764           a_temp(1,2)=aggj(l,2)
2765           a_temp(2,1)=aggj(l,3)
2766           a_temp(2,2)=aggj(l,4)
2767           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2768           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2769           s1=scalar2(b1(1,iti2),auxvec(1))
2770           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2771           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2772           s2=scalar2(b1(1,iti1),auxvec(1))
2773           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2774           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2775           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2776           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2777           a_temp(1,1)=aggj1(l,1)
2778           a_temp(1,2)=aggj1(l,2)
2779           a_temp(2,1)=aggj1(l,3)
2780           a_temp(2,2)=aggj1(l,4)
2781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2783           s1=scalar2(b1(1,iti2),auxvec(1))
2784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2786           s2=scalar2(b1(1,iti1),auxvec(1))
2787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2790           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2791         enddo
2792         endif
2793       endif
2794       return
2795       end
2796 C-----------------------------------------------------------------------------
2797       subroutine vecpr(u,v,w)
2798       implicit real*8(a-h,o-z)
2799       dimension u(3),v(3),w(3)
2800       w(1)=u(2)*v(3)-u(3)*v(2)
2801       w(2)=-u(1)*v(3)+u(3)*v(1)
2802       w(3)=u(1)*v(2)-u(2)*v(1)
2803       return
2804       end
2805 C-----------------------------------------------------------------------------
2806       subroutine unormderiv(u,ugrad,unorm,ungrad)
2807 C This subroutine computes the derivatives of a normalized vector u, given
2808 C the derivatives computed without normalization conditions, ugrad. Returns
2809 C ungrad.
2810       implicit none
2811       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2812       double precision vec(3)
2813       double precision scalar
2814       integer i,j
2815 c      write (2,*) 'ugrad',ugrad
2816 c      write (2,*) 'u',u
2817       do i=1,3
2818         vec(i)=scalar(ugrad(1,i),u(1))
2819       enddo
2820 c      write (2,*) 'vec',vec
2821       do i=1,3
2822         do j=1,3
2823           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2824         enddo
2825       enddo
2826 c      write (2,*) 'ungrad',ungrad
2827       return
2828       end
2829 C-----------------------------------------------------------------------------
2830       subroutine escp(evdw2,evdw2_14)
2831 C
2832 C This subroutine calculates the excluded-volume interaction energy between
2833 C peptide-group centers and side chains and its gradient in virtual-bond and
2834 C side-chain vectors.
2835 C
2836       implicit real*8 (a-h,o-z)
2837       include 'DIMENSIONS'
2838       include 'DIMENSIONS.ZSCOPT'
2839       include 'COMMON.GEO'
2840       include 'COMMON.VAR'
2841       include 'COMMON.LOCAL'
2842       include 'COMMON.CHAIN'
2843       include 'COMMON.DERIV'
2844       include 'COMMON.INTERACT'
2845       include 'COMMON.FFIELD'
2846       include 'COMMON.IOUNITS'
2847       dimension ggg(3)
2848       evdw2=0.0D0
2849       evdw2_14=0.0d0
2850 cd    print '(a)','Enter ESCP'
2851 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2852 c     &  ' scal14',scal14
2853       do i=iatscp_s,iatscp_e
2854         iteli=itel(i)
2855 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2856 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2857         if (iteli.eq.0) goto 1225
2858         xi=0.5D0*(c(1,i)+c(1,i+1))
2859         yi=0.5D0*(c(2,i)+c(2,i+1))
2860         zi=0.5D0*(c(3,i)+c(3,i+1))
2861
2862         do iint=1,nscp_gr(i)
2863
2864         do j=iscpstart(i,iint),iscpend(i,iint)
2865           itypj=itype(j)
2866 C Uncomment following three lines for SC-p interactions
2867 c         xj=c(1,nres+j)-xi
2868 c         yj=c(2,nres+j)-yi
2869 c         zj=c(3,nres+j)-zi
2870 C Uncomment following three lines for Ca-p interactions
2871           xj=c(1,j)-xi
2872           yj=c(2,j)-yi
2873           zj=c(3,j)-zi
2874           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2875           fac=rrij**expon2
2876           e1=fac*fac*aad(itypj,iteli)
2877           e2=fac*bad(itypj,iteli)
2878           if (iabs(j-i) .le. 2) then
2879             e1=scal14*e1
2880             e2=scal14*e2
2881             evdw2_14=evdw2_14+e1+e2
2882           endif
2883           evdwij=e1+e2
2884 c          write (iout,*) i,j,evdwij
2885           evdw2=evdw2+evdwij
2886           if (calc_grad) then
2887 C
2888 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2889 C
2890           fac=-(evdwij+e1)*rrij
2891           ggg(1)=xj*fac
2892           ggg(2)=yj*fac
2893           ggg(3)=zj*fac
2894           if (j.lt.i) then
2895 cd          write (iout,*) 'j<i'
2896 C Uncomment following three lines for SC-p interactions
2897 c           do k=1,3
2898 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2899 c           enddo
2900           else
2901 cd          write (iout,*) 'j>i'
2902             do k=1,3
2903               ggg(k)=-ggg(k)
2904 C Uncomment following line for SC-p interactions
2905 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2906             enddo
2907           endif
2908           do k=1,3
2909             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2910           enddo
2911           kstart=min0(i+1,j)
2912           kend=max0(i-1,j-1)
2913 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2914 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2915           do k=kstart,kend
2916             do l=1,3
2917               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2918             enddo
2919           enddo
2920           endif
2921         enddo
2922         enddo ! iint
2923  1225   continue
2924       enddo ! i
2925       do i=1,nct
2926         do j=1,3
2927           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2928           gradx_scp(j,i)=expon*gradx_scp(j,i)
2929         enddo
2930       enddo
2931 C******************************************************************************
2932 C
2933 C                              N O T E !!!
2934 C
2935 C To save time the factor EXPON has been extracted from ALL components
2936 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2937 C use!
2938 C
2939 C******************************************************************************
2940       return
2941       end
2942 C--------------------------------------------------------------------------
2943       subroutine edis(ehpb)
2944 C
2945 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2946 C
2947       implicit real*8 (a-h,o-z)
2948       include 'DIMENSIONS'
2949       include 'COMMON.SBRIDGE'
2950       include 'COMMON.CHAIN'
2951       include 'COMMON.DERIV'
2952       include 'COMMON.VAR'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.IOUNITS'
2955       dimension ggg(3)
2956       ehpb=0.0D0
2957 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2958 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2959       if (link_end.eq.0) return
2960       do i=link_start,link_end
2961 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2962 C CA-CA distance used in regularization of structure.
2963         ii=ihpb(i)
2964         jj=jhpb(i)
2965 C iii and jjj point to the residues for which the distance is assigned.
2966         if (ii.gt.nres) then
2967           iii=ii-nres
2968           jjj=jj-nres
2969         else
2970           iii=ii
2971           jjj=jj
2972         endif
2973 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2974 c     &    dhpb(i),dhpb1(i),forcon(i)
2975 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2976 C    distance and angle dependent SS bond potential.
2977         if (.not.dyn_ss .and. i.le.nss) then
2978 C 15/02/13 CC dynamic SSbond - additional check
2979         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2980           call ssbond_ene(iii,jjj,eij)
2981           ehpb=ehpb+2*eij
2982          endif
2983 cd          write (iout,*) "eij",eij
2984         else if (ii.gt.nres .and. jj.gt.nres) then
2985 c Restraints from contact prediction
2986           dd=dist(ii,jj)
2987           if (dhpb1(i).gt.0.0d0) then
2988             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2989             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2990 c            write (iout,*) "beta nmr",
2991 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2992           else
2993             dd=dist(ii,jj)
2994             rdis=dd-dhpb(i)
2995 C Get the force constant corresponding to this distance.
2996             waga=forcon(i)
2997 C Calculate the contribution to energy.
2998             ehpb=ehpb+waga*rdis*rdis
2999 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3000 C
3001 C Evaluate gradient.
3002 C
3003             fac=waga*rdis/dd
3004           endif
3005           do j=1,3
3006             ggg(j)=fac*(c(j,jj)-c(j,ii))
3007           enddo
3008           do j=1,3
3009             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3010             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3011           enddo
3012           do k=1,3
3013             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3014             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3015           enddo
3016         else
3017 C Calculate the distance between the two points and its difference from the
3018 C target distance.
3019           dd=dist(ii,jj)
3020           if (dhpb1(i).gt.0.0d0) then
3021             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3022             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3023 c            write (iout,*) "alph nmr",
3024 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3025           else
3026             rdis=dd-dhpb(i)
3027 C Get the force constant corresponding to this distance.
3028             waga=forcon(i)
3029 C Calculate the contribution to energy.
3030             ehpb=ehpb+waga*rdis*rdis
3031 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3032 C
3033 C Evaluate gradient.
3034 C
3035             fac=waga*rdis/dd
3036           endif
3037 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3038 cd   &   ' waga=',waga,' fac=',fac
3039             do j=1,3
3040               ggg(j)=fac*(c(j,jj)-c(j,ii))
3041             enddo
3042 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3043 C If this is a SC-SC distance, we need to calculate the contributions to the
3044 C Cartesian gradient in the SC vectors (ghpbx).
3045           if (iii.lt.ii) then
3046           do j=1,3
3047             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3048             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3049           enddo
3050           endif
3051           do k=1,3
3052             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3053             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3054           enddo
3055         endif
3056       enddo
3057       ehpb=0.5D0*ehpb
3058       return
3059       end
3060 C--------------------------------------------------------------------------
3061       subroutine ssbond_ene(i,j,eij)
3062 C
3063 C Calculate the distance and angle dependent SS-bond potential energy
3064 C using a free-energy function derived based on RHF/6-31G** ab initio
3065 C calculations of diethyl disulfide.
3066 C
3067 C A. Liwo and U. Kozlowska, 11/24/03
3068 C
3069       implicit real*8 (a-h,o-z)
3070       include 'DIMENSIONS'
3071       include 'DIMENSIONS.ZSCOPT'
3072       include 'COMMON.SBRIDGE'
3073       include 'COMMON.CHAIN'
3074       include 'COMMON.DERIV'
3075       include 'COMMON.LOCAL'
3076       include 'COMMON.INTERACT'
3077       include 'COMMON.VAR'
3078       include 'COMMON.IOUNITS'
3079       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3080       itypi=itype(i)
3081       xi=c(1,nres+i)
3082       yi=c(2,nres+i)
3083       zi=c(3,nres+i)
3084       dxi=dc_norm(1,nres+i)
3085       dyi=dc_norm(2,nres+i)
3086       dzi=dc_norm(3,nres+i)
3087       dsci_inv=dsc_inv(itypi)
3088       itypj=itype(j)
3089       dscj_inv=dsc_inv(itypj)
3090       xj=c(1,nres+j)-xi
3091       yj=c(2,nres+j)-yi
3092       zj=c(3,nres+j)-zi
3093       dxj=dc_norm(1,nres+j)
3094       dyj=dc_norm(2,nres+j)
3095       dzj=dc_norm(3,nres+j)
3096       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3097       rij=dsqrt(rrij)
3098       erij(1)=xj*rij
3099       erij(2)=yj*rij
3100       erij(3)=zj*rij
3101       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3102       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3103       om12=dxi*dxj+dyi*dyj+dzi*dzj
3104       do k=1,3
3105         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3106         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3107       enddo
3108       rij=1.0d0/rij
3109       deltad=rij-d0cm
3110       deltat1=1.0d0-om1
3111       deltat2=1.0d0+om2
3112       deltat12=om2-om1+2.0d0
3113       cosphi=om12-om1*om2
3114       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3115      &  +akct*deltad*deltat12+ebr
3116 c     &  +akct*deltad*deltat12
3117      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3118       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3119      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3120      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3121       ed=2*akcm*deltad+akct*deltat12
3122       pom1=akct*deltad
3123       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3124       eom1=-2*akth*deltat1-pom1-om2*pom2
3125       eom2= 2*akth*deltat2+pom1-om1*pom2
3126       eom12=pom2
3127       do k=1,3
3128         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3129       enddo
3130       do k=1,3
3131         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3132      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3133         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3134      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3135       enddo
3136 C
3137 C Calculate the components of the gradient in DC and X
3138 C
3139       do k=i,j-1
3140         do l=1,3
3141           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3142         enddo
3143       enddo
3144       return
3145       end
3146 C--------------------------------------------------------------------------
3147 c MODELLER restraint function
3148       subroutine e_modeller(ehomology_constr)
3149       implicit real*8 (a-h,o-z)
3150       include 'DIMENSIONS'
3151       include 'DIMENSIONS.ZSCOPT'
3152
3153       integer nnn, i, j, k, ki, irec, l
3154       integer katy, odleglosci, test7
3155       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3156       real*8 distance(max_template),distancek(max_template),
3157      &    min_odl,godl(max_template),dih_diff(max_template)
3158
3159 c
3160 c     FP - 30/10/2014 Temporary specifications for homology restraints
3161 c
3162       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3163      &                 sgtheta
3164       double precision, dimension (maxres) :: guscdiff,usc_diff
3165       double precision, dimension (max_template) ::
3166      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3167      &           theta_diff
3168
3169       include 'COMMON.SBRIDGE'
3170       include 'COMMON.CHAIN'
3171       include 'COMMON.GEO'
3172       include 'COMMON.DERIV'
3173       include 'COMMON.LOCAL'
3174       include 'COMMON.INTERACT'
3175       include 'COMMON.VAR'
3176       include 'COMMON.IOUNITS'
3177       include 'COMMON.CONTROL'
3178       include 'COMMON.HOMRESTR'
3179 c
3180       include 'COMMON.SETUP'
3181       include 'COMMON.NAMES'
3182
3183       do i=1,19
3184         distancek(i)=9999999.9
3185       enddo
3186
3187       odleg=0.0d0
3188
3189 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3190 c function)
3191 C AL 5/2/14 - Introduce list of restraints
3192 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3193 #ifdef DEBUG
3194       write(iout,*) "------- dist restrs start -------"
3195 #endif
3196       do ii = link_start_homo,link_end_homo
3197          i = ires_homo(ii)
3198          j = jres_homo(ii)
3199          dij=dist(i,j)
3200 c        write (iout,*) "dij(",i,j,") =",dij
3201          do k=1,constr_homology
3202            distance(k)=odl(k,ii)-dij
3203 c          write (iout,*) "distance(",k,") =",distance(k)
3204 c
3205 c          For Gaussian-type Urestr
3206 c
3207            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3208 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3209 c          write (iout,*) "distancek(",k,") =",distancek(k)
3210 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3211 c
3212 c          For Lorentzian-type Urestr
3213 c
3214            if (waga_dist.lt.0.0d0) then
3215               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3216               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3217      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3218            endif
3219          enddo
3220
3221          min_odl=minval(distancek)
3222 c        write (iout,* )"min_odl",min_odl
3223 #ifdef DEBUG
3224          write (iout,*) "ij dij",i,j,dij
3225          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3226          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3227          write (iout,* )"min_odl",min_odl
3228 #endif
3229          odleg2=0.0d0
3230          do k=1,constr_homology
3231 c Nie wiem po co to liczycie jeszcze raz!
3232 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3233 c     &              (2*(sigma_odl(i,j,k))**2))
3234            if (waga_dist.ge.0.0d0) then
3235 c
3236 c          For Gaussian-type Urestr
3237 c
3238             godl(k)=dexp(-distancek(k)+min_odl)
3239             odleg2=odleg2+godl(k)
3240 c
3241 c          For Lorentzian-type Urestr
3242 c
3243            else
3244             odleg2=odleg2+distancek(k)
3245            endif
3246
3247 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3248 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3249 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3250 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3251
3252          enddo
3253 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3254 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3255 #ifdef DEBUG
3256          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3257          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3258 #endif
3259            if (waga_dist.ge.0.0d0) then
3260 c
3261 c          For Gaussian-type Urestr
3262 c
3263               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3264 c
3265 c          For Lorentzian-type Urestr
3266 c
3267            else
3268               odleg=odleg+odleg2/constr_homology
3269            endif
3270 c
3271 #ifdef GRAD
3272 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3273 c Gradient
3274 c
3275 c          For Gaussian-type Urestr
3276 c
3277          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3278          sum_sgodl=0.0d0
3279          do k=1,constr_homology
3280 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3281 c     &           *waga_dist)+min_odl
3282 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3283 c
3284          if (waga_dist.ge.0.0d0) then
3285 c          For Gaussian-type Urestr
3286 c
3287            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3288 c
3289 c          For Lorentzian-type Urestr
3290 c
3291          else
3292            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3293      &           sigma_odlir(k,ii)**2)**2)
3294          endif
3295            sum_sgodl=sum_sgodl+sgodl
3296
3297 c            sgodl2=sgodl2+sgodl
3298 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3299 c      write(iout,*) "constr_homology=",constr_homology
3300 c      write(iout,*) i, j, k, "TEST K"
3301          enddo
3302          if (waga_dist.ge.0.0d0) then
3303 c
3304 c          For Gaussian-type Urestr
3305 c
3306             grad_odl3=waga_homology(iset)*waga_dist
3307      &                *sum_sgodl/(sum_godl*dij)
3308 c
3309 c          For Lorentzian-type Urestr
3310 c
3311          else
3312 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3313 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3314             grad_odl3=-waga_homology(iset)*waga_dist*
3315      &                sum_sgodl/(constr_homology*dij)
3316          endif
3317 c
3318 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3319
3320
3321 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3322 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3323 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3324
3325 ccc      write(iout,*) godl, sgodl, grad_odl3
3326
3327 c          grad_odl=grad_odl+grad_odl3
3328
3329          do jik=1,3
3330             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3331 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3332 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3333 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3334             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3335             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3336 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3337 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3338 c         if (i.eq.25.and.j.eq.27) then
3339 c         write(iout,*) "jik",jik,"i",i,"j",j
3340 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3341 c         write(iout,*) "grad_odl3",grad_odl3
3342 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3343 c         write(iout,*) "ggodl",ggodl
3344 c         write(iout,*) "ghpbc(",jik,i,")",
3345 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3346 c     &                 ghpbc(jik,j)
3347 c         endif
3348          enddo
3349 #endif
3350 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3351 ccc     & dLOG(odleg2),"-odleg=", -odleg
3352
3353       enddo ! ii-loop for dist
3354 #ifdef DEBUG
3355       write(iout,*) "------- dist restrs end -------"
3356 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3357 c    &     waga_d.eq.1.0d0) call sum_gradient
3358 #endif
3359 c Pseudo-energy and gradient from dihedral-angle restraints from
3360 c homology templates
3361 c      write (iout,*) "End of distance loop"
3362 c      call flush(iout)
3363       kat=0.0d0
3364 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3365 #ifdef DEBUG
3366       write(iout,*) "------- dih restrs start -------"
3367       do i=idihconstr_start_homo,idihconstr_end_homo
3368         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3369       enddo
3370 #endif
3371       do i=idihconstr_start_homo,idihconstr_end_homo
3372         kat2=0.0d0
3373 c        betai=beta(i,i+1,i+2,i+3)
3374         betai = phi(i+3)
3375 c       write (iout,*) "betai =",betai
3376         do k=1,constr_homology
3377           dih_diff(k)=pinorm(dih(k,i)-betai)
3378 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3379 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3380 c     &                                   -(6.28318-dih_diff(i,k))
3381 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3382 c     &                                   6.28318+dih_diff(i,k)
3383
3384           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3385 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3386           gdih(k)=dexp(kat3)
3387           kat2=kat2+gdih(k)
3388 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3389 c          write(*,*)""
3390         enddo
3391 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3392 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3393 #ifdef DEBUG
3394         write (iout,*) "i",i," betai",betai," kat2",kat2
3395         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3396 #endif
3397         if (kat2.le.1.0d-14) cycle
3398         kat=kat-dLOG(kat2/constr_homology)
3399 c       write (iout,*) "kat",kat ! sum of -ln-s
3400
3401 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3402 ccc     & dLOG(kat2), "-kat=", -kat
3403
3404 #ifdef GRAD
3405 c ----------------------------------------------------------------------
3406 c Gradient
3407 c ----------------------------------------------------------------------
3408
3409         sum_gdih=kat2
3410         sum_sgdih=0.0d0
3411         do k=1,constr_homology
3412           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3413 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3414           sum_sgdih=sum_sgdih+sgdih
3415         enddo
3416 c       grad_dih3=sum_sgdih/sum_gdih
3417         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3418
3419 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3420 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3421 ccc     & gloc(nphi+i-3,icg)
3422         gloc(i,icg)=gloc(i,icg)+grad_dih3
3423 c        if (i.eq.25) then
3424 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3425 c        endif
3426 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3427 ccc     & gloc(nphi+i-3,icg)
3428 #endif
3429       enddo ! i-loop for dih
3430 #ifdef DEBUG
3431       write(iout,*) "------- dih restrs end -------"
3432 #endif
3433
3434 c Pseudo-energy and gradient for theta angle restraints from
3435 c homology templates
3436 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3437 c adapted
3438
3439 c
3440 c     For constr_homology reference structures (FP)
3441 c
3442 c     Uconst_back_tot=0.0d0
3443       Eval=0.0d0
3444       Erot=0.0d0
3445 c     Econstr_back legacy
3446 #ifdef GRAD
3447       do i=1,nres
3448 c     do i=ithet_start,ithet_end
3449        dutheta(i)=0.0d0
3450 c     enddo
3451 c     do i=loc_start,loc_end
3452         do j=1,3
3453           duscdiff(j,i)=0.0d0
3454           duscdiffx(j,i)=0.0d0
3455         enddo
3456       enddo
3457 #endif
3458 c
3459 c     do iref=1,nref
3460 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3461 c     write (iout,*) "waga_theta",waga_theta
3462       if (waga_theta.gt.0.0d0) then
3463 #ifdef DEBUG
3464       write (iout,*) "usampl",usampl
3465       write(iout,*) "------- theta restrs start -------"
3466 c     do i=ithet_start,ithet_end
3467 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3468 c     enddo
3469 #endif
3470 c     write (iout,*) "maxres",maxres,"nres",nres
3471
3472       do i=ithet_start,ithet_end
3473 c
3474 c     do i=1,nfrag_back
3475 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3476 c
3477 c Deviation of theta angles wrt constr_homology ref structures
3478 c
3479         utheta_i=0.0d0 ! argument of Gaussian for single k
3480         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3481 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3482 c       over residues in a fragment
3483 c       write (iout,*) "theta(",i,")=",theta(i)
3484         do k=1,constr_homology
3485 c
3486 c         dtheta_i=theta(j)-thetaref(j,iref)
3487 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3488           theta_diff(k)=thetatpl(k,i)-theta(i)
3489 c
3490           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3491 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3492           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3493           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3494 c         Gradient for single Gaussian restraint in subr Econstr_back
3495 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3496 c
3497         enddo
3498 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3499 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3500
3501 c
3502 #ifdef GRAD
3503 c         Gradient for multiple Gaussian restraint
3504         sum_gtheta=gutheta_i
3505         sum_sgtheta=0.0d0
3506         do k=1,constr_homology
3507 c        New generalized expr for multiple Gaussian from Econstr_back
3508          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3509 c
3510 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3511           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3512         enddo
3513 c       grad_theta3=sum_sgtheta/sum_gtheta 1/*theta(i)? s. line below
3514 c       grad_theta3=sum_sgtheta/sum_gtheta
3515 c
3516 c       Final value of gradient using same var as in Econstr_back
3517         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3518      &               *waga_homology(iset)
3519 c       dutheta(i)=sum_sgtheta/sum_gtheta
3520 c
3521 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3522 #endif
3523         Eval=Eval-dLOG(gutheta_i/constr_homology)
3524 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3525 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3526 c       Uconst_back=Uconst_back+utheta(i)
3527       enddo ! (i-loop for theta)
3528 #ifdef DEBUG
3529       write(iout,*) "------- theta restrs end -------"
3530 #endif
3531       endif
3532 c
3533 c Deviation of local SC geometry
3534 c
3535 c Separation of two i-loops (instructed by AL - 11/3/2014)
3536 c
3537 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3538 c     write (iout,*) "waga_d",waga_d
3539
3540 #ifdef DEBUG
3541       write(iout,*) "------- SC restrs start -------"
3542       write (iout,*) "Initial duscdiff,duscdiffx"
3543       do i=loc_start,loc_end
3544         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3545      &                 (duscdiffx(jik,i),jik=1,3)
3546       enddo
3547 #endif
3548       do i=loc_start,loc_end
3549         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3550         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3551 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3552 c       write(iout,*) "xxtab, yytab, zztab"
3553 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3554         do k=1,constr_homology
3555 c
3556           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3557 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3558           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3559           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3560 c         write(iout,*) "dxx, dyy, dzz"
3561 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3562 c
3563           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3564 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3565 c         uscdiffk(k)=usc_diff(i)
3566           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3567           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3568 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3569 c     &      xxref(j),yyref(j),zzref(j)
3570         enddo
3571 c
3572 c       Gradient
3573 c
3574 c       Generalized expression for multiple Gaussian acc to that for a single
3575 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3576 c
3577 c       Original implementation
3578 c       sum_guscdiff=guscdiff(i)
3579 c
3580 c       sum_sguscdiff=0.0d0
3581 c       do k=1,constr_homology
3582 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3583 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3584 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3585 c       enddo
3586 c
3587 c       Implementation of new expressions for gradient (Jan. 2015)
3588 c
3589 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3590 #ifdef GRAD
3591         do k=1,constr_homology
3592 c
3593 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3594 c       before. Now the drivatives should be correct
3595 c
3596           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3597 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3598           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3599           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3600 c
3601 c         New implementation
3602 c
3603           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3604      &                 sigma_d(k,i) ! for the grad wrt r'
3605 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3606 c
3607 c
3608 c        New implementation
3609          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3610          do jik=1,3
3611             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3612      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3613      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3614             duscdiff(jik,i)=duscdiff(jik,i)+
3615      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3616      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3617             duscdiffx(jik,i)=duscdiffx(jik,i)+
3618      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3619      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3620 c
3621 #ifdef DEBUG
3622              write(iout,*) "jik",jik,"i",i
3623              write(iout,*) "dxx, dyy, dzz"
3624              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3625              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3626 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3627 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3628 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3629 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3630 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3631 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3632 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3633 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3634 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3635 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3636 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3637 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3638 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3639 c            endif
3640 #endif
3641          enddo
3642         enddo
3643 #endif
3644 c
3645 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3646 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3647 c
3648 c        write (iout,*) i," uscdiff",uscdiff(i)
3649 c
3650 c Put together deviations from local geometry
3651
3652 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3653 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3654         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3655 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3656 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3657 c       Uconst_back=Uconst_back+usc_diff(i)
3658 c
3659 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3660 c
3661 c     New implment: multiplied by sum_sguscdiff
3662 c
3663
3664       enddo ! (i-loop for dscdiff)
3665
3666 c      endif
3667
3668 #ifdef DEBUG
3669       write(iout,*) "------- SC restrs end -------"
3670         write (iout,*) "------ After SC loop in e_modeller ------"
3671         do i=loc_start,loc_end
3672          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3673          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3674         enddo
3675       if (waga_theta.eq.1.0d0) then
3676       write (iout,*) "in e_modeller after SC restr end: dutheta"
3677       do i=ithet_start,ithet_end
3678         write (iout,*) i,dutheta(i)
3679       enddo
3680       endif
3681       if (waga_d.eq.1.0d0) then
3682       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3683       do i=1,nres
3684         write (iout,*) i,(duscdiff(j,i),j=1,3)
3685         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3686       enddo
3687       endif
3688 #endif
3689
3690 c Total energy from homology restraints
3691 #ifdef DEBUG
3692       write (iout,*) "odleg",odleg," kat",kat
3693       write (iout,*) "odleg",odleg," kat",kat
3694       write (iout,*) "Eval",Eval," Erot",Erot
3695       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3696       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3697       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3698 #endif
3699 c
3700 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3701 c
3702 c     ehomology_constr=odleg+kat
3703 c
3704 c     For Lorentzian-type Urestr
3705 c
3706
3707       if (waga_dist.ge.0.0d0) then
3708 c
3709 c          For Gaussian-type Urestr
3710 c
3711         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
3712      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3713 c     write (iout,*) "ehomology_constr=",ehomology_constr
3714       else
3715 c
3716 c          For Lorentzian-type Urestr
3717 c
3718         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
3719      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
3720 c     write (iout,*) "ehomology_constr=",ehomology_constr
3721       endif
3722 c     write (iout,*) "odleg",odleg," kat",kat," Uconst_back",Uconst_back
3723 c     write (iout,*) "ehomology_constr",ehomology_constr
3724 c     ehomology_constr=odleg+kat+Uconst_back
3725       return
3726
3727   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3728   747 format(a12,i4,i4,i4,f8.3,f8.3)
3729   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3730   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3731   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3732      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3733       end
3734 c-----------------------------------------------------------------------
3735       subroutine ebond(estr)
3736 c
3737 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3738 c
3739       implicit real*8 (a-h,o-z)
3740       include 'DIMENSIONS'
3741       include 'DIMENSIONS.ZSCOPT'
3742       include 'COMMON.LOCAL'
3743       include 'COMMON.GEO'
3744       include 'COMMON.INTERACT'
3745       include 'COMMON.DERIV'
3746       include 'COMMON.VAR'
3747       include 'COMMON.CHAIN'
3748       include 'COMMON.IOUNITS'
3749       include 'COMMON.NAMES'
3750       include 'COMMON.FFIELD'
3751       include 'COMMON.CONTROL'
3752       double precision u(3),ud(3)
3753       logical :: lprn=.false.
3754       estr=0.0d0
3755       do i=nnt+1,nct
3756         diff = vbld(i)-vbldp0
3757 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3758         estr=estr+diff*diff
3759         do j=1,3
3760           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3761         enddo
3762       enddo
3763       estr=0.5d0*AKP*estr
3764 c
3765 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3766 c
3767       do i=nnt,nct
3768         iti=itype(i)
3769         if (iti.ne.10) then
3770           nbi=nbondterm(iti)
3771           if (nbi.eq.1) then
3772             diff=vbld(i+nres)-vbldsc0(1,iti)
3773             if (lprn)
3774      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3775      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3776             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3777             do j=1,3
3778               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3779             enddo
3780           else
3781             do j=1,nbi
3782               diff=vbld(i+nres)-vbldsc0(j,iti)
3783               ud(j)=aksc(j,iti)*diff
3784               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3785             enddo
3786             uprod=u(1)
3787             do j=2,nbi
3788               uprod=uprod*u(j)
3789             enddo
3790             usum=0.0d0
3791             usumsqder=0.0d0
3792             do j=1,nbi
3793               uprod1=1.0d0
3794               uprod2=1.0d0
3795               do k=1,nbi
3796                 if (k.ne.j) then
3797                   uprod1=uprod1*u(k)
3798                   uprod2=uprod2*u(k)*u(k)
3799                 endif
3800               enddo
3801               usum=usum+uprod1
3802               usumsqder=usumsqder+ud(j)*uprod2
3803             enddo
3804             if (lprn)
3805      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3806      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3807             estr=estr+uprod/usum
3808             do j=1,3
3809              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3810             enddo
3811           endif
3812         endif
3813       enddo
3814       return
3815       end
3816 #ifdef CRYST_THETA
3817 C--------------------------------------------------------------------------
3818       subroutine ebend(etheta)
3819 C
3820 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3821 C angles gamma and its derivatives in consecutive thetas and gammas.
3822 C
3823       implicit real*8 (a-h,o-z)
3824       include 'DIMENSIONS'
3825       include 'DIMENSIONS.ZSCOPT'
3826       include 'COMMON.LOCAL'
3827       include 'COMMON.GEO'
3828       include 'COMMON.INTERACT'
3829       include 'COMMON.DERIV'
3830       include 'COMMON.VAR'
3831       include 'COMMON.CHAIN'
3832       include 'COMMON.IOUNITS'
3833       include 'COMMON.NAMES'
3834       include 'COMMON.FFIELD'
3835       common /calcthet/ term1,term2,termm,diffak,ratak,
3836      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3837      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3838       double precision y(2),z(2)
3839       delta=0.02d0*pi
3840       time11=dexp(-2*time)
3841       time12=1.0d0
3842       etheta=0.0D0
3843 c      write (iout,*) "nres",nres
3844 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3845 c      write (iout,*) ithet_start,ithet_end
3846       do i=ithet_start,ithet_end
3847 C Zero the energy function and its derivative at 0 or pi.
3848         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3849         it=itype(i-1)
3850 c        if (i.gt.ithet_start .and.
3851 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3852 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3853 c          phii=phi(i)
3854 c          y(1)=dcos(phii)
3855 c          y(2)=dsin(phii)
3856 c        else
3857 c          y(1)=0.0D0
3858 c          y(2)=0.0D0
3859 c        endif
3860 c        if (i.lt.nres .and. itel(i).ne.0) then
3861 c          phii1=phi(i+1)
3862 c          z(1)=dcos(phii1)
3863 c          z(2)=dsin(phii1)
3864 c        else
3865 c          z(1)=0.0D0
3866 c          z(2)=0.0D0
3867 c        endif
3868         if (i.gt.3) then
3869 #ifdef OSF
3870           phii=phi(i)
3871           icrc=0
3872           call proc_proc(phii,icrc)
3873           if (icrc.eq.1) phii=150.0
3874 #else
3875           phii=phi(i)
3876 #endif
3877           y(1)=dcos(phii)
3878           y(2)=dsin(phii)
3879         else
3880           y(1)=0.0D0
3881           y(2)=0.0D0
3882         endif
3883         if (i.lt.nres) then
3884 #ifdef OSF
3885           phii1=phi(i+1)
3886           icrc=0
3887           call proc_proc(phii1,icrc)
3888           if (icrc.eq.1) phii1=150.0
3889           phii1=pinorm(phii1)
3890           z(1)=cos(phii1)
3891 #else
3892           phii1=phi(i+1)
3893           z(1)=dcos(phii1)
3894 #endif
3895           z(2)=dsin(phii1)
3896         else
3897           z(1)=0.0D0
3898           z(2)=0.0D0
3899         endif
3900 C Calculate the "mean" value of theta from the part of the distribution
3901 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3902 C In following comments this theta will be referred to as t_c.
3903         thet_pred_mean=0.0d0
3904         do k=1,2
3905           athetk=athet(k,it)
3906           bthetk=bthet(k,it)
3907           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3908         enddo
3909 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3910         dthett=thet_pred_mean*ssd
3911         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3912 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3913 C Derivatives of the "mean" values in gamma1 and gamma2.
3914         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3915         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3916         if (theta(i).gt.pi-delta) then
3917           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3918      &         E_tc0)
3919           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3920           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3921           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3922      &        E_theta)
3923           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3924      &        E_tc)
3925         else if (theta(i).lt.delta) then
3926           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3927           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3928           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3929      &        E_theta)
3930           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3931           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3932      &        E_tc)
3933         else
3934           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3935      &        E_theta,E_tc)
3936         endif
3937         etheta=etheta+ethetai
3938 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3939 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3940         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3941         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3942         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3943  1215   continue
3944       enddo
3945 C Ufff.... We've done all this!!!
3946       return
3947       end
3948 C---------------------------------------------------------------------------
3949       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3950      &     E_tc)
3951       implicit real*8 (a-h,o-z)
3952       include 'DIMENSIONS'
3953       include 'COMMON.LOCAL'
3954       include 'COMMON.IOUNITS'
3955       common /calcthet/ term1,term2,termm,diffak,ratak,
3956      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3957      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3958 C Calculate the contributions to both Gaussian lobes.
3959 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3960 C The "polynomial part" of the "standard deviation" of this part of
3961 C the distribution.
3962         sig=polthet(3,it)
3963         do j=2,0,-1
3964           sig=sig*thet_pred_mean+polthet(j,it)
3965         enddo
3966 C Derivative of the "interior part" of the "standard deviation of the"
3967 C gamma-dependent Gaussian lobe in t_c.
3968         sigtc=3*polthet(3,it)
3969         do j=2,1,-1
3970           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3971         enddo
3972         sigtc=sig*sigtc
3973 C Set the parameters of both Gaussian lobes of the distribution.
3974 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3975         fac=sig*sig+sigc0(it)
3976         sigcsq=fac+fac
3977         sigc=1.0D0/sigcsq
3978 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3979         sigsqtc=-4.0D0*sigcsq*sigtc
3980 c       print *,i,sig,sigtc,sigsqtc
3981 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3982         sigtc=-sigtc/(fac*fac)
3983 C Following variable is sigma(t_c)**(-2)
3984         sigcsq=sigcsq*sigcsq
3985         sig0i=sig0(it)
3986         sig0inv=1.0D0/sig0i**2
3987         delthec=thetai-thet_pred_mean
3988         delthe0=thetai-theta0i
3989         term1=-0.5D0*sigcsq*delthec*delthec
3990         term2=-0.5D0*sig0inv*delthe0*delthe0
3991 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3992 C NaNs in taking the logarithm. We extract the largest exponent which is added
3993 C to the energy (this being the log of the distribution) at the end of energy
3994 C term evaluation for this virtual-bond angle.
3995         if (term1.gt.term2) then
3996           termm=term1
3997           term2=dexp(term2-termm)
3998           term1=1.0d0
3999         else
4000           termm=term2
4001           term1=dexp(term1-termm)
4002           term2=1.0d0
4003         endif
4004 C The ratio between the gamma-independent and gamma-dependent lobes of
4005 C the distribution is a Gaussian function of thet_pred_mean too.
4006         diffak=gthet(2,it)-thet_pred_mean
4007         ratak=diffak/gthet(3,it)**2
4008         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4009 C Let's differentiate it in thet_pred_mean NOW.
4010         aktc=ak*ratak
4011 C Now put together the distribution terms to make complete distribution.
4012         termexp=term1+ak*term2
4013         termpre=sigc+ak*sig0i
4014 C Contribution of the bending energy from this theta is just the -log of
4015 C the sum of the contributions from the two lobes and the pre-exponential
4016 C factor. Simple enough, isn't it?
4017         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4018 C NOW the derivatives!!!
4019 C 6/6/97 Take into account the deformation.
4020         E_theta=(delthec*sigcsq*term1
4021      &       +ak*delthe0*sig0inv*term2)/termexp
4022         E_tc=((sigtc+aktc*sig0i)/termpre
4023      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4024      &       aktc*term2)/termexp)
4025       return
4026       end
4027 c-----------------------------------------------------------------------------
4028       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4029       implicit real*8 (a-h,o-z)
4030       include 'DIMENSIONS'
4031       include 'COMMON.LOCAL'
4032       include 'COMMON.IOUNITS'
4033       common /calcthet/ term1,term2,termm,diffak,ratak,
4034      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4035      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4036       delthec=thetai-thet_pred_mean
4037       delthe0=thetai-theta0i
4038 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4039       t3 = thetai-thet_pred_mean
4040       t6 = t3**2
4041       t9 = term1
4042       t12 = t3*sigcsq
4043       t14 = t12+t6*sigsqtc
4044       t16 = 1.0d0
4045       t21 = thetai-theta0i
4046       t23 = t21**2
4047       t26 = term2
4048       t27 = t21*t26
4049       t32 = termexp
4050       t40 = t32**2
4051       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4052      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4053      & *(-t12*t9-ak*sig0inv*t27)
4054       return
4055       end
4056 #else
4057 C--------------------------------------------------------------------------
4058       subroutine ebend(etheta)
4059 C
4060 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4061 C angles gamma and its derivatives in consecutive thetas and gammas.
4062 C ab initio-derived potentials from
4063 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4064 C
4065       implicit real*8 (a-h,o-z)
4066       include 'DIMENSIONS'
4067       include 'DIMENSIONS.ZSCOPT'
4068       include 'COMMON.LOCAL'
4069       include 'COMMON.GEO'
4070       include 'COMMON.INTERACT'
4071       include 'COMMON.DERIV'
4072       include 'COMMON.VAR'
4073       include 'COMMON.CHAIN'
4074       include 'COMMON.IOUNITS'
4075       include 'COMMON.NAMES'
4076       include 'COMMON.FFIELD'
4077       include 'COMMON.CONTROL'
4078       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4079      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4080      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4081      & sinph1ph2(maxdouble,maxdouble)
4082       logical lprn /.false./, lprn1 /.false./
4083       etheta=0.0D0
4084 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4085       do i=ithet_start,ithet_end
4086         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4087      &    (itype(i).eq.ntyp1)) cycle
4088         dethetai=0.0d0
4089         dephii=0.0d0
4090         dephii1=0.0d0
4091         theti2=0.5d0*theta(i)
4092         ityp2=ithetyp(itype(i-1))
4093         do k=1,nntheterm
4094           coskt(k)=dcos(k*theti2)
4095           sinkt(k)=dsin(k*theti2)
4096         enddo
4097         if (i.gt.3  .and. itype(i-3).ne.ntyp1) then
4098 #ifdef OSF
4099           phii=phi(i)
4100           if (phii.ne.phii) phii=150.0
4101 #else
4102           phii=phi(i)
4103 #endif
4104           ityp1=ithetyp(itype(i-2))
4105           do k=1,nsingle
4106             cosph1(k)=dcos(k*phii)
4107             sinph1(k)=dsin(k*phii)
4108           enddo
4109         else
4110           phii=0.0d0
4111           ityp1=ithetyp(itype(i-2))
4112           do k=1,nsingle
4113             cosph1(k)=0.0d0
4114             sinph1(k)=0.0d0
4115           enddo
4116         endif
4117         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4118 #ifdef OSF
4119           phii1=phi(i+1)
4120           if (phii1.ne.phii1) phii1=150.0
4121           phii1=pinorm(phii1)
4122 #else
4123           phii1=phi(i+1)
4124 #endif
4125           ityp3=ithetyp(itype(i))
4126           do k=1,nsingle
4127             cosph2(k)=dcos(k*phii1)
4128             sinph2(k)=dsin(k*phii1)
4129           enddo
4130         else
4131           phii1=0.0d0
4132           ityp3=nthetyp+1
4133           do k=1,nsingle
4134             cosph2(k)=0.0d0
4135             sinph2(k)=0.0d0
4136           enddo
4137         endif
4138 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4139 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4140 c        call flush(iout)
4141         ethetai=aa0thet(ityp1,ityp2,ityp3)
4142         do k=1,ndouble
4143           do l=1,k-1
4144             ccl=cosph1(l)*cosph2(k-l)
4145             ssl=sinph1(l)*sinph2(k-l)
4146             scl=sinph1(l)*cosph2(k-l)
4147             csl=cosph1(l)*sinph2(k-l)
4148             cosph1ph2(l,k)=ccl-ssl
4149             cosph1ph2(k,l)=ccl+ssl
4150             sinph1ph2(l,k)=scl+csl
4151             sinph1ph2(k,l)=scl-csl
4152           enddo
4153         enddo
4154         if (lprn) then
4155         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4156      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4157         write (iout,*) "coskt and sinkt"
4158         do k=1,nntheterm
4159           write (iout,*) k,coskt(k),sinkt(k)
4160         enddo
4161         endif
4162         do k=1,ntheterm
4163           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4164           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4165      &      *coskt(k)
4166           if (lprn)
4167      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4168      &     " ethetai",ethetai
4169         enddo
4170         if (lprn) then
4171         write (iout,*) "cosph and sinph"
4172         do k=1,nsingle
4173           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4174         enddo
4175         write (iout,*) "cosph1ph2 and sinph2ph2"
4176         do k=2,ndouble
4177           do l=1,k-1
4178             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4179      &         sinph1ph2(l,k),sinph1ph2(k,l)
4180           enddo
4181         enddo
4182         write(iout,*) "ethetai",ethetai
4183         endif
4184         do m=1,ntheterm2
4185           do k=1,nsingle
4186             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4187      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4188      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4189      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4190             ethetai=ethetai+sinkt(m)*aux
4191             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4192             dephii=dephii+k*sinkt(m)*(
4193      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4194      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4195             dephii1=dephii1+k*sinkt(m)*(
4196      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4197      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4198             if (lprn)
4199      &      write (iout,*) "m",m," k",k," bbthet",
4200      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4201      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4202      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4203      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4204           enddo
4205         enddo
4206         if (lprn)
4207      &  write(iout,*) "ethetai",ethetai
4208         do m=1,ntheterm3
4209           do k=2,ndouble
4210             do l=1,k-1
4211               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4212      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4213      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4214      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4215               ethetai=ethetai+sinkt(m)*aux
4216               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4217               dephii=dephii+l*sinkt(m)*(
4218      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4219      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4220      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4221      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4222               dephii1=dephii1+(k-l)*sinkt(m)*(
4223      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4224      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4225      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4226      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4227               if (lprn) then
4228               write (iout,*) "m",m," k",k," l",l," ffthet",
4229      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4230      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4231      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4232      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4233               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4234      &            cosph1ph2(k,l)*sinkt(m),
4235      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4236               endif
4237             enddo
4238           enddo
4239         enddo
4240 10      continue
4241 c        lprn1=.true.
4242         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4243      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
4244      &   phii1*rad2deg,ethetai
4245 c        lprn1=.false.
4246         etheta=etheta+ethetai
4247
4248         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4249         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4250         gloc(nphi+i-2,icg)=wang*dethetai
4251       enddo
4252       return
4253       end
4254 #endif
4255 #ifdef CRYST_SC
4256 c-----------------------------------------------------------------------------
4257       subroutine esc(escloc)
4258 C Calculate the local energy of a side chain and its derivatives in the
4259 C corresponding virtual-bond valence angles THETA and the spherical angles
4260 C ALPHA and OMEGA.
4261       implicit real*8 (a-h,o-z)
4262       include 'DIMENSIONS'
4263       include 'DIMENSIONS.ZSCOPT'
4264       include 'COMMON.GEO'
4265       include 'COMMON.LOCAL'
4266       include 'COMMON.VAR'
4267       include 'COMMON.INTERACT'
4268       include 'COMMON.DERIV'
4269       include 'COMMON.CHAIN'
4270       include 'COMMON.IOUNITS'
4271       include 'COMMON.NAMES'
4272       include 'COMMON.FFIELD'
4273       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4274      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4275       common /sccalc/ time11,time12,time112,theti,it,nlobit
4276       delta=0.02d0*pi
4277       escloc=0.0D0
4278 c     write (iout,'(a)') 'ESC'
4279       do i=loc_start,loc_end
4280         it=itype(i)
4281         if (it.eq.10) goto 1
4282         nlobit=nlob(it)
4283 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4284 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4285         theti=theta(i+1)-pipol
4286         x(1)=dtan(theti)
4287         x(2)=alph(i)
4288         x(3)=omeg(i)
4289 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4290
4291         if (x(2).gt.pi-delta) then
4292           xtemp(1)=x(1)
4293           xtemp(2)=pi-delta
4294           xtemp(3)=x(3)
4295           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4296           xtemp(2)=pi
4297           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4298           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4299      &        escloci,dersc(2))
4300           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4301      &        ddersc0(1),dersc(1))
4302           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4303      &        ddersc0(3),dersc(3))
4304           xtemp(2)=pi-delta
4305           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4306           xtemp(2)=pi
4307           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4308           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4309      &            dersc0(2),esclocbi,dersc02)
4310           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4311      &            dersc12,dersc01)
4312           call splinthet(x(2),0.5d0*delta,ss,ssd)
4313           dersc0(1)=dersc01
4314           dersc0(2)=dersc02
4315           dersc0(3)=0.0d0
4316           do k=1,3
4317             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4318           enddo
4319           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4320 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4321 c    &             esclocbi,ss,ssd
4322           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4323 c         escloci=esclocbi
4324 c         write (iout,*) escloci
4325         else if (x(2).lt.delta) then
4326           xtemp(1)=x(1)
4327           xtemp(2)=delta
4328           xtemp(3)=x(3)
4329           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4330           xtemp(2)=0.0d0
4331           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4332           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4333      &        escloci,dersc(2))
4334           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4335      &        ddersc0(1),dersc(1))
4336           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4337      &        ddersc0(3),dersc(3))
4338           xtemp(2)=delta
4339           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4340           xtemp(2)=0.0d0
4341           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4342           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4343      &            dersc0(2),esclocbi,dersc02)
4344           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4345      &            dersc12,dersc01)
4346           dersc0(1)=dersc01
4347           dersc0(2)=dersc02
4348           dersc0(3)=0.0d0
4349           call splinthet(x(2),0.5d0*delta,ss,ssd)
4350           do k=1,3
4351             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4352           enddo
4353           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4354 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4355 c    &             esclocbi,ss,ssd
4356           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4357 c         write (iout,*) escloci
4358         else
4359           call enesc(x,escloci,dersc,ddummy,.false.)
4360         endif
4361
4362         escloc=escloc+escloci
4363 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4364
4365         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4366      &   wscloc*dersc(1)
4367         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4368         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4369     1   continue
4370       enddo
4371       return
4372       end
4373 C---------------------------------------------------------------------------
4374       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4375       implicit real*8 (a-h,o-z)
4376       include 'DIMENSIONS'
4377       include 'COMMON.GEO'
4378       include 'COMMON.LOCAL'
4379       include 'COMMON.IOUNITS'
4380       common /sccalc/ time11,time12,time112,theti,it,nlobit
4381       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4382       double precision contr(maxlob,-1:1)
4383       logical mixed
4384 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4385         escloc_i=0.0D0
4386         do j=1,3
4387           dersc(j)=0.0D0
4388           if (mixed) ddersc(j)=0.0d0
4389         enddo
4390         x3=x(3)
4391
4392 C Because of periodicity of the dependence of the SC energy in omega we have
4393 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4394 C To avoid underflows, first compute & store the exponents.
4395
4396         do iii=-1,1
4397
4398           x(3)=x3+iii*dwapi
4399
4400           do j=1,nlobit
4401             do k=1,3
4402               z(k)=x(k)-censc(k,j,it)
4403             enddo
4404             do k=1,3
4405               Axk=0.0D0
4406               do l=1,3
4407                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4408               enddo
4409               Ax(k,j,iii)=Axk
4410             enddo
4411             expfac=0.0D0
4412             do k=1,3
4413               expfac=expfac+Ax(k,j,iii)*z(k)
4414             enddo
4415             contr(j,iii)=expfac
4416           enddo ! j
4417
4418         enddo ! iii
4419
4420         x(3)=x3
4421 C As in the case of ebend, we want to avoid underflows in exponentiation and
4422 C subsequent NaNs and INFs in energy calculation.
4423 C Find the largest exponent
4424         emin=contr(1,-1)
4425         do iii=-1,1
4426           do j=1,nlobit
4427             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4428           enddo
4429         enddo
4430         emin=0.5D0*emin
4431 cd      print *,'it=',it,' emin=',emin
4432
4433 C Compute the contribution to SC energy and derivatives
4434         do iii=-1,1
4435
4436           do j=1,nlobit
4437             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4438 cd          print *,'j=',j,' expfac=',expfac
4439             escloc_i=escloc_i+expfac
4440             do k=1,3
4441               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4442             enddo
4443             if (mixed) then
4444               do k=1,3,2
4445                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4446      &            +gaussc(k,2,j,it))*expfac
4447               enddo
4448             endif
4449           enddo
4450
4451         enddo ! iii
4452
4453         dersc(1)=dersc(1)/cos(theti)**2
4454         ddersc(1)=ddersc(1)/cos(theti)**2
4455         ddersc(3)=ddersc(3)
4456
4457         escloci=-(dlog(escloc_i)-emin)
4458         do j=1,3
4459           dersc(j)=dersc(j)/escloc_i
4460         enddo
4461         if (mixed) then
4462           do j=1,3,2
4463             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4464           enddo
4465         endif
4466       return
4467       end
4468 C------------------------------------------------------------------------------
4469       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4470       implicit real*8 (a-h,o-z)
4471       include 'DIMENSIONS'
4472       include 'COMMON.GEO'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.IOUNITS'
4475       common /sccalc/ time11,time12,time112,theti,it,nlobit
4476       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4477       double precision contr(maxlob)
4478       logical mixed
4479
4480       escloc_i=0.0D0
4481
4482       do j=1,3
4483         dersc(j)=0.0D0
4484       enddo
4485
4486       do j=1,nlobit
4487         do k=1,2
4488           z(k)=x(k)-censc(k,j,it)
4489         enddo
4490         z(3)=dwapi
4491         do k=1,3
4492           Axk=0.0D0
4493           do l=1,3
4494             Axk=Axk+gaussc(l,k,j,it)*z(l)
4495           enddo
4496           Ax(k,j)=Axk
4497         enddo
4498         expfac=0.0D0
4499         do k=1,3
4500           expfac=expfac+Ax(k,j)*z(k)
4501         enddo
4502         contr(j)=expfac
4503       enddo ! j
4504
4505 C As in the case of ebend, we want to avoid underflows in exponentiation and
4506 C subsequent NaNs and INFs in energy calculation.
4507 C Find the largest exponent
4508       emin=contr(1)
4509       do j=1,nlobit
4510         if (emin.gt.contr(j)) emin=contr(j)
4511       enddo
4512       emin=0.5D0*emin
4513
4514 C Compute the contribution to SC energy and derivatives
4515
4516       dersc12=0.0d0
4517       do j=1,nlobit
4518         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4519         escloc_i=escloc_i+expfac
4520         do k=1,2
4521           dersc(k)=dersc(k)+Ax(k,j)*expfac
4522         enddo
4523         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4524      &            +gaussc(1,2,j,it))*expfac
4525         dersc(3)=0.0d0
4526       enddo
4527
4528       dersc(1)=dersc(1)/cos(theti)**2
4529       dersc12=dersc12/cos(theti)**2
4530       escloci=-(dlog(escloc_i)-emin)
4531       do j=1,2
4532         dersc(j)=dersc(j)/escloc_i
4533       enddo
4534       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4535       return
4536       end
4537 #else
4538 c----------------------------------------------------------------------------------
4539       subroutine esc(escloc)
4540 C Calculate the local energy of a side chain and its derivatives in the
4541 C corresponding virtual-bond valence angles THETA and the spherical angles
4542 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4543 C added by Urszula Kozlowska. 07/11/2007
4544 C
4545       implicit real*8 (a-h,o-z)
4546       include 'DIMENSIONS'
4547       include 'DIMENSIONS.ZSCOPT'
4548       include 'COMMON.GEO'
4549       include 'COMMON.LOCAL'
4550       include 'COMMON.VAR'
4551       include 'COMMON.SCROT'
4552       include 'COMMON.INTERACT'
4553       include 'COMMON.DERIV'
4554       include 'COMMON.CHAIN'
4555       include 'COMMON.IOUNITS'
4556       include 'COMMON.NAMES'
4557       include 'COMMON.FFIELD'
4558       include 'COMMON.CONTROL'
4559       include 'COMMON.VECTORS'
4560       double precision x_prime(3),y_prime(3),z_prime(3)
4561      &    , sumene,dsc_i,dp2_i,x(65),
4562      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4563      &    de_dxx,de_dyy,de_dzz,de_dt
4564       double precision s1_t,s1_6_t,s2_t,s2_6_t
4565       double precision
4566      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4567      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4568      & dt_dCi(3),dt_dCi1(3)
4569       common /sccalc/ time11,time12,time112,theti,it,nlobit
4570       delta=0.02d0*pi
4571       escloc=0.0D0
4572       do i=loc_start,loc_end
4573         costtab(i+1) =dcos(theta(i+1))
4574         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4575         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4576         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4577         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4578         cosfac=dsqrt(cosfac2)
4579         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4580         sinfac=dsqrt(sinfac2)
4581         it=itype(i)
4582         if (it.eq.10) goto 1
4583 c
4584 C  Compute the axes of tghe local cartesian coordinates system; store in
4585 c   x_prime, y_prime and z_prime
4586 c
4587         do j=1,3
4588           x_prime(j) = 0.00
4589           y_prime(j) = 0.00
4590           z_prime(j) = 0.00
4591         enddo
4592 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4593 C     &   dc_norm(3,i+nres)
4594         do j = 1,3
4595           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4596           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4597         enddo
4598         do j = 1,3
4599           z_prime(j) = -uz(j,i-1)
4600         enddo
4601 c       write (2,*) "i",i
4602 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4603 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4604 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4605 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4606 c      & " xy",scalar(x_prime(1),y_prime(1)),
4607 c      & " xz",scalar(x_prime(1),z_prime(1)),
4608 c      & " yy",scalar(y_prime(1),y_prime(1)),
4609 c      & " yz",scalar(y_prime(1),z_prime(1)),
4610 c      & " zz",scalar(z_prime(1),z_prime(1))
4611 c
4612 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4613 C to local coordinate system. Store in xx, yy, zz.
4614 c
4615         xx=0.0d0
4616         yy=0.0d0
4617         zz=0.0d0
4618         do j = 1,3
4619           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4620           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4621           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4622         enddo
4623
4624         xxtab(i)=xx
4625         yytab(i)=yy
4626         zztab(i)=zz
4627 C
4628 C Compute the energy of the ith side cbain
4629 C
4630 c        write (2,*) "xx",xx," yy",yy," zz",zz
4631         it=itype(i)
4632         do j = 1,65
4633           x(j) = sc_parmin(j,it)
4634         enddo
4635 #ifdef CHECK_COORD
4636 Cc diagnostics - remove later
4637         xx1 = dcos(alph(2))
4638         yy1 = dsin(alph(2))*dcos(omeg(2))
4639         zz1 = -dsin(alph(2))*dsin(omeg(2))
4640         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4641      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4642      &    xx1,yy1,zz1
4643 C,"  --- ", xx_w,yy_w,zz_w
4644 c end diagnostics
4645 #endif
4646         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4647      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4648      &   + x(10)*yy*zz
4649         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4650      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4651      & + x(20)*yy*zz
4652         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4653      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4654      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4655      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4656      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4657      &  +x(40)*xx*yy*zz
4658         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4659      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4660      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4661      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4662      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4663      &  +x(60)*xx*yy*zz
4664         dsc_i   = 0.743d0+x(61)
4665         dp2_i   = 1.9d0+x(62)
4666         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4667      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4668         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4669      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4670         s1=(1+x(63))/(0.1d0 + dscp1)
4671         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4672         s2=(1+x(65))/(0.1d0 + dscp2)
4673         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4674         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4675      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4676 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4677 c     &   sumene4,
4678 c     &   dscp1,dscp2,sumene
4679 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4680         escloc = escloc + sumene
4681 c        write (2,*) "escloc",escloc
4682         if (.not. calc_grad) goto 1
4683
4684 #ifdef DEBUG2
4685 C
4686 C This section to check the numerical derivatives of the energy of ith side
4687 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4688 C #define DEBUG in the code to turn it on.
4689 C
4690         write (2,*) "sumene               =",sumene
4691         aincr=1.0d-7
4692         xxsave=xx
4693         xx=xx+aincr
4694         write (2,*) xx,yy,zz
4695         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4696         de_dxx_num=(sumenep-sumene)/aincr
4697         xx=xxsave
4698         write (2,*) "xx+ sumene from enesc=",sumenep
4699         yysave=yy
4700         yy=yy+aincr
4701         write (2,*) xx,yy,zz
4702         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4703         de_dyy_num=(sumenep-sumene)/aincr
4704         yy=yysave
4705         write (2,*) "yy+ sumene from enesc=",sumenep
4706         zzsave=zz
4707         zz=zz+aincr
4708         write (2,*) xx,yy,zz
4709         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4710         de_dzz_num=(sumenep-sumene)/aincr
4711         zz=zzsave
4712         write (2,*) "zz+ sumene from enesc=",sumenep
4713         costsave=cost2tab(i+1)
4714         sintsave=sint2tab(i+1)
4715         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4716         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4717         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4718         de_dt_num=(sumenep-sumene)/aincr
4719         write (2,*) " t+ sumene from enesc=",sumenep
4720         cost2tab(i+1)=costsave
4721         sint2tab(i+1)=sintsave
4722 C End of diagnostics section.
4723 #endif
4724 C
4725 C Compute the gradient of esc
4726 C
4727         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4728         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4729         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4730         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4731         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4732         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4733         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4734         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4735         pom1=(sumene3*sint2tab(i+1)+sumene1)
4736      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4737         pom2=(sumene4*cost2tab(i+1)+sumene2)
4738      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4739         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4740         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4741      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4742      &  +x(40)*yy*zz
4743         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4744         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4745      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4746      &  +x(60)*yy*zz
4747         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4748      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4749      &        +(pom1+pom2)*pom_dx
4750 #ifdef DEBUG
4751         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4752 #endif
4753 C
4754         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4755         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4756      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4757      &  +x(40)*xx*zz
4758         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4759         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4760      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4761      &  +x(59)*zz**2 +x(60)*xx*zz
4762         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4763      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4764      &        +(pom1-pom2)*pom_dy
4765 #ifdef DEBUG
4766         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4767 #endif
4768 C
4769         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4770      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4771      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4772      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4773      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4774      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4775      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4776      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4777 #ifdef DEBUG
4778         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4779 #endif
4780 C
4781         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4782      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4783      &  +pom1*pom_dt1+pom2*pom_dt2
4784 #ifdef DEBUG
4785         write(2,*), "de_dt = ", de_dt,de_dt_num
4786 #endif
4787 c
4788 C
4789        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4790        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4791        cosfac2xx=cosfac2*xx
4792        sinfac2yy=sinfac2*yy
4793        do k = 1,3
4794          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4795      &      vbld_inv(i+1)
4796          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4797      &      vbld_inv(i)
4798          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4799          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4800 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4801 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4802 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4803 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4804          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4805          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4806          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4807          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4808          dZZ_Ci1(k)=0.0d0
4809          dZZ_Ci(k)=0.0d0
4810          do j=1,3
4811            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4812            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4813          enddo
4814
4815          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4816          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4817          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4818 c
4819          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4820          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4821        enddo
4822
4823        do k=1,3
4824          dXX_Ctab(k,i)=dXX_Ci(k)
4825          dXX_C1tab(k,i)=dXX_Ci1(k)
4826          dYY_Ctab(k,i)=dYY_Ci(k)
4827          dYY_C1tab(k,i)=dYY_Ci1(k)
4828          dZZ_Ctab(k,i)=dZZ_Ci(k)
4829          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4830          dXX_XYZtab(k,i)=dXX_XYZ(k)
4831          dYY_XYZtab(k,i)=dYY_XYZ(k)
4832          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4833        enddo
4834
4835        do k = 1,3
4836 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4837 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4838 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4839 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4840 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4841 c     &    dt_dci(k)
4842 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4843 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4844          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4845      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4846          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4847      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4848          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4849      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4850        enddo
4851 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4852 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4853
4854 C to check gradient call subroutine check_grad
4855
4856     1 continue
4857       enddo
4858       return
4859       end
4860 #endif
4861 c------------------------------------------------------------------------------
4862       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4863 C
4864 C This procedure calculates two-body contact function g(rij) and its derivative:
4865 C
4866 C           eps0ij                                     !       x < -1
4867 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4868 C            0                                         !       x > 1
4869 C
4870 C where x=(rij-r0ij)/delta
4871 C
4872 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4873 C
4874       implicit none
4875       double precision rij,r0ij,eps0ij,fcont,fprimcont
4876       double precision x,x2,x4,delta
4877 c     delta=0.02D0*r0ij
4878 c      delta=0.2D0*r0ij
4879       x=(rij-r0ij)/delta
4880       if (x.lt.-1.0D0) then
4881         fcont=eps0ij
4882         fprimcont=0.0D0
4883       else if (x.le.1.0D0) then
4884         x2=x*x
4885         x4=x2*x2
4886         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4887         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4888       else
4889         fcont=0.0D0
4890         fprimcont=0.0D0
4891       endif
4892       return
4893       end
4894 c------------------------------------------------------------------------------
4895       subroutine splinthet(theti,delta,ss,ssder)
4896       implicit real*8 (a-h,o-z)
4897       include 'DIMENSIONS'
4898       include 'DIMENSIONS.ZSCOPT'
4899       include 'COMMON.VAR'
4900       include 'COMMON.GEO'
4901       thetup=pi-delta
4902       thetlow=delta
4903       if (theti.gt.pipol) then
4904         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4905       else
4906         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4907         ssder=-ssder
4908       endif
4909       return
4910       end
4911 c------------------------------------------------------------------------------
4912       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4913       implicit none
4914       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4915       double precision ksi,ksi2,ksi3,a1,a2,a3
4916       a1=fprim0*delta/(f1-f0)
4917       a2=3.0d0-2.0d0*a1
4918       a3=a1-2.0d0
4919       ksi=(x-x0)/delta
4920       ksi2=ksi*ksi
4921       ksi3=ksi2*ksi
4922       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4923       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4924       return
4925       end
4926 c------------------------------------------------------------------------------
4927       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4928       implicit none
4929       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4930       double precision ksi,ksi2,ksi3,a1,a2,a3
4931       ksi=(x-x0)/delta
4932       ksi2=ksi*ksi
4933       ksi3=ksi2*ksi
4934       a1=fprim0x*delta
4935       a2=3*(f1x-f0x)-2*fprim0x*delta
4936       a3=fprim0x*delta-2*(f1x-f0x)
4937       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4938       return
4939       end
4940 C-----------------------------------------------------------------------------
4941 #ifdef CRYST_TOR
4942 C-----------------------------------------------------------------------------
4943       subroutine etor(etors,edihcnstr,fact)
4944       implicit real*8 (a-h,o-z)
4945       include 'DIMENSIONS'
4946       include 'DIMENSIONS.ZSCOPT'
4947       include 'COMMON.VAR'
4948       include 'COMMON.GEO'
4949       include 'COMMON.LOCAL'
4950       include 'COMMON.TORSION'
4951       include 'COMMON.INTERACT'
4952       include 'COMMON.DERIV'
4953       include 'COMMON.CHAIN'
4954       include 'COMMON.NAMES'
4955       include 'COMMON.IOUNITS'
4956       include 'COMMON.FFIELD'
4957       include 'COMMON.TORCNSTR'
4958       logical lprn
4959 C Set lprn=.true. for debugging
4960       lprn=.false.
4961 c      lprn=.true.
4962       etors=0.0D0
4963       do i=iphi_start,iphi_end
4964         itori=itortyp(itype(i-2))
4965         itori1=itortyp(itype(i-1))
4966         phii=phi(i)
4967         gloci=0.0D0
4968 C Proline-Proline pair is a special case...
4969         if (itori.eq.3 .and. itori1.eq.3) then
4970           if (phii.gt.-dwapi3) then
4971             cosphi=dcos(3*phii)
4972             fac=1.0D0/(1.0D0-cosphi)
4973             etorsi=v1(1,3,3)*fac
4974             etorsi=etorsi+etorsi
4975             etors=etors+etorsi-v1(1,3,3)
4976             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4977           endif
4978           do j=1,3
4979             v1ij=v1(j+1,itori,itori1)
4980             v2ij=v2(j+1,itori,itori1)
4981             cosphi=dcos(j*phii)
4982             sinphi=dsin(j*phii)
4983             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4984             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4985           enddo
4986         else
4987           do j=1,nterm_old
4988             v1ij=v1(j,itori,itori1)
4989             v2ij=v2(j,itori,itori1)
4990             cosphi=dcos(j*phii)
4991             sinphi=dsin(j*phii)
4992             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4993             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4994           enddo
4995         endif
4996         if (lprn)
4997      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4998      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4999      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5000         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5001 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5002       enddo
5003 ! 6/20/98 - dihedral angle constraints
5004       edihcnstr=0.0d0
5005       do i=1,ndih_constr
5006         itori=idih_constr(i)
5007         phii=phi(itori)
5008         difi=phii-phi0(i)
5009         if (difi.gt.drange(i)) then
5010           difi=difi-drange(i)
5011           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5012           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5013         else if (difi.lt.-drange(i)) then
5014           difi=difi+drange(i)
5015           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5016           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5017         endif
5018 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5019 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5020       enddo
5021 !      write (iout,*) 'edihcnstr',edihcnstr
5022       return
5023       end
5024 c------------------------------------------------------------------------------
5025 #else
5026       subroutine etor(etors,edihcnstr,fact)
5027       implicit real*8 (a-h,o-z)
5028       include 'DIMENSIONS'
5029       include 'DIMENSIONS.ZSCOPT'
5030       include 'COMMON.VAR'
5031       include 'COMMON.GEO'
5032       include 'COMMON.LOCAL'
5033       include 'COMMON.TORSION'
5034       include 'COMMON.INTERACT'
5035       include 'COMMON.DERIV'
5036       include 'COMMON.CHAIN'
5037       include 'COMMON.NAMES'
5038       include 'COMMON.IOUNITS'
5039       include 'COMMON.FFIELD'
5040       include 'COMMON.TORCNSTR'
5041       logical lprn
5042 C Set lprn=.true. for debugging
5043       lprn=.false.
5044 c      lprn=.true.
5045       etors=0.0D0
5046       do i=iphi_start,iphi_end
5047         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5048         itori=itortyp(itype(i-2))
5049         itori1=itortyp(itype(i-1))
5050         phii=phi(i)
5051         gloci=0.0D0
5052 C Regular cosine and sine terms
5053         do j=1,nterm(itori,itori1)
5054           v1ij=v1(j,itori,itori1)
5055           v2ij=v2(j,itori,itori1)
5056           cosphi=dcos(j*phii)
5057           sinphi=dsin(j*phii)
5058           etors=etors+v1ij*cosphi+v2ij*sinphi
5059           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5060         enddo
5061 C Lorentz terms
5062 C                         v1
5063 C  E = SUM ----------------------------------- - v1
5064 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5065 C
5066         cosphi=dcos(0.5d0*phii)
5067         sinphi=dsin(0.5d0*phii)
5068         do j=1,nlor(itori,itori1)
5069           vl1ij=vlor1(j,itori,itori1)
5070           vl2ij=vlor2(j,itori,itori1)
5071           vl3ij=vlor3(j,itori,itori1)
5072           pom=vl2ij*cosphi+vl3ij*sinphi
5073           pom1=1.0d0/(pom*pom+1.0d0)
5074           etors=etors+vl1ij*pom1
5075           pom=-pom*pom1*pom1
5076           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5077         enddo
5078 C Subtract the constant term
5079         etors=etors-v0(itori,itori1)
5080         if (lprn)
5081      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5082      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5083      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5084         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5085 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5086  1215   continue
5087       enddo
5088 ! 6/20/98 - dihedral angle constraints
5089       edihcnstr=0.0d0
5090       do i=1,ndih_constr
5091         itori=idih_constr(i)
5092         phii=phi(itori)
5093         difi=pinorm(phii-phi0(i))
5094         edihi=0.0d0
5095         if (difi.gt.drange(i)) then
5096           difi=difi-drange(i)
5097           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5098           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5099           edihi=0.25d0*ftors*difi**4
5100         else if (difi.lt.-drange(i)) then
5101           difi=difi+drange(i)
5102           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5103           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5104           edihi=0.25d0*ftors*difi**4
5105         else
5106           difi=0.0d0
5107         endif
5108 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5109 c     &    drange(i),edihi
5110 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5111 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5112       enddo
5113 !      write (iout,*) 'edihcnstr',edihcnstr
5114       return
5115       end
5116 c----------------------------------------------------------------------------
5117       subroutine etor_d(etors_d,fact2)
5118 C 6/23/01 Compute double torsional energy
5119       implicit real*8 (a-h,o-z)
5120       include 'DIMENSIONS'
5121       include 'DIMENSIONS.ZSCOPT'
5122       include 'COMMON.VAR'
5123       include 'COMMON.GEO'
5124       include 'COMMON.LOCAL'
5125       include 'COMMON.TORSION'
5126       include 'COMMON.INTERACT'
5127       include 'COMMON.DERIV'
5128       include 'COMMON.CHAIN'
5129       include 'COMMON.NAMES'
5130       include 'COMMON.IOUNITS'
5131       include 'COMMON.FFIELD'
5132       include 'COMMON.TORCNSTR'
5133       logical lprn
5134 C Set lprn=.true. for debugging
5135       lprn=.false.
5136 c     lprn=.true.
5137       etors_d=0.0D0
5138       do i=iphi_start,iphi_end-1
5139         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5140      &     goto 1215
5141         itori=itortyp(itype(i-2))
5142         itori1=itortyp(itype(i-1))
5143         itori2=itortyp(itype(i))
5144         phii=phi(i)
5145         phii1=phi(i+1)
5146         gloci1=0.0D0
5147         gloci2=0.0D0
5148 C Regular cosine and sine terms
5149         do j=1,ntermd_1(itori,itori1,itori2)
5150           v1cij=v1c(1,j,itori,itori1,itori2)
5151           v1sij=v1s(1,j,itori,itori1,itori2)
5152           v2cij=v1c(2,j,itori,itori1,itori2)
5153           v2sij=v1s(2,j,itori,itori1,itori2)
5154           cosphi1=dcos(j*phii)
5155           sinphi1=dsin(j*phii)
5156           cosphi2=dcos(j*phii1)
5157           sinphi2=dsin(j*phii1)
5158           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5159      &     v2cij*cosphi2+v2sij*sinphi2
5160           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5161           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5162         enddo
5163         do k=2,ntermd_2(itori,itori1,itori2)
5164           do l=1,k-1
5165             v1cdij = v2c(k,l,itori,itori1,itori2)
5166             v2cdij = v2c(l,k,itori,itori1,itori2)
5167             v1sdij = v2s(k,l,itori,itori1,itori2)
5168             v2sdij = v2s(l,k,itori,itori1,itori2)
5169             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5170             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5171             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5172             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5173             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5174      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5175             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5176      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5177             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5178      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5179           enddo
5180         enddo
5181         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5182         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5183  1215   continue
5184       enddo
5185       return
5186       end
5187 #endif
5188 c------------------------------------------------------------------------------
5189       subroutine eback_sc_corr(esccor)
5190 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5191 c        conformational states; temporarily implemented as differences
5192 c        between UNRES torsional potentials (dependent on three types of
5193 c        residues) and the torsional potentials dependent on all 20 types
5194 c        of residues computed from AM1 energy surfaces of terminally-blocked
5195 c        amino-acid residues.
5196       implicit real*8 (a-h,o-z)
5197       include 'DIMENSIONS'
5198       include 'DIMENSIONS.ZSCOPT'
5199       include 'COMMON.VAR'
5200       include 'COMMON.GEO'
5201       include 'COMMON.LOCAL'
5202       include 'COMMON.TORSION'
5203       include 'COMMON.SCCOR'
5204       include 'COMMON.INTERACT'
5205       include 'COMMON.DERIV'
5206       include 'COMMON.CHAIN'
5207       include 'COMMON.NAMES'
5208       include 'COMMON.IOUNITS'
5209       include 'COMMON.FFIELD'
5210       include 'COMMON.CONTROL'
5211       logical lprn
5212 C Set lprn=.true. for debugging
5213       lprn=.false.
5214 c      lprn=.true.
5215 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
5216       esccor=0.0D0
5217       do i=itau_start,itau_end
5218         esccor_ii=0.0D0
5219         isccori=isccortyp(itype(i-2))
5220         isccori1=isccortyp(itype(i-1))
5221         phii=phi(i)
5222 cccc  Added 9 May 2012
5223 cc Tauangle is torsional engle depending on the value of first digit
5224 c(see comment below)
5225 cc Omicron is flat angle depending on the value of first digit
5226 c(see comment below)
5227
5228
5229         do intertyp=1,3 !intertyp
5230 cc Added 09 May 2012 (Adasko)
5231 cc  Intertyp means interaction type of backbone mainchain correlation:
5232 c   1 = SC...Ca...Ca...Ca
5233 c   2 = Ca...Ca...Ca...SC
5234 c   3 = SC...Ca...Ca...SCi
5235         gloci=0.0D0
5236         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5237      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5238      &      (itype(i-1).eq.21)))
5239      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5240      &     .or.(itype(i-2).eq.21)))
5241      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5242      &      (itype(i-1).eq.21)))) cycle
5243         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5244         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5245      & cycle
5246         do j=1,nterm_sccor(isccori,isccori1)
5247           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5248           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5249           cosphi=dcos(j*tauangle(intertyp,i))
5250           sinphi=dsin(j*tauangle(intertyp,i))
5251           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5252           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5253         enddo
5254         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5255 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5256 c     &gloc_sc(intertyp,i-3,icg)
5257         if (lprn)
5258      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5259      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5260      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5261      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5262         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5263        enddo !intertyp
5264       enddo
5265 c        do i=1,nres
5266 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5267 c        enddo
5268       return
5269       end
5270 c------------------------------------------------------------------------------
5271       subroutine multibody(ecorr)
5272 C This subroutine calculates multi-body contributions to energy following
5273 C the idea of Skolnick et al. If side chains I and J make a contact and
5274 C at the same time side chains I+1 and J+1 make a contact, an extra
5275 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5276       implicit real*8 (a-h,o-z)
5277       include 'DIMENSIONS'
5278       include 'COMMON.IOUNITS'
5279       include 'COMMON.DERIV'
5280       include 'COMMON.INTERACT'
5281       include 'COMMON.CONTACTS'
5282       double precision gx(3),gx1(3)
5283       logical lprn
5284
5285 C Set lprn=.true. for debugging
5286       lprn=.false.
5287
5288       if (lprn) then
5289         write (iout,'(a)') 'Contact function values:'
5290         do i=nnt,nct-2
5291           write (iout,'(i2,20(1x,i2,f10.5))')
5292      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5293         enddo
5294       endif
5295       ecorr=0.0D0
5296       do i=nnt,nct
5297         do j=1,3
5298           gradcorr(j,i)=0.0D0
5299           gradxorr(j,i)=0.0D0
5300         enddo
5301       enddo
5302       do i=nnt,nct-2
5303
5304         DO ISHIFT = 3,4
5305
5306         i1=i+ishift
5307         num_conti=num_cont(i)
5308         num_conti1=num_cont(i1)
5309         do jj=1,num_conti
5310           j=jcont(jj,i)
5311           do kk=1,num_conti1
5312             j1=jcont(kk,i1)
5313             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5314 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5315 cd   &                   ' ishift=',ishift
5316 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5317 C The system gains extra energy.
5318               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5319             endif   ! j1==j+-ishift
5320           enddo     ! kk
5321         enddo       ! jj
5322
5323         ENDDO ! ISHIFT
5324
5325       enddo         ! i
5326       return
5327       end
5328 c------------------------------------------------------------------------------
5329       double precision function esccorr(i,j,k,l,jj,kk)
5330       implicit real*8 (a-h,o-z)
5331       include 'DIMENSIONS'
5332       include 'COMMON.IOUNITS'
5333       include 'COMMON.DERIV'
5334       include 'COMMON.INTERACT'
5335       include 'COMMON.CONTACTS'
5336       double precision gx(3),gx1(3)
5337       logical lprn
5338       lprn=.false.
5339       eij=facont(jj,i)
5340       ekl=facont(kk,k)
5341 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5342 C Calculate the multi-body contribution to energy.
5343 C Calculate multi-body contributions to the gradient.
5344 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5345 cd   & k,l,(gacont(m,kk,k),m=1,3)
5346       do m=1,3
5347         gx(m) =ekl*gacont(m,jj,i)
5348         gx1(m)=eij*gacont(m,kk,k)
5349         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5350         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5351         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5352         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5353       enddo
5354       do m=i,j-1
5355         do ll=1,3
5356           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5357         enddo
5358       enddo
5359       do m=k,l-1
5360         do ll=1,3
5361           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5362         enddo
5363       enddo
5364       esccorr=-eij*ekl
5365       return
5366       end
5367 c------------------------------------------------------------------------------
5368 #ifdef MPL
5369       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5370       implicit real*8 (a-h,o-z)
5371       include 'DIMENSIONS'
5372       integer dimen1,dimen2,atom,indx
5373       double precision buffer(dimen1,dimen2)
5374       double precision zapas
5375       common /contacts_hb/ zapas(3,20,maxres,7),
5376      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5377      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5378       num_kont=num_cont_hb(atom)
5379       do i=1,num_kont
5380         do k=1,7
5381           do j=1,3
5382             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5383           enddo ! j
5384         enddo ! k
5385         buffer(i,indx+22)=facont_hb(i,atom)
5386         buffer(i,indx+23)=ees0p(i,atom)
5387         buffer(i,indx+24)=ees0m(i,atom)
5388         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5389       enddo ! i
5390       buffer(1,indx+26)=dfloat(num_kont)
5391       return
5392       end
5393 c------------------------------------------------------------------------------
5394       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5395       implicit real*8 (a-h,o-z)
5396       include 'DIMENSIONS'
5397       integer dimen1,dimen2,atom,indx
5398       double precision buffer(dimen1,dimen2)
5399       double precision zapas
5400       common /contacts_hb/ zapas(3,20,maxres,7),
5401      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5402      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5403       num_kont=buffer(1,indx+26)
5404       num_kont_old=num_cont_hb(atom)
5405       num_cont_hb(atom)=num_kont+num_kont_old
5406       do i=1,num_kont
5407         ii=i+num_kont_old
5408         do k=1,7
5409           do j=1,3
5410             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5411           enddo ! j
5412         enddo ! k
5413         facont_hb(ii,atom)=buffer(i,indx+22)
5414         ees0p(ii,atom)=buffer(i,indx+23)
5415         ees0m(ii,atom)=buffer(i,indx+24)
5416         jcont_hb(ii,atom)=buffer(i,indx+25)
5417       enddo ! i
5418       return
5419       end
5420 c------------------------------------------------------------------------------
5421 #endif
5422       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5423 C This subroutine calculates multi-body contributions to hydrogen-bonding
5424       implicit real*8 (a-h,o-z)
5425       include 'DIMENSIONS'
5426       include 'DIMENSIONS.ZSCOPT'
5427       include 'COMMON.IOUNITS'
5428 #ifdef MPL
5429       include 'COMMON.INFO'
5430 #endif
5431       include 'COMMON.FFIELD'
5432       include 'COMMON.DERIV'
5433       include 'COMMON.INTERACT'
5434       include 'COMMON.CONTACTS'
5435 #ifdef MPL
5436       parameter (max_cont=maxconts)
5437       parameter (max_dim=2*(8*3+2))
5438       parameter (msglen1=max_cont*max_dim*4)
5439       parameter (msglen2=2*msglen1)
5440       integer source,CorrelType,CorrelID,Error
5441       double precision buffer(max_cont,max_dim)
5442 #endif
5443       double precision gx(3),gx1(3)
5444       logical lprn,ldone
5445
5446 C Set lprn=.true. for debugging
5447       lprn=.false.
5448 #ifdef MPL
5449       n_corr=0
5450       n_corr1=0
5451       if (fgProcs.le.1) goto 30
5452       if (lprn) then
5453         write (iout,'(a)') 'Contact function values:'
5454         do i=nnt,nct-2
5455           write (iout,'(2i3,50(1x,i2,f5.2))')
5456      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5457      &    j=1,num_cont_hb(i))
5458         enddo
5459       endif
5460 C Caution! Following code assumes that electrostatic interactions concerning
5461 C a given atom are split among at most two processors!
5462       CorrelType=477
5463       CorrelID=MyID+1
5464       ldone=.false.
5465       do i=1,max_cont
5466         do j=1,max_dim
5467           buffer(i,j)=0.0D0
5468         enddo
5469       enddo
5470       mm=mod(MyRank,2)
5471 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5472       if (mm) 20,20,10
5473    10 continue
5474 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5475       if (MyRank.gt.0) then
5476 C Send correlation contributions to the preceding processor
5477         msglen=msglen1
5478         nn=num_cont_hb(iatel_s)
5479         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5480 cd      write (iout,*) 'The BUFFER array:'
5481 cd      do i=1,nn
5482 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5483 cd      enddo
5484         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5485           msglen=msglen2
5486             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5487 C Clear the contacts of the atom passed to the neighboring processor
5488         nn=num_cont_hb(iatel_s+1)
5489 cd      do i=1,nn
5490 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5491 cd      enddo
5492             num_cont_hb(iatel_s)=0
5493         endif
5494 cd      write (iout,*) 'Processor ',MyID,MyRank,
5495 cd   & ' is sending correlation contribution to processor',MyID-1,
5496 cd   & ' msglen=',msglen
5497 cd      write (*,*) 'Processor ',MyID,MyRank,
5498 cd   & ' is sending correlation contribution to processor',MyID-1,
5499 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5500         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5501 cd      write (iout,*) 'Processor ',MyID,
5502 cd   & ' has sent correlation contribution to processor',MyID-1,
5503 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5504 cd      write (*,*) 'Processor ',MyID,
5505 cd   & ' has sent correlation contribution to processor',MyID-1,
5506 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5507         msglen=msglen1
5508       endif ! (MyRank.gt.0)
5509       if (ldone) goto 30
5510       ldone=.true.
5511    20 continue
5512 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5513       if (MyRank.lt.fgProcs-1) then
5514 C Receive correlation contributions from the next processor
5515         msglen=msglen1
5516         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5517 cd      write (iout,*) 'Processor',MyID,
5518 cd   & ' is receiving correlation contribution from processor',MyID+1,
5519 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5520 cd      write (*,*) 'Processor',MyID,
5521 cd   & ' is receiving correlation contribution from processor',MyID+1,
5522 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5523         nbytes=-1
5524         do while (nbytes.le.0)
5525           call mp_probe(MyID+1,CorrelType,nbytes)
5526         enddo
5527 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5528         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5529 cd      write (iout,*) 'Processor',MyID,
5530 cd   & ' has received correlation contribution from processor',MyID+1,
5531 cd   & ' msglen=',msglen,' nbytes=',nbytes
5532 cd      write (iout,*) 'The received BUFFER array:'
5533 cd      do i=1,max_cont
5534 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5535 cd      enddo
5536         if (msglen.eq.msglen1) then
5537           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5538         else if (msglen.eq.msglen2)  then
5539           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5540           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5541         else
5542           write (iout,*)
5543      & 'ERROR!!!! message length changed while processing correlations.'
5544           write (*,*)
5545      & 'ERROR!!!! message length changed while processing correlations.'
5546           call mp_stopall(Error)
5547         endif ! msglen.eq.msglen1
5548       endif ! MyRank.lt.fgProcs-1
5549       if (ldone) goto 30
5550       ldone=.true.
5551       goto 10
5552    30 continue
5553 #endif
5554       if (lprn) then
5555         write (iout,'(a)') 'Contact function values:'
5556         do i=nnt,nct-2
5557           write (iout,'(2i3,50(1x,i2,f5.2))')
5558      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5559      &    j=1,num_cont_hb(i))
5560         enddo
5561       endif
5562       ecorr=0.0D0
5563 C Remove the loop below after debugging !!!
5564       do i=nnt,nct
5565         do j=1,3
5566           gradcorr(j,i)=0.0D0
5567           gradxorr(j,i)=0.0D0
5568         enddo
5569       enddo
5570 C Calculate the local-electrostatic correlation terms
5571       do i=iatel_s,iatel_e+1
5572         i1=i+1
5573         num_conti=num_cont_hb(i)
5574         num_conti1=num_cont_hb(i+1)
5575         do jj=1,num_conti
5576           j=jcont_hb(jj,i)
5577           do kk=1,num_conti1
5578             j1=jcont_hb(kk,i1)
5579 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5580 c     &         ' jj=',jj,' kk=',kk
5581             if (j1.eq.j+1 .or. j1.eq.j-1) then
5582 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5583 C The system gains extra energy.
5584               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5585               n_corr=n_corr+1
5586             else if (j1.eq.j) then
5587 C Contacts I-J and I-(J+1) occur simultaneously.
5588 C The system loses extra energy.
5589 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5590             endif
5591           enddo ! kk
5592           do kk=1,num_conti
5593             j1=jcont_hb(kk,i)
5594 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5595 c    &         ' jj=',jj,' kk=',kk
5596             if (j1.eq.j+1) then
5597 C Contacts I-J and (I+1)-J occur simultaneously.
5598 C The system loses extra energy.
5599 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5600             endif ! j1==j+1
5601           enddo ! kk
5602         enddo ! jj
5603       enddo ! i
5604       return
5605       end
5606 c------------------------------------------------------------------------------
5607       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5608      &  n_corr1)
5609 C This subroutine calculates multi-body contributions to hydrogen-bonding
5610       implicit real*8 (a-h,o-z)
5611       include 'DIMENSIONS'
5612       include 'DIMENSIONS.ZSCOPT'
5613       include 'COMMON.IOUNITS'
5614 #ifdef MPL
5615       include 'COMMON.INFO'
5616 #endif
5617       include 'COMMON.FFIELD'
5618       include 'COMMON.DERIV'
5619       include 'COMMON.INTERACT'
5620       include 'COMMON.CONTACTS'
5621 #ifdef MPL
5622       parameter (max_cont=maxconts)
5623       parameter (max_dim=2*(8*3+2))
5624       parameter (msglen1=max_cont*max_dim*4)
5625       parameter (msglen2=2*msglen1)
5626       integer source,CorrelType,CorrelID,Error
5627       double precision buffer(max_cont,max_dim)
5628 #endif
5629       double precision gx(3),gx1(3)
5630       logical lprn,ldone
5631
5632 C Set lprn=.true. for debugging
5633       lprn=.false.
5634       eturn6=0.0d0
5635 #ifdef MPL
5636       n_corr=0
5637       n_corr1=0
5638       if (fgProcs.le.1) goto 30
5639       if (lprn) then
5640         write (iout,'(a)') 'Contact function values:'
5641         do i=nnt,nct-2
5642           write (iout,'(2i3,50(1x,i2,f5.2))')
5643      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5644      &    j=1,num_cont_hb(i))
5645         enddo
5646       endif
5647 C Caution! Following code assumes that electrostatic interactions concerning
5648 C a given atom are split among at most two processors!
5649       CorrelType=477
5650       CorrelID=MyID+1
5651       ldone=.false.
5652       do i=1,max_cont
5653         do j=1,max_dim
5654           buffer(i,j)=0.0D0
5655         enddo
5656       enddo
5657       mm=mod(MyRank,2)
5658 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5659       if (mm) 20,20,10
5660    10 continue
5661 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5662       if (MyRank.gt.0) then
5663 C Send correlation contributions to the preceding processor
5664         msglen=msglen1
5665         nn=num_cont_hb(iatel_s)
5666         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5667 cd      write (iout,*) 'The BUFFER array:'
5668 cd      do i=1,nn
5669 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5670 cd      enddo
5671         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5672           msglen=msglen2
5673             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5674 C Clear the contacts of the atom passed to the neighboring processor
5675         nn=num_cont_hb(iatel_s+1)
5676 cd      do i=1,nn
5677 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5678 cd      enddo
5679             num_cont_hb(iatel_s)=0
5680         endif
5681 cd      write (iout,*) 'Processor ',MyID,MyRank,
5682 cd   & ' is sending correlation contribution to processor',MyID-1,
5683 cd   & ' msglen=',msglen
5684 cd      write (*,*) 'Processor ',MyID,MyRank,
5685 cd   & ' is sending correlation contribution to processor',MyID-1,
5686 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5687         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5688 cd      write (iout,*) 'Processor ',MyID,
5689 cd   & ' has sent correlation contribution to processor',MyID-1,
5690 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5691 cd      write (*,*) 'Processor ',MyID,
5692 cd   & ' has sent correlation contribution to processor',MyID-1,
5693 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5694         msglen=msglen1
5695       endif ! (MyRank.gt.0)
5696       if (ldone) goto 30
5697       ldone=.true.
5698    20 continue
5699 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5700       if (MyRank.lt.fgProcs-1) then
5701 C Receive correlation contributions from the next processor
5702         msglen=msglen1
5703         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5704 cd      write (iout,*) 'Processor',MyID,
5705 cd   & ' is receiving correlation contribution from processor',MyID+1,
5706 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5707 cd      write (*,*) 'Processor',MyID,
5708 cd   & ' is receiving correlation contribution from processor',MyID+1,
5709 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5710         nbytes=-1
5711         do while (nbytes.le.0)
5712           call mp_probe(MyID+1,CorrelType,nbytes)
5713         enddo
5714 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5715         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5716 cd      write (iout,*) 'Processor',MyID,
5717 cd   & ' has received correlation contribution from processor',MyID+1,
5718 cd   & ' msglen=',msglen,' nbytes=',nbytes
5719 cd      write (iout,*) 'The received BUFFER array:'
5720 cd      do i=1,max_cont
5721 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5722 cd      enddo
5723         if (msglen.eq.msglen1) then
5724           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5725         else if (msglen.eq.msglen2)  then
5726           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5727           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5728         else
5729           write (iout,*)
5730      & 'ERROR!!!! message length changed while processing correlations.'
5731           write (*,*)
5732      & 'ERROR!!!! message length changed while processing correlations.'
5733           call mp_stopall(Error)
5734         endif ! msglen.eq.msglen1
5735       endif ! MyRank.lt.fgProcs-1
5736       if (ldone) goto 30
5737       ldone=.true.
5738       goto 10
5739    30 continue
5740 #endif
5741       if (lprn) then
5742         write (iout,'(a)') 'Contact function values:'
5743         do i=nnt,nct-2
5744           write (iout,'(2i3,50(1x,i2,f5.2))')
5745      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5746      &    j=1,num_cont_hb(i))
5747         enddo
5748       endif
5749       ecorr=0.0D0
5750       ecorr5=0.0d0
5751       ecorr6=0.0d0
5752 C Remove the loop below after debugging !!!
5753       do i=nnt,nct
5754         do j=1,3
5755           gradcorr(j,i)=0.0D0
5756           gradxorr(j,i)=0.0D0
5757         enddo
5758       enddo
5759 C Calculate the dipole-dipole interaction energies
5760       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5761       do i=iatel_s,iatel_e+1
5762         num_conti=num_cont_hb(i)
5763         do jj=1,num_conti
5764           j=jcont_hb(jj,i)
5765           call dipole(i,j,jj)
5766         enddo
5767       enddo
5768       endif
5769 C Calculate the local-electrostatic correlation terms
5770       do i=iatel_s,iatel_e+1
5771         i1=i+1
5772         num_conti=num_cont_hb(i)
5773         num_conti1=num_cont_hb(i+1)
5774         do jj=1,num_conti
5775           j=jcont_hb(jj,i)
5776           do kk=1,num_conti1
5777             j1=jcont_hb(kk,i1)
5778 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5779 c     &         ' jj=',jj,' kk=',kk
5780             if (j1.eq.j+1 .or. j1.eq.j-1) then
5781 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5782 C The system gains extra energy.
5783               n_corr=n_corr+1
5784               sqd1=dsqrt(d_cont(jj,i))
5785               sqd2=dsqrt(d_cont(kk,i1))
5786               sred_geom = sqd1*sqd2
5787               IF (sred_geom.lt.cutoff_corr) THEN
5788                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5789      &            ekont,fprimcont)
5790 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5791 c     &         ' jj=',jj,' kk=',kk
5792                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5793                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5794                 do l=1,3
5795                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5796                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5797                 enddo
5798                 n_corr1=n_corr1+1
5799 cd               write (iout,*) 'sred_geom=',sred_geom,
5800 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5801                 call calc_eello(i,j,i+1,j1,jj,kk)
5802                 if (wcorr4.gt.0.0d0)
5803      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5804                 if (wcorr5.gt.0.0d0)
5805      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5806 c                print *,"wcorr5",ecorr5
5807 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5808 cd                write(2,*)'ijkl',i,j,i+1,j1
5809                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5810      &               .or. wturn6.eq.0.0d0))then
5811 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5812                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5813 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5814 cd     &            'ecorr6=',ecorr6
5815 cd                write (iout,'(4e15.5)') sred_geom,
5816 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5817 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5818 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5819                 else if (wturn6.gt.0.0d0
5820      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5821 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5822                   eturn6=eturn6+eello_turn6(i,jj,kk)
5823 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5824                 endif
5825               ENDIF
5826 1111          continue
5827             else if (j1.eq.j) then
5828 C Contacts I-J and I-(J+1) occur simultaneously.
5829 C The system loses extra energy.
5830 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5831             endif
5832           enddo ! kk
5833           do kk=1,num_conti
5834             j1=jcont_hb(kk,i)
5835 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5836 c    &         ' jj=',jj,' kk=',kk
5837             if (j1.eq.j+1) then
5838 C Contacts I-J and (I+1)-J occur simultaneously.
5839 C The system loses extra energy.
5840 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5841             endif ! j1==j+1
5842           enddo ! kk
5843         enddo ! jj
5844       enddo ! i
5845       return
5846       end
5847 c------------------------------------------------------------------------------
5848       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5849       implicit real*8 (a-h,o-z)
5850       include 'DIMENSIONS'
5851       include 'COMMON.IOUNITS'
5852       include 'COMMON.DERIV'
5853       include 'COMMON.INTERACT'
5854       include 'COMMON.CONTACTS'
5855       double precision gx(3),gx1(3)
5856       logical lprn
5857       lprn=.false.
5858       eij=facont_hb(jj,i)
5859       ekl=facont_hb(kk,k)
5860       ees0pij=ees0p(jj,i)
5861       ees0pkl=ees0p(kk,k)
5862       ees0mij=ees0m(jj,i)
5863       ees0mkl=ees0m(kk,k)
5864       ekont=eij*ekl
5865       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5866 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5867 C Following 4 lines for diagnostics.
5868 cd    ees0pkl=0.0D0
5869 cd    ees0pij=1.0D0
5870 cd    ees0mkl=0.0D0
5871 cd    ees0mij=1.0D0
5872 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5873 c    &   ' and',k,l
5874 c     write (iout,*)'Contacts have occurred for peptide groups',
5875 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5876 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5877 C Calculate the multi-body contribution to energy.
5878       ecorr=ecorr+ekont*ees
5879       if (calc_grad) then
5880 C Calculate multi-body contributions to the gradient.
5881       do ll=1,3
5882         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5883         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5884      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5885      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5886         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5887      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5888      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5889         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5890         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5891      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5892      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5893         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5894      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5895      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5896       enddo
5897       do m=i+1,j-1
5898         do ll=1,3
5899           gradcorr(ll,m)=gradcorr(ll,m)+
5900      &     ees*ekl*gacont_hbr(ll,jj,i)-
5901      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5902      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5903         enddo
5904       enddo
5905       do m=k+1,l-1
5906         do ll=1,3
5907           gradcorr(ll,m)=gradcorr(ll,m)+
5908      &     ees*eij*gacont_hbr(ll,kk,k)-
5909      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5910      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5911         enddo
5912       enddo
5913       endif
5914       ehbcorr=ekont*ees
5915       return
5916       end
5917 C---------------------------------------------------------------------------
5918       subroutine dipole(i,j,jj)
5919       implicit real*8 (a-h,o-z)
5920       include 'DIMENSIONS'
5921       include 'DIMENSIONS.ZSCOPT'
5922       include 'COMMON.IOUNITS'
5923       include 'COMMON.CHAIN'
5924       include 'COMMON.FFIELD'
5925       include 'COMMON.DERIV'
5926       include 'COMMON.INTERACT'
5927       include 'COMMON.CONTACTS'
5928       include 'COMMON.TORSION'
5929       include 'COMMON.VAR'
5930       include 'COMMON.GEO'
5931       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5932      &  auxmat(2,2)
5933       iti1 = itortyp(itype(i+1))
5934       if (j.lt.nres-1) then
5935         itj1 = itortyp(itype(j+1))
5936       else
5937         itj1=ntortyp+1
5938       endif
5939       do iii=1,2
5940         dipi(iii,1)=Ub2(iii,i)
5941         dipderi(iii)=Ub2der(iii,i)
5942         dipi(iii,2)=b1(iii,iti1)
5943         dipj(iii,1)=Ub2(iii,j)
5944         dipderj(iii)=Ub2der(iii,j)
5945         dipj(iii,2)=b1(iii,itj1)
5946       enddo
5947       kkk=0
5948       do iii=1,2
5949         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5950         do jjj=1,2
5951           kkk=kkk+1
5952           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5953         enddo
5954       enddo
5955       if (.not.calc_grad) return
5956       do kkk=1,5
5957         do lll=1,3
5958           mmm=0
5959           do iii=1,2
5960             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5961      &        auxvec(1))
5962             do jjj=1,2
5963               mmm=mmm+1
5964               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5965             enddo
5966           enddo
5967         enddo
5968       enddo
5969       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5970       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5971       do iii=1,2
5972         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5973       enddo
5974       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5975       do iii=1,2
5976         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5977       enddo
5978       return
5979       end
5980 C---------------------------------------------------------------------------
5981       subroutine calc_eello(i,j,k,l,jj,kk)
5982 C
5983 C This subroutine computes matrices and vectors needed to calculate
5984 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5985 C
5986       implicit real*8 (a-h,o-z)
5987       include 'DIMENSIONS'
5988       include 'DIMENSIONS.ZSCOPT'
5989       include 'COMMON.IOUNITS'
5990       include 'COMMON.CHAIN'
5991       include 'COMMON.DERIV'
5992       include 'COMMON.INTERACT'
5993       include 'COMMON.CONTACTS'
5994       include 'COMMON.TORSION'
5995       include 'COMMON.VAR'
5996       include 'COMMON.GEO'
5997       include 'COMMON.FFIELD'
5998       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5999      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6000       logical lprn
6001       common /kutas/ lprn
6002 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6003 cd     & ' jj=',jj,' kk=',kk
6004 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6005       do iii=1,2
6006         do jjj=1,2
6007           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6008           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6009         enddo
6010       enddo
6011       call transpose2(aa1(1,1),aa1t(1,1))
6012       call transpose2(aa2(1,1),aa2t(1,1))
6013       do kkk=1,5
6014         do lll=1,3
6015           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6016      &      aa1tder(1,1,lll,kkk))
6017           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6018      &      aa2tder(1,1,lll,kkk))
6019         enddo
6020       enddo
6021       if (l.eq.j+1) then
6022 C parallel orientation of the two CA-CA-CA frames.
6023         if (i.gt.1) then
6024           iti=itortyp(itype(i))
6025         else
6026           iti=ntortyp+1
6027         endif
6028         itk1=itortyp(itype(k+1))
6029         itj=itortyp(itype(j))
6030         if (l.lt.nres-1) then
6031           itl1=itortyp(itype(l+1))
6032         else
6033           itl1=ntortyp+1
6034         endif
6035 C A1 kernel(j+1) A2T
6036 cd        do iii=1,2
6037 cd          write (iout,'(3f10.5,5x,3f10.5)')
6038 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6039 cd        enddo
6040         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6041      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6042      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6043 C Following matrices are needed only for 6-th order cumulants
6044         IF (wcorr6.gt.0.0d0) THEN
6045         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6046      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6047      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6048         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6049      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6050      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6051      &   ADtEAderx(1,1,1,1,1,1))
6052         lprn=.false.
6053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6054      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6055      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6056      &   ADtEA1derx(1,1,1,1,1,1))
6057         ENDIF
6058 C End 6-th order cumulants
6059 cd        lprn=.false.
6060 cd        if (lprn) then
6061 cd        write (2,*) 'In calc_eello6'
6062 cd        do iii=1,2
6063 cd          write (2,*) 'iii=',iii
6064 cd          do kkk=1,5
6065 cd            write (2,*) 'kkk=',kkk
6066 cd            do jjj=1,2
6067 cd              write (2,'(3(2f10.5),5x)')
6068 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6069 cd            enddo
6070 cd          enddo
6071 cd        enddo
6072 cd        endif
6073         call transpose2(EUgder(1,1,k),auxmat(1,1))
6074         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6075         call transpose2(EUg(1,1,k),auxmat(1,1))
6076         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6077         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6078         do iii=1,2
6079           do kkk=1,5
6080             do lll=1,3
6081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6082      &          EAEAderx(1,1,lll,kkk,iii,1))
6083             enddo
6084           enddo
6085         enddo
6086 C A1T kernel(i+1) A2
6087         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6088      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6089      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6090 C Following matrices are needed only for 6-th order cumulants
6091         IF (wcorr6.gt.0.0d0) THEN
6092         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6093      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6094      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6096      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6097      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6098      &   ADtEAderx(1,1,1,1,1,2))
6099         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6100      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6101      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6102      &   ADtEA1derx(1,1,1,1,1,2))
6103         ENDIF
6104 C End 6-th order cumulants
6105         call transpose2(EUgder(1,1,l),auxmat(1,1))
6106         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6107         call transpose2(EUg(1,1,l),auxmat(1,1))
6108         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6109         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6110         do iii=1,2
6111           do kkk=1,5
6112             do lll=1,3
6113               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6114      &          EAEAderx(1,1,lll,kkk,iii,2))
6115             enddo
6116           enddo
6117         enddo
6118 C AEAb1 and AEAb2
6119 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6120 C They are needed only when the fifth- or the sixth-order cumulants are
6121 C indluded.
6122         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6123         call transpose2(AEA(1,1,1),auxmat(1,1))
6124         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6125         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6126         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6127         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6128         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6129         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6130         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6131         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6132         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6133         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6134         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6135         call transpose2(AEA(1,1,2),auxmat(1,1))
6136         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6137         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6138         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6139         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6140         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6141         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6142         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6143         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6144         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6145         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6146         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6147 C Calculate the Cartesian derivatives of the vectors.
6148         do iii=1,2
6149           do kkk=1,5
6150             do lll=1,3
6151               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6152               call matvec2(auxmat(1,1),b1(1,iti),
6153      &          AEAb1derx(1,lll,kkk,iii,1,1))
6154               call matvec2(auxmat(1,1),Ub2(1,i),
6155      &          AEAb2derx(1,lll,kkk,iii,1,1))
6156               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6157      &          AEAb1derx(1,lll,kkk,iii,2,1))
6158               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6159      &          AEAb2derx(1,lll,kkk,iii,2,1))
6160               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6161               call matvec2(auxmat(1,1),b1(1,itj),
6162      &          AEAb1derx(1,lll,kkk,iii,1,2))
6163               call matvec2(auxmat(1,1),Ub2(1,j),
6164      &          AEAb2derx(1,lll,kkk,iii,1,2))
6165               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6166      &          AEAb1derx(1,lll,kkk,iii,2,2))
6167               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6168      &          AEAb2derx(1,lll,kkk,iii,2,2))
6169             enddo
6170           enddo
6171         enddo
6172         ENDIF
6173 C End vectors
6174       else
6175 C Antiparallel orientation of the two CA-CA-CA frames.
6176         if (i.gt.1) then
6177           iti=itortyp(itype(i))
6178         else
6179           iti=ntortyp+1
6180         endif
6181         itk1=itortyp(itype(k+1))
6182         itl=itortyp(itype(l))
6183         itj=itortyp(itype(j))
6184         if (j.lt.nres-1) then
6185           itj1=itortyp(itype(j+1))
6186         else
6187           itj1=ntortyp+1
6188         endif
6189 C A2 kernel(j-1)T A1T
6190         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6191      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6192      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6193 C Following matrices are needed only for 6-th order cumulants
6194         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6195      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6196         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6197      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6198      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6199         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6200      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6201      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6202      &   ADtEAderx(1,1,1,1,1,1))
6203         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6204      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6205      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6206      &   ADtEA1derx(1,1,1,1,1,1))
6207         ENDIF
6208 C End 6-th order cumulants
6209         call transpose2(EUgder(1,1,k),auxmat(1,1))
6210         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6211         call transpose2(EUg(1,1,k),auxmat(1,1))
6212         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6213         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6214         do iii=1,2
6215           do kkk=1,5
6216             do lll=1,3
6217               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6218      &          EAEAderx(1,1,lll,kkk,iii,1))
6219             enddo
6220           enddo
6221         enddo
6222 C A2T kernel(i+1)T A1
6223         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6224      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6225      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6226 C Following matrices are needed only for 6-th order cumulants
6227         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6228      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6229         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6230      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6231      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6232         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6233      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6234      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6235      &   ADtEAderx(1,1,1,1,1,2))
6236         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6237      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6238      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6239      &   ADtEA1derx(1,1,1,1,1,2))
6240         ENDIF
6241 C End 6-th order cumulants
6242         call transpose2(EUgder(1,1,j),auxmat(1,1))
6243         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6244         call transpose2(EUg(1,1,j),auxmat(1,1))
6245         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6246         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6247         do iii=1,2
6248           do kkk=1,5
6249             do lll=1,3
6250               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6251      &          EAEAderx(1,1,lll,kkk,iii,2))
6252             enddo
6253           enddo
6254         enddo
6255 C AEAb1 and AEAb2
6256 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6257 C They are needed only when the fifth- or the sixth-order cumulants are
6258 C indluded.
6259         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6260      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6261         call transpose2(AEA(1,1,1),auxmat(1,1))
6262         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6263         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6264         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6265         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6266         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6267         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6268         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6269         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6270         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6271         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6272         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6273         call transpose2(AEA(1,1,2),auxmat(1,1))
6274         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6275         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6276         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6277         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6278         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6279         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6280         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6281         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6282         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6283         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6284         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6285 C Calculate the Cartesian derivatives of the vectors.
6286         do iii=1,2
6287           do kkk=1,5
6288             do lll=1,3
6289               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6290               call matvec2(auxmat(1,1),b1(1,iti),
6291      &          AEAb1derx(1,lll,kkk,iii,1,1))
6292               call matvec2(auxmat(1,1),Ub2(1,i),
6293      &          AEAb2derx(1,lll,kkk,iii,1,1))
6294               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6295      &          AEAb1derx(1,lll,kkk,iii,2,1))
6296               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6297      &          AEAb2derx(1,lll,kkk,iii,2,1))
6298               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6299               call matvec2(auxmat(1,1),b1(1,itl),
6300      &          AEAb1derx(1,lll,kkk,iii,1,2))
6301               call matvec2(auxmat(1,1),Ub2(1,l),
6302      &          AEAb2derx(1,lll,kkk,iii,1,2))
6303               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6304      &          AEAb1derx(1,lll,kkk,iii,2,2))
6305               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6306      &          AEAb2derx(1,lll,kkk,iii,2,2))
6307             enddo
6308           enddo
6309         enddo
6310         ENDIF
6311 C End vectors
6312       endif
6313       return
6314       end
6315 C---------------------------------------------------------------------------
6316       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6317      &  KK,KKderg,AKA,AKAderg,AKAderx)
6318       implicit none
6319       integer nderg
6320       logical transp
6321       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6322      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6323      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6324       integer iii,kkk,lll
6325       integer jjj,mmm
6326       logical lprn
6327       common /kutas/ lprn
6328       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6329       do iii=1,nderg
6330         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6331      &    AKAderg(1,1,iii))
6332       enddo
6333 cd      if (lprn) write (2,*) 'In kernel'
6334       do kkk=1,5
6335 cd        if (lprn) write (2,*) 'kkk=',kkk
6336         do lll=1,3
6337           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6338      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6339 cd          if (lprn) then
6340 cd            write (2,*) 'lll=',lll
6341 cd            write (2,*) 'iii=1'
6342 cd            do jjj=1,2
6343 cd              write (2,'(3(2f10.5),5x)')
6344 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6345 cd            enddo
6346 cd          endif
6347           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6348      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6349 cd          if (lprn) then
6350 cd            write (2,*) 'lll=',lll
6351 cd            write (2,*) 'iii=2'
6352 cd            do jjj=1,2
6353 cd              write (2,'(3(2f10.5),5x)')
6354 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6355 cd            enddo
6356 cd          endif
6357         enddo
6358       enddo
6359       return
6360       end
6361 C---------------------------------------------------------------------------
6362       double precision function eello4(i,j,k,l,jj,kk)
6363       implicit real*8 (a-h,o-z)
6364       include 'DIMENSIONS'
6365       include 'DIMENSIONS.ZSCOPT'
6366       include 'COMMON.IOUNITS'
6367       include 'COMMON.CHAIN'
6368       include 'COMMON.DERIV'
6369       include 'COMMON.INTERACT'
6370       include 'COMMON.CONTACTS'
6371       include 'COMMON.TORSION'
6372       include 'COMMON.VAR'
6373       include 'COMMON.GEO'
6374       double precision pizda(2,2),ggg1(3),ggg2(3)
6375 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6376 cd        eello4=0.0d0
6377 cd        return
6378 cd      endif
6379 cd      print *,'eello4:',i,j,k,l,jj,kk
6380 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6381 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6382 cold      eij=facont_hb(jj,i)
6383 cold      ekl=facont_hb(kk,k)
6384 cold      ekont=eij*ekl
6385       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6386       if (calc_grad) then
6387 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6388       gcorr_loc(k-1)=gcorr_loc(k-1)
6389      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6390       if (l.eq.j+1) then
6391         gcorr_loc(l-1)=gcorr_loc(l-1)
6392      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6393       else
6394         gcorr_loc(j-1)=gcorr_loc(j-1)
6395      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6396       endif
6397       do iii=1,2
6398         do kkk=1,5
6399           do lll=1,3
6400             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6401      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6402 cd            derx(lll,kkk,iii)=0.0d0
6403           enddo
6404         enddo
6405       enddo
6406 cd      gcorr_loc(l-1)=0.0d0
6407 cd      gcorr_loc(j-1)=0.0d0
6408 cd      gcorr_loc(k-1)=0.0d0
6409 cd      eel4=1.0d0
6410 cd      write (iout,*)'Contacts have occurred for peptide groups',
6411 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6412 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6413       if (j.lt.nres-1) then
6414         j1=j+1
6415         j2=j-1
6416       else
6417         j1=j-1
6418         j2=j-2
6419       endif
6420       if (l.lt.nres-1) then
6421         l1=l+1
6422         l2=l-1
6423       else
6424         l1=l-1
6425         l2=l-2
6426       endif
6427       do ll=1,3
6428 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6429         ggg1(ll)=eel4*g_contij(ll,1)
6430         ggg2(ll)=eel4*g_contij(ll,2)
6431         ghalf=0.5d0*ggg1(ll)
6432 cd        ghalf=0.0d0
6433         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6434         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6435         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6436         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6437 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6438         ghalf=0.5d0*ggg2(ll)
6439 cd        ghalf=0.0d0
6440         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6441         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6442         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6443         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6444       enddo
6445 cd      goto 1112
6446       do m=i+1,j-1
6447         do ll=1,3
6448 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6449           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6450         enddo
6451       enddo
6452       do m=k+1,l-1
6453         do ll=1,3
6454 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6455           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6456         enddo
6457       enddo
6458 1112  continue
6459       do m=i+2,j2
6460         do ll=1,3
6461           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6462         enddo
6463       enddo
6464       do m=k+2,l2
6465         do ll=1,3
6466           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6467         enddo
6468       enddo
6469 cd      do iii=1,nres-3
6470 cd        write (2,*) iii,gcorr_loc(iii)
6471 cd      enddo
6472       endif
6473       eello4=ekont*eel4
6474 cd      write (2,*) 'ekont',ekont
6475 cd      write (iout,*) 'eello4',ekont*eel4
6476       return
6477       end
6478 C---------------------------------------------------------------------------
6479       double precision function eello5(i,j,k,l,jj,kk)
6480       implicit real*8 (a-h,o-z)
6481       include 'DIMENSIONS'
6482       include 'DIMENSIONS.ZSCOPT'
6483       include 'COMMON.IOUNITS'
6484       include 'COMMON.CHAIN'
6485       include 'COMMON.DERIV'
6486       include 'COMMON.INTERACT'
6487       include 'COMMON.CONTACTS'
6488       include 'COMMON.TORSION'
6489       include 'COMMON.VAR'
6490       include 'COMMON.GEO'
6491       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6492       double precision ggg1(3),ggg2(3)
6493 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6494 C                                                                              C
6495 C                            Parallel chains                                   C
6496 C                                                                              C
6497 C          o             o                   o             o                   C
6498 C         /l\           / \             \   / \           / \   /              C
6499 C        /   \         /   \             \ /   \         /   \ /               C
6500 C       j| o |l1       | o |              o| o |         | o |o                C
6501 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6502 C      \i/   \         /   \ /             /   \         /   \                 C
6503 C       o    k1             o                                                  C
6504 C         (I)          (II)                (III)          (IV)                 C
6505 C                                                                              C
6506 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6507 C                                                                              C
6508 C                            Antiparallel chains                               C
6509 C                                                                              C
6510 C          o             o                   o             o                   C
6511 C         /j\           / \             \   / \           / \   /              C
6512 C        /   \         /   \             \ /   \         /   \ /               C
6513 C      j1| o |l        | o |              o| o |         | o |o                C
6514 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6515 C      \i/   \         /   \ /             /   \         /   \                 C
6516 C       o     k1            o                                                  C
6517 C         (I)          (II)                (III)          (IV)                 C
6518 C                                                                              C
6519 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6520 C                                                                              C
6521 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6522 C                                                                              C
6523 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6524 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6525 cd        eello5=0.0d0
6526 cd        return
6527 cd      endif
6528 cd      write (iout,*)
6529 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6530 cd     &   ' and',k,l
6531       itk=itortyp(itype(k))
6532       itl=itortyp(itype(l))
6533       itj=itortyp(itype(j))
6534       eello5_1=0.0d0
6535       eello5_2=0.0d0
6536       eello5_3=0.0d0
6537       eello5_4=0.0d0
6538 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6539 cd     &   eel5_3_num,eel5_4_num)
6540       do iii=1,2
6541         do kkk=1,5
6542           do lll=1,3
6543             derx(lll,kkk,iii)=0.0d0
6544           enddo
6545         enddo
6546       enddo
6547 cd      eij=facont_hb(jj,i)
6548 cd      ekl=facont_hb(kk,k)
6549 cd      ekont=eij*ekl
6550 cd      write (iout,*)'Contacts have occurred for peptide groups',
6551 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6552 cd      goto 1111
6553 C Contribution from the graph I.
6554 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6555 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6556       call transpose2(EUg(1,1,k),auxmat(1,1))
6557       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6558       vv(1)=pizda(1,1)-pizda(2,2)
6559       vv(2)=pizda(1,2)+pizda(2,1)
6560       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6561      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6562       if (calc_grad) then
6563 C Explicit gradient in virtual-dihedral angles.
6564       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6565      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6566      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6567       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6568       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6569       vv(1)=pizda(1,1)-pizda(2,2)
6570       vv(2)=pizda(1,2)+pizda(2,1)
6571       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6572      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6573      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6574       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6575       vv(1)=pizda(1,1)-pizda(2,2)
6576       vv(2)=pizda(1,2)+pizda(2,1)
6577       if (l.eq.j+1) then
6578         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6579      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6580      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6581       else
6582         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6583      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6584      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6585       endif
6586 C Cartesian gradient
6587       do iii=1,2
6588         do kkk=1,5
6589           do lll=1,3
6590             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6591      &        pizda(1,1))
6592             vv(1)=pizda(1,1)-pizda(2,2)
6593             vv(2)=pizda(1,2)+pizda(2,1)
6594             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6595      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6596      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6597           enddo
6598         enddo
6599       enddo
6600 c      goto 1112
6601       endif
6602 c1111  continue
6603 C Contribution from graph II
6604       call transpose2(EE(1,1,itk),auxmat(1,1))
6605       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6606       vv(1)=pizda(1,1)+pizda(2,2)
6607       vv(2)=pizda(2,1)-pizda(1,2)
6608       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6609      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6610       if (calc_grad) then
6611 C Explicit gradient in virtual-dihedral angles.
6612       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6613      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6614       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6615       vv(1)=pizda(1,1)+pizda(2,2)
6616       vv(2)=pizda(2,1)-pizda(1,2)
6617       if (l.eq.j+1) then
6618         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6619      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6620      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6621       else
6622         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6623      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6624      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6625       endif
6626 C Cartesian gradient
6627       do iii=1,2
6628         do kkk=1,5
6629           do lll=1,3
6630             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6631      &        pizda(1,1))
6632             vv(1)=pizda(1,1)+pizda(2,2)
6633             vv(2)=pizda(2,1)-pizda(1,2)
6634             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6635      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6636      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6637           enddo
6638         enddo
6639       enddo
6640 cd      goto 1112
6641       endif
6642 cd1111  continue
6643       if (l.eq.j+1) then
6644 cd        goto 1110
6645 C Parallel orientation
6646 C Contribution from graph III
6647         call transpose2(EUg(1,1,l),auxmat(1,1))
6648         call matmat2(AEA(1,1,2),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_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6652      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6653         if (calc_grad) then
6654 C Explicit gradient in virtual-dihedral angles.
6655         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6656      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6657      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6658         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6659         vv(1)=pizda(1,1)-pizda(2,2)
6660         vv(2)=pizda(1,2)+pizda(2,1)
6661         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6662      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6664         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6665         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6666         vv(1)=pizda(1,1)-pizda(2,2)
6667         vv(2)=pizda(1,2)+pizda(2,1)
6668         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6669      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6670      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6671 C Cartesian gradient
6672         do iii=1,2
6673           do kkk=1,5
6674             do lll=1,3
6675               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6676      &          pizda(1,1))
6677               vv(1)=pizda(1,1)-pizda(2,2)
6678               vv(2)=pizda(1,2)+pizda(2,1)
6679               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6680      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6681      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6682             enddo
6683           enddo
6684         enddo
6685 cd        goto 1112
6686         endif
6687 C Contribution from graph IV
6688 cd1110    continue
6689         call transpose2(EE(1,1,itl),auxmat(1,1))
6690         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6691         vv(1)=pizda(1,1)+pizda(2,2)
6692         vv(2)=pizda(2,1)-pizda(1,2)
6693         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6694      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6695         if (calc_grad) then
6696 C Explicit gradient in virtual-dihedral angles.
6697         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6698      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6699         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6700         vv(1)=pizda(1,1)+pizda(2,2)
6701         vv(2)=pizda(2,1)-pizda(1,2)
6702         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6703      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6704      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6705 C Cartesian gradient
6706         do iii=1,2
6707           do kkk=1,5
6708             do lll=1,3
6709               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6710      &          pizda(1,1))
6711               vv(1)=pizda(1,1)+pizda(2,2)
6712               vv(2)=pizda(2,1)-pizda(1,2)
6713               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6714      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6715      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6716             enddo
6717           enddo
6718         enddo
6719         endif
6720       else
6721 C Antiparallel orientation
6722 C Contribution from graph III
6723 c        goto 1110
6724         call transpose2(EUg(1,1,j),auxmat(1,1))
6725         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6726         vv(1)=pizda(1,1)-pizda(2,2)
6727         vv(2)=pizda(1,2)+pizda(2,1)
6728         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6730         if (calc_grad) then
6731 C Explicit gradient in virtual-dihedral angles.
6732         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6733      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6734      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6735         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6736         vv(1)=pizda(1,1)-pizda(2,2)
6737         vv(2)=pizda(1,2)+pizda(2,1)
6738         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6739      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6740      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6741         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6742         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6743         vv(1)=pizda(1,1)-pizda(2,2)
6744         vv(2)=pizda(1,2)+pizda(2,1)
6745         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6746      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6747      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6748 C Cartesian gradient
6749         do iii=1,2
6750           do kkk=1,5
6751             do lll=1,3
6752               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6753      &          pizda(1,1))
6754               vv(1)=pizda(1,1)-pizda(2,2)
6755               vv(2)=pizda(1,2)+pizda(2,1)
6756               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6757      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6758      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6759             enddo
6760           enddo
6761         enddo
6762 cd        goto 1112
6763         endif
6764 C Contribution from graph IV
6765 1110    continue
6766         call transpose2(EE(1,1,itj),auxmat(1,1))
6767         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6768         vv(1)=pizda(1,1)+pizda(2,2)
6769         vv(2)=pizda(2,1)-pizda(1,2)
6770         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6771      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6772         if (calc_grad) then
6773 C Explicit gradient in virtual-dihedral angles.
6774         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6775      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6776         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6777         vv(1)=pizda(1,1)+pizda(2,2)
6778         vv(2)=pizda(2,1)-pizda(1,2)
6779         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6780      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6781      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6782 C Cartesian gradient
6783         do iii=1,2
6784           do kkk=1,5
6785             do lll=1,3
6786               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6787      &          pizda(1,1))
6788               vv(1)=pizda(1,1)+pizda(2,2)
6789               vv(2)=pizda(2,1)-pizda(1,2)
6790               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6791      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6792      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6793             enddo
6794           enddo
6795         enddo
6796       endif
6797       endif
6798 1112  continue
6799       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6800 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6801 cd        write (2,*) 'ijkl',i,j,k,l
6802 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6803 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6804 cd      endif
6805 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6806 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6807 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6808 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6809       if (calc_grad) then
6810       if (j.lt.nres-1) then
6811         j1=j+1
6812         j2=j-1
6813       else
6814         j1=j-1
6815         j2=j-2
6816       endif
6817       if (l.lt.nres-1) then
6818         l1=l+1
6819         l2=l-1
6820       else
6821         l1=l-1
6822         l2=l-2
6823       endif
6824 cd      eij=1.0d0
6825 cd      ekl=1.0d0
6826 cd      ekont=1.0d0
6827 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6828       do ll=1,3
6829         ggg1(ll)=eel5*g_contij(ll,1)
6830         ggg2(ll)=eel5*g_contij(ll,2)
6831 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6832         ghalf=0.5d0*ggg1(ll)
6833 cd        ghalf=0.0d0
6834         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6835         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6836         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6837         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6838 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6839         ghalf=0.5d0*ggg2(ll)
6840 cd        ghalf=0.0d0
6841         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6842         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6843         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6844         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6845       enddo
6846 cd      goto 1112
6847       do m=i+1,j-1
6848         do ll=1,3
6849 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6850           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6851         enddo
6852       enddo
6853       do m=k+1,l-1
6854         do ll=1,3
6855 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6856           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6857         enddo
6858       enddo
6859 c1112  continue
6860       do m=i+2,j2
6861         do ll=1,3
6862           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6863         enddo
6864       enddo
6865       do m=k+2,l2
6866         do ll=1,3
6867           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6868         enddo
6869       enddo
6870 cd      do iii=1,nres-3
6871 cd        write (2,*) iii,g_corr5_loc(iii)
6872 cd      enddo
6873       endif
6874       eello5=ekont*eel5
6875 cd      write (2,*) 'ekont',ekont
6876 cd      write (iout,*) 'eello5',ekont*eel5
6877       return
6878       end
6879 c--------------------------------------------------------------------------
6880       double precision function eello6(i,j,k,l,jj,kk)
6881       implicit real*8 (a-h,o-z)
6882       include 'DIMENSIONS'
6883       include 'DIMENSIONS.ZSCOPT'
6884       include 'COMMON.IOUNITS'
6885       include 'COMMON.CHAIN'
6886       include 'COMMON.DERIV'
6887       include 'COMMON.INTERACT'
6888       include 'COMMON.CONTACTS'
6889       include 'COMMON.TORSION'
6890       include 'COMMON.VAR'
6891       include 'COMMON.GEO'
6892       include 'COMMON.FFIELD'
6893       double precision ggg1(3),ggg2(3)
6894 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6895 cd        eello6=0.0d0
6896 cd        return
6897 cd      endif
6898 cd      write (iout,*)
6899 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6900 cd     &   ' and',k,l
6901       eello6_1=0.0d0
6902       eello6_2=0.0d0
6903       eello6_3=0.0d0
6904       eello6_4=0.0d0
6905       eello6_5=0.0d0
6906       eello6_6=0.0d0
6907 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6908 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6909       do iii=1,2
6910         do kkk=1,5
6911           do lll=1,3
6912             derx(lll,kkk,iii)=0.0d0
6913           enddo
6914         enddo
6915       enddo
6916 cd      eij=facont_hb(jj,i)
6917 cd      ekl=facont_hb(kk,k)
6918 cd      ekont=eij*ekl
6919 cd      eij=1.0d0
6920 cd      ekl=1.0d0
6921 cd      ekont=1.0d0
6922       if (l.eq.j+1) then
6923         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6924         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6925         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6926         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6927         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6928         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6929       else
6930         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6931         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6932         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6933         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6934         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6935           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6936         else
6937           eello6_5=0.0d0
6938         endif
6939         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6940       endif
6941 C If turn contributions are considered, they will be handled separately.
6942       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6943 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6944 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6945 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6946 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6947 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6948 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6949 cd      goto 1112
6950       if (calc_grad) then
6951       if (j.lt.nres-1) then
6952         j1=j+1
6953         j2=j-1
6954       else
6955         j1=j-1
6956         j2=j-2
6957       endif
6958       if (l.lt.nres-1) then
6959         l1=l+1
6960         l2=l-1
6961       else
6962         l1=l-1
6963         l2=l-2
6964       endif
6965       do ll=1,3
6966         ggg1(ll)=eel6*g_contij(ll,1)
6967         ggg2(ll)=eel6*g_contij(ll,2)
6968 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6969         ghalf=0.5d0*ggg1(ll)
6970 cd        ghalf=0.0d0
6971         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6972         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6973         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6974         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6975         ghalf=0.5d0*ggg2(ll)
6976 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6977 cd        ghalf=0.0d0
6978         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6979         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6980         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6981         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6982       enddo
6983 cd      goto 1112
6984       do m=i+1,j-1
6985         do ll=1,3
6986 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6987           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6988         enddo
6989       enddo
6990       do m=k+1,l-1
6991         do ll=1,3
6992 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6993           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6994         enddo
6995       enddo
6996 1112  continue
6997       do m=i+2,j2
6998         do ll=1,3
6999           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7000         enddo
7001       enddo
7002       do m=k+2,l2
7003         do ll=1,3
7004           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7005         enddo
7006       enddo
7007 cd      do iii=1,nres-3
7008 cd        write (2,*) iii,g_corr6_loc(iii)
7009 cd      enddo
7010       endif
7011       eello6=ekont*eel6
7012 cd      write (2,*) 'ekont',ekont
7013 cd      write (iout,*) 'eello6',ekont*eel6
7014       return
7015       end
7016 c--------------------------------------------------------------------------
7017       double precision function eello6_graph1(i,j,k,l,imat,swap)
7018       implicit real*8 (a-h,o-z)
7019       include 'DIMENSIONS'
7020       include 'DIMENSIONS.ZSCOPT'
7021       include 'COMMON.IOUNITS'
7022       include 'COMMON.CHAIN'
7023       include 'COMMON.DERIV'
7024       include 'COMMON.INTERACT'
7025       include 'COMMON.CONTACTS'
7026       include 'COMMON.TORSION'
7027       include 'COMMON.VAR'
7028       include 'COMMON.GEO'
7029       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7030       logical swap
7031       logical lprn
7032       common /kutas/ lprn
7033 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7034 C                                                                              C
7035 C      Parallel       Antiparallel                                             C
7036 C                                                                              C
7037 C          o             o                                                     C
7038 C         /l\           /j\                                                    C
7039 C        /   \         /   \                                                   C
7040 C       /| o |         | o |\                                                  C
7041 C     \ j|/k\|  /   \  |/k\|l /                                                C
7042 C      \ /   \ /     \ /   \ /                                                 C
7043 C       o     o       o     o                                                  C
7044 C       i             i                                                        C
7045 C                                                                              C
7046 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7047       itk=itortyp(itype(k))
7048       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7049       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7050       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7051       call transpose2(EUgC(1,1,k),auxmat(1,1))
7052       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7053       vv1(1)=pizda1(1,1)-pizda1(2,2)
7054       vv1(2)=pizda1(1,2)+pizda1(2,1)
7055       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7056       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7057       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7058       s5=scalar2(vv(1),Dtobr2(1,i))
7059 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7060       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7061       if (.not. calc_grad) return
7062       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7063      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7064      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7065      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7066      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7067      & +scalar2(vv(1),Dtobr2der(1,i)))
7068       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7069       vv1(1)=pizda1(1,1)-pizda1(2,2)
7070       vv1(2)=pizda1(1,2)+pizda1(2,1)
7071       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7072       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7073       if (l.eq.j+1) then
7074         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7075      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7076      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7077      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7078      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7079       else
7080         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7081      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7082      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7083      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7084      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7085       endif
7086       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7087       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7088       vv1(1)=pizda1(1,1)-pizda1(2,2)
7089       vv1(2)=pizda1(1,2)+pizda1(2,1)
7090       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7091      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7092      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7093      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7094       do iii=1,2
7095         if (swap) then
7096           ind=3-iii
7097         else
7098           ind=iii
7099         endif
7100         do kkk=1,5
7101           do lll=1,3
7102             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7103             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7104             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7105             call transpose2(EUgC(1,1,k),auxmat(1,1))
7106             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7107      &        pizda1(1,1))
7108             vv1(1)=pizda1(1,1)-pizda1(2,2)
7109             vv1(2)=pizda1(1,2)+pizda1(2,1)
7110             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7111             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7112      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7113             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7114      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7115             s5=scalar2(vv(1),Dtobr2(1,i))
7116             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7117           enddo
7118         enddo
7119       enddo
7120       return
7121       end
7122 c----------------------------------------------------------------------------
7123       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7124       implicit real*8 (a-h,o-z)
7125       include 'DIMENSIONS'
7126       include 'DIMENSIONS.ZSCOPT'
7127       include 'COMMON.IOUNITS'
7128       include 'COMMON.CHAIN'
7129       include 'COMMON.DERIV'
7130       include 'COMMON.INTERACT'
7131       include 'COMMON.CONTACTS'
7132       include 'COMMON.TORSION'
7133       include 'COMMON.VAR'
7134       include 'COMMON.GEO'
7135       logical swap
7136       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7137      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7138       logical lprn
7139       common /kutas/ lprn
7140 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7141 C                                                                              C
7142 C      Parallel       Antiparallel                                             C
7143 C                                                                              C
7144 C          o             o                                                     C
7145 C     \   /l\           /j\   /                                                C
7146 C      \ /   \         /   \ /                                                 C
7147 C       o| o |         | o |o                                                  C
7148 C     \ j|/k\|      \  |/k\|l                                                  C
7149 C      \ /   \       \ /   \                                                   C
7150 C       o             o                                                        C
7151 C       i             i                                                        C
7152 C                                                                              C
7153 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7154 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7155 C AL 7/4/01 s1 would occur in the sixth-order moment,
7156 C           but not in a cluster cumulant
7157 #ifdef MOMENT
7158       s1=dip(1,jj,i)*dip(1,kk,k)
7159 #endif
7160       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7161       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7162       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7163       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7164       call transpose2(EUg(1,1,k),auxmat(1,1))
7165       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7166       vv(1)=pizda(1,1)-pizda(2,2)
7167       vv(2)=pizda(1,2)+pizda(2,1)
7168       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7169 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7170 #ifdef MOMENT
7171       eello6_graph2=-(s1+s2+s3+s4)
7172 #else
7173       eello6_graph2=-(s2+s3+s4)
7174 #endif
7175 c      eello6_graph2=-s3
7176       if (.not. calc_grad) return
7177 C Derivatives in gamma(i-1)
7178       if (i.gt.1) then
7179 #ifdef MOMENT
7180         s1=dipderg(1,jj,i)*dip(1,kk,k)
7181 #endif
7182         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7183         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7184         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7185         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7186 #ifdef MOMENT
7187         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7188 #else
7189         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7190 #endif
7191 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7192       endif
7193 C Derivatives in gamma(k-1)
7194 #ifdef MOMENT
7195       s1=dip(1,jj,i)*dipderg(1,kk,k)
7196 #endif
7197       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7198       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7199       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7200       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7201       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7202       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7203       vv(1)=pizda(1,1)-pizda(2,2)
7204       vv(2)=pizda(1,2)+pizda(2,1)
7205       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7206 #ifdef MOMENT
7207       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7208 #else
7209       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7210 #endif
7211 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7212 C Derivatives in gamma(j-1) or gamma(l-1)
7213       if (j.gt.1) then
7214 #ifdef MOMENT
7215         s1=dipderg(3,jj,i)*dip(1,kk,k)
7216 #endif
7217         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7218         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7219         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7220         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7221         vv(1)=pizda(1,1)-pizda(2,2)
7222         vv(2)=pizda(1,2)+pizda(2,1)
7223         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7224 #ifdef MOMENT
7225         if (swap) then
7226           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7227         else
7228           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7229         endif
7230 #endif
7231         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7232 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7233       endif
7234 C Derivatives in gamma(l-1) or gamma(j-1)
7235       if (l.gt.1) then
7236 #ifdef MOMENT
7237         s1=dip(1,jj,i)*dipderg(3,kk,k)
7238 #endif
7239         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7240         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7241         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7242         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7243         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7244         vv(1)=pizda(1,1)-pizda(2,2)
7245         vv(2)=pizda(1,2)+pizda(2,1)
7246         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7247 #ifdef MOMENT
7248         if (swap) then
7249           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7250         else
7251           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7252         endif
7253 #endif
7254         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7255 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7256       endif
7257 C Cartesian derivatives.
7258       if (lprn) then
7259         write (2,*) 'In eello6_graph2'
7260         do iii=1,2
7261           write (2,*) 'iii=',iii
7262           do kkk=1,5
7263             write (2,*) 'kkk=',kkk
7264             do jjj=1,2
7265               write (2,'(3(2f10.5),5x)')
7266      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7267             enddo
7268           enddo
7269         enddo
7270       endif
7271       do iii=1,2
7272         do kkk=1,5
7273           do lll=1,3
7274 #ifdef MOMENT
7275             if (iii.eq.1) then
7276               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7277             else
7278               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7279             endif
7280 #endif
7281             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7282      &        auxvec(1))
7283             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7284             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7285      &        auxvec(1))
7286             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7287             call transpose2(EUg(1,1,k),auxmat(1,1))
7288             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7289      &        pizda(1,1))
7290             vv(1)=pizda(1,1)-pizda(2,2)
7291             vv(2)=pizda(1,2)+pizda(2,1)
7292             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7293 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7294 #ifdef MOMENT
7295             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7296 #else
7297             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7298 #endif
7299             if (swap) then
7300               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7301             else
7302               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7303             endif
7304           enddo
7305         enddo
7306       enddo
7307       return
7308       end
7309 c----------------------------------------------------------------------------
7310       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7311       implicit real*8 (a-h,o-z)
7312       include 'DIMENSIONS'
7313       include 'DIMENSIONS.ZSCOPT'
7314       include 'COMMON.IOUNITS'
7315       include 'COMMON.CHAIN'
7316       include 'COMMON.DERIV'
7317       include 'COMMON.INTERACT'
7318       include 'COMMON.CONTACTS'
7319       include 'COMMON.TORSION'
7320       include 'COMMON.VAR'
7321       include 'COMMON.GEO'
7322       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7323       logical swap
7324 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7325 C                                                                              C
7326 C      Parallel       Antiparallel                                             C
7327 C                                                                              C
7328 C          o             o                                                     C
7329 C         /l\   /   \   /j\                                                    C
7330 C        /   \ /     \ /   \                                                   C
7331 C       /| o |o       o| o |\                                                  C
7332 C       j|/k\|  /      |/k\|l /                                                C
7333 C        /   \ /       /   \ /                                                 C
7334 C       /     o       /     o                                                  C
7335 C       i             i                                                        C
7336 C                                                                              C
7337 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7338 C
7339 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7340 C           energy moment and not to the cluster cumulant.
7341       iti=itortyp(itype(i))
7342       if (j.lt.nres-1) then
7343         itj1=itortyp(itype(j+1))
7344       else
7345         itj1=ntortyp+1
7346       endif
7347       itk=itortyp(itype(k))
7348       itk1=itortyp(itype(k+1))
7349       if (l.lt.nres-1) then
7350         itl1=itortyp(itype(l+1))
7351       else
7352         itl1=ntortyp+1
7353       endif
7354 #ifdef MOMENT
7355       s1=dip(4,jj,i)*dip(4,kk,k)
7356 #endif
7357       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7358       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7359       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7360       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7361       call transpose2(EE(1,1,itk),auxmat(1,1))
7362       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7363       vv(1)=pizda(1,1)+pizda(2,2)
7364       vv(2)=pizda(2,1)-pizda(1,2)
7365       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7366 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7367 #ifdef MOMENT
7368       eello6_graph3=-(s1+s2+s3+s4)
7369 #else
7370       eello6_graph3=-(s2+s3+s4)
7371 #endif
7372 c      eello6_graph3=-s4
7373       if (.not. calc_grad) return
7374 C Derivatives in gamma(k-1)
7375       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7376       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7377       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7378       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7379 C Derivatives in gamma(l-1)
7380       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7381       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7382       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7383       vv(1)=pizda(1,1)+pizda(2,2)
7384       vv(2)=pizda(2,1)-pizda(1,2)
7385       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7386       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7387 C Cartesian derivatives.
7388       do iii=1,2
7389         do kkk=1,5
7390           do lll=1,3
7391 #ifdef MOMENT
7392             if (iii.eq.1) then
7393               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7394             else
7395               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7396             endif
7397 #endif
7398             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7399      &        auxvec(1))
7400             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7401             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7402      &        auxvec(1))
7403             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7404             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7405      &        pizda(1,1))
7406             vv(1)=pizda(1,1)+pizda(2,2)
7407             vv(2)=pizda(2,1)-pizda(1,2)
7408             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7409 #ifdef MOMENT
7410             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7411 #else
7412             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7413 #endif
7414             if (swap) then
7415               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7416             else
7417               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7418             endif
7419 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7420           enddo
7421         enddo
7422       enddo
7423       return
7424       end
7425 c----------------------------------------------------------------------------
7426       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7427       implicit real*8 (a-h,o-z)
7428       include 'DIMENSIONS'
7429       include 'DIMENSIONS.ZSCOPT'
7430       include 'COMMON.IOUNITS'
7431       include 'COMMON.CHAIN'
7432       include 'COMMON.DERIV'
7433       include 'COMMON.INTERACT'
7434       include 'COMMON.CONTACTS'
7435       include 'COMMON.TORSION'
7436       include 'COMMON.VAR'
7437       include 'COMMON.GEO'
7438       include 'COMMON.FFIELD'
7439       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7440      & auxvec1(2),auxmat1(2,2)
7441       logical swap
7442 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7443 C                                                                              C
7444 C      Parallel       Antiparallel                                             C
7445 C                                                                              C
7446 C          o             o                                                     C
7447 C         /l\   /   \   /j\                                                    C
7448 C        /   \ /     \ /   \                                                   C
7449 C       /| o |o       o| o |\                                                  C
7450 C     \ j|/k\|      \  |/k\|l                                                  C
7451 C      \ /   \       \ /   \                                                   C
7452 C       o     \       o     \                                                  C
7453 C       i             i                                                        C
7454 C                                                                              C
7455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7456 C
7457 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7458 C           energy moment and not to the cluster cumulant.
7459 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7460       iti=itortyp(itype(i))
7461       itj=itortyp(itype(j))
7462       if (j.lt.nres-1) then
7463         itj1=itortyp(itype(j+1))
7464       else
7465         itj1=ntortyp+1
7466       endif
7467       itk=itortyp(itype(k))
7468       if (k.lt.nres-1) then
7469         itk1=itortyp(itype(k+1))
7470       else
7471         itk1=ntortyp+1
7472       endif
7473       itl=itortyp(itype(l))
7474       if (l.lt.nres-1) then
7475         itl1=itortyp(itype(l+1))
7476       else
7477         itl1=ntortyp+1
7478       endif
7479 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7480 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7481 cd     & ' itl',itl,' itl1',itl1
7482 #ifdef MOMENT
7483       if (imat.eq.1) then
7484         s1=dip(3,jj,i)*dip(3,kk,k)
7485       else
7486         s1=dip(2,jj,j)*dip(2,kk,l)
7487       endif
7488 #endif
7489       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7490       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7491       if (j.eq.l+1) then
7492         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7493         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7494       else
7495         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7496         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7497       endif
7498       call transpose2(EUg(1,1,k),auxmat(1,1))
7499       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7500       vv(1)=pizda(1,1)-pizda(2,2)
7501       vv(2)=pizda(2,1)+pizda(1,2)
7502       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7503 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7504 #ifdef MOMENT
7505       eello6_graph4=-(s1+s2+s3+s4)
7506 #else
7507       eello6_graph4=-(s2+s3+s4)
7508 #endif
7509       if (.not. calc_grad) return
7510 C Derivatives in gamma(i-1)
7511       if (i.gt.1) then
7512 #ifdef MOMENT
7513         if (imat.eq.1) then
7514           s1=dipderg(2,jj,i)*dip(3,kk,k)
7515         else
7516           s1=dipderg(4,jj,j)*dip(2,kk,l)
7517         endif
7518 #endif
7519         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7520         if (j.eq.l+1) then
7521           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7522           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7523         else
7524           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7525           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7526         endif
7527         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7528         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7529 cd          write (2,*) 'turn6 derivatives'
7530 #ifdef MOMENT
7531           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7532 #else
7533           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7534 #endif
7535         else
7536 #ifdef MOMENT
7537           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7538 #else
7539           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7540 #endif
7541         endif
7542       endif
7543 C Derivatives in gamma(k-1)
7544 #ifdef MOMENT
7545       if (imat.eq.1) then
7546         s1=dip(3,jj,i)*dipderg(2,kk,k)
7547       else
7548         s1=dip(2,jj,j)*dipderg(4,kk,l)
7549       endif
7550 #endif
7551       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7552       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7553       if (j.eq.l+1) then
7554         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7555         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7556       else
7557         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7558         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7559       endif
7560       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7561       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7562       vv(1)=pizda(1,1)-pizda(2,2)
7563       vv(2)=pizda(2,1)+pizda(1,2)
7564       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7565       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7566 #ifdef MOMENT
7567         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7568 #else
7569         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7570 #endif
7571       else
7572 #ifdef MOMENT
7573         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7574 #else
7575         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7576 #endif
7577       endif
7578 C Derivatives in gamma(j-1) or gamma(l-1)
7579       if (l.eq.j+1 .and. l.gt.1) then
7580         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7581         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7582         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7583         vv(1)=pizda(1,1)-pizda(2,2)
7584         vv(2)=pizda(2,1)+pizda(1,2)
7585         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7586         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7587       else if (j.gt.1) then
7588         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7589         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7590         call matmat2(AECAderg(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         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7595           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7596         else
7597           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7598         endif
7599       endif
7600 C Cartesian derivatives.
7601       do iii=1,2
7602         do kkk=1,5
7603           do lll=1,3
7604 #ifdef MOMENT
7605             if (iii.eq.1) then
7606               if (imat.eq.1) then
7607                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7608               else
7609                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7610               endif
7611             else
7612               if (imat.eq.1) then
7613                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7614               else
7615                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7616               endif
7617             endif
7618 #endif
7619             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7620      &        auxvec(1))
7621             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7622             if (j.eq.l+1) then
7623               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7624      &          b1(1,itj1),auxvec(1))
7625               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7626             else
7627               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7628      &          b1(1,itl1),auxvec(1))
7629               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7630             endif
7631             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7632      &        pizda(1,1))
7633             vv(1)=pizda(1,1)-pizda(2,2)
7634             vv(2)=pizda(2,1)+pizda(1,2)
7635             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7636             if (swap) then
7637               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7638 #ifdef MOMENT
7639                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7640      &             -(s1+s2+s4)
7641 #else
7642                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7643      &             -(s2+s4)
7644 #endif
7645                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7646               else
7647 #ifdef MOMENT
7648                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7649 #else
7650                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7651 #endif
7652                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7653               endif
7654             else
7655 #ifdef MOMENT
7656               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7657 #else
7658               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7659 #endif
7660               if (l.eq.j+1) then
7661                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7662               else
7663                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7664               endif
7665             endif
7666           enddo
7667         enddo
7668       enddo
7669       return
7670       end
7671 c----------------------------------------------------------------------------
7672       double precision function eello_turn6(i,jj,kk)
7673       implicit real*8 (a-h,o-z)
7674       include 'DIMENSIONS'
7675       include 'DIMENSIONS.ZSCOPT'
7676       include 'COMMON.IOUNITS'
7677       include 'COMMON.CHAIN'
7678       include 'COMMON.DERIV'
7679       include 'COMMON.INTERACT'
7680       include 'COMMON.CONTACTS'
7681       include 'COMMON.TORSION'
7682       include 'COMMON.VAR'
7683       include 'COMMON.GEO'
7684       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7685      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7686      &  ggg1(3),ggg2(3)
7687       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7688      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7689 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7690 C           the respective energy moment and not to the cluster cumulant.
7691       eello_turn6=0.0d0
7692       j=i+4
7693       k=i+1
7694       l=i+3
7695       iti=itortyp(itype(i))
7696       itk=itortyp(itype(k))
7697       itk1=itortyp(itype(k+1))
7698       itl=itortyp(itype(l))
7699       itj=itortyp(itype(j))
7700 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7701 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7702 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7703 cd        eello6=0.0d0
7704 cd        return
7705 cd      endif
7706 cd      write (iout,*)
7707 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7708 cd     &   ' and',k,l
7709 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7710       do iii=1,2
7711         do kkk=1,5
7712           do lll=1,3
7713             derx_turn(lll,kkk,iii)=0.0d0
7714           enddo
7715         enddo
7716       enddo
7717 cd      eij=1.0d0
7718 cd      ekl=1.0d0
7719 cd      ekont=1.0d0
7720       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7721 cd      eello6_5=0.0d0
7722 cd      write (2,*) 'eello6_5',eello6_5
7723 #ifdef MOMENT
7724       call transpose2(AEA(1,1,1),auxmat(1,1))
7725       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7726       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7727       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7728 #else
7729       s1 = 0.0d0
7730 #endif
7731       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7732       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7733       s2 = scalar2(b1(1,itk),vtemp1(1))
7734 #ifdef MOMENT
7735       call transpose2(AEA(1,1,2),atemp(1,1))
7736       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7737       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7738       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7739 #else
7740       s8=0.0d0
7741 #endif
7742       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7743       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7744       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7745 #ifdef MOMENT
7746       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7747       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7748       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7749       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7750       ss13 = scalar2(b1(1,itk),vtemp4(1))
7751       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7752 #else
7753       s13=0.0d0
7754 #endif
7755 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7756 c      s1=0.0d0
7757 c      s2=0.0d0
7758 c      s8=0.0d0
7759 c      s12=0.0d0
7760 c      s13=0.0d0
7761       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7762       if (calc_grad) then
7763 C Derivatives in gamma(i+2)
7764 #ifdef MOMENT
7765       call transpose2(AEA(1,1,1),auxmatd(1,1))
7766       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7767       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7768       call transpose2(AEAderg(1,1,2),atempd(1,1))
7769       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7770       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7771 #else
7772       s8d=0.0d0
7773 #endif
7774       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7775       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7776       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7777 c      s1d=0.0d0
7778 c      s2d=0.0d0
7779 c      s8d=0.0d0
7780 c      s12d=0.0d0
7781 c      s13d=0.0d0
7782       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7783 C Derivatives in gamma(i+3)
7784 #ifdef MOMENT
7785       call transpose2(AEA(1,1,1),auxmatd(1,1))
7786       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7787       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7788       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7789 #else
7790       s1d=0.0d0
7791 #endif
7792       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7793       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7794       s2d = scalar2(b1(1,itk),vtemp1d(1))
7795 #ifdef MOMENT
7796       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7797       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7798 #endif
7799       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7800 #ifdef MOMENT
7801       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7802       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7803       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7804 #else
7805       s13d=0.0d0
7806 #endif
7807 c      s1d=0.0d0
7808 c      s2d=0.0d0
7809 c      s8d=0.0d0
7810 c      s12d=0.0d0
7811 c      s13d=0.0d0
7812 #ifdef MOMENT
7813       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7814      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7815 #else
7816       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7817      &               -0.5d0*ekont*(s2d+s12d)
7818 #endif
7819 C Derivatives in gamma(i+4)
7820       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7821       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7822       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7823 #ifdef MOMENT
7824       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7825       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7826       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7827 #else
7828       s13d = 0.0d0
7829 #endif
7830 c      s1d=0.0d0
7831 c      s2d=0.0d0
7832 c      s8d=0.0d0
7833 C      s12d=0.0d0
7834 c      s13d=0.0d0
7835 #ifdef MOMENT
7836       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7837 #else
7838       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7839 #endif
7840 C Derivatives in gamma(i+5)
7841 #ifdef MOMENT
7842       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7843       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7844       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7845 #else
7846       s1d = 0.0d0
7847 #endif
7848       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7849       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7850       s2d = scalar2(b1(1,itk),vtemp1d(1))
7851 #ifdef MOMENT
7852       call transpose2(AEA(1,1,2),atempd(1,1))
7853       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7854       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7855 #else
7856       s8d = 0.0d0
7857 #endif
7858       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7859       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7860 #ifdef MOMENT
7861       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7862       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7863       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7864 #else
7865       s13d = 0.0d0
7866 #endif
7867 c      s1d=0.0d0
7868 c      s2d=0.0d0
7869 c      s8d=0.0d0
7870 c      s12d=0.0d0
7871 c      s13d=0.0d0
7872 #ifdef MOMENT
7873       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7874      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7875 #else
7876       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7877      &               -0.5d0*ekont*(s2d+s12d)
7878 #endif
7879 C Cartesian derivatives
7880       do iii=1,2
7881         do kkk=1,5
7882           do lll=1,3
7883 #ifdef MOMENT
7884             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7885             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7886             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7887 #else
7888             s1d = 0.0d0
7889 #endif
7890             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7891             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7892      &          vtemp1d(1))
7893             s2d = scalar2(b1(1,itk),vtemp1d(1))
7894 #ifdef MOMENT
7895             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7896             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7897             s8d = -(atempd(1,1)+atempd(2,2))*
7898      &           scalar2(cc(1,1,itl),vtemp2(1))
7899 #else
7900             s8d = 0.0d0
7901 #endif
7902             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7903      &           auxmatd(1,1))
7904             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7905             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7906 c      s1d=0.0d0
7907 c      s2d=0.0d0
7908 c      s8d=0.0d0
7909 c      s12d=0.0d0
7910 c      s13d=0.0d0
7911 #ifdef MOMENT
7912             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7913      &        - 0.5d0*(s1d+s2d)
7914 #else
7915             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7916      &        - 0.5d0*s2d
7917 #endif
7918 #ifdef MOMENT
7919             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7920      &        - 0.5d0*(s8d+s12d)
7921 #else
7922             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7923      &        - 0.5d0*s12d
7924 #endif
7925           enddo
7926         enddo
7927       enddo
7928 #ifdef MOMENT
7929       do kkk=1,5
7930         do lll=1,3
7931           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7932      &      achuj_tempd(1,1))
7933           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7934           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7935           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7936           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7937           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7938      &      vtemp4d(1))
7939           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7940           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7941           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7942         enddo
7943       enddo
7944 #endif
7945 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7946 cd     &  16*eel_turn6_num
7947 cd      goto 1112
7948       if (j.lt.nres-1) then
7949         j1=j+1
7950         j2=j-1
7951       else
7952         j1=j-1
7953         j2=j-2
7954       endif
7955       if (l.lt.nres-1) then
7956         l1=l+1
7957         l2=l-1
7958       else
7959         l1=l-1
7960         l2=l-2
7961       endif
7962       do ll=1,3
7963         ggg1(ll)=eel_turn6*g_contij(ll,1)
7964         ggg2(ll)=eel_turn6*g_contij(ll,2)
7965         ghalf=0.5d0*ggg1(ll)
7966 cd        ghalf=0.0d0
7967         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7968      &    +ekont*derx_turn(ll,2,1)
7969         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7970         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7971      &    +ekont*derx_turn(ll,4,1)
7972         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7973         ghalf=0.5d0*ggg2(ll)
7974 cd        ghalf=0.0d0
7975         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7976      &    +ekont*derx_turn(ll,2,2)
7977         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7978         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7979      &    +ekont*derx_turn(ll,4,2)
7980         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7981       enddo
7982 cd      goto 1112
7983       do m=i+1,j-1
7984         do ll=1,3
7985           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7986         enddo
7987       enddo
7988       do m=k+1,l-1
7989         do ll=1,3
7990           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7991         enddo
7992       enddo
7993 1112  continue
7994       do m=i+2,j2
7995         do ll=1,3
7996           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7997         enddo
7998       enddo
7999       do m=k+2,l2
8000         do ll=1,3
8001           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8002         enddo
8003       enddo
8004 cd      do iii=1,nres-3
8005 cd        write (2,*) iii,g_corr6_loc(iii)
8006 cd      enddo
8007       endif
8008       eello_turn6=ekont*eel_turn6
8009 cd      write (2,*) 'ekont',ekont
8010 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8011       return
8012       end
8013 crc-------------------------------------------------
8014       SUBROUTINE MATVEC2(A1,V1,V2)
8015       implicit real*8 (a-h,o-z)
8016       include 'DIMENSIONS'
8017       DIMENSION A1(2,2),V1(2),V2(2)
8018 c      DO 1 I=1,2
8019 c        VI=0.0
8020 c        DO 3 K=1,2
8021 c    3     VI=VI+A1(I,K)*V1(K)
8022 c        Vaux(I)=VI
8023 c    1 CONTINUE
8024
8025       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8026       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8027
8028       v2(1)=vaux1
8029       v2(2)=vaux2
8030       END
8031 C---------------------------------------
8032       SUBROUTINE MATMAT2(A1,A2,A3)
8033       implicit real*8 (a-h,o-z)
8034       include 'DIMENSIONS'
8035       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8036 c      DIMENSION AI3(2,2)
8037 c        DO  J=1,2
8038 c          A3IJ=0.0
8039 c          DO K=1,2
8040 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8041 c          enddo
8042 c          A3(I,J)=A3IJ
8043 c       enddo
8044 c      enddo
8045
8046       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8047       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8048       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8049       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8050
8051       A3(1,1)=AI3_11
8052       A3(2,1)=AI3_21
8053       A3(1,2)=AI3_12
8054       A3(2,2)=AI3_22
8055       END
8056
8057 c-------------------------------------------------------------------------
8058       double precision function scalar2(u,v)
8059       implicit none
8060       double precision u(2),v(2)
8061       double precision sc
8062       integer i
8063       scalar2=u(1)*v(1)+u(2)*v(2)
8064       return
8065       end
8066
8067 C-----------------------------------------------------------------------------
8068
8069       subroutine transpose2(a,at)
8070       implicit none
8071       double precision a(2,2),at(2,2)
8072       at(1,1)=a(1,1)
8073       at(1,2)=a(2,1)
8074       at(2,1)=a(1,2)
8075       at(2,2)=a(2,2)
8076       return
8077       end
8078 c--------------------------------------------------------------------------
8079       subroutine transpose(n,a,at)
8080       implicit none
8081       integer n,i,j
8082       double precision a(n,n),at(n,n)
8083       do i=1,n
8084         do j=1,n
8085           at(j,i)=a(i,j)
8086         enddo
8087       enddo
8088       return
8089       end
8090 C---------------------------------------------------------------------------
8091       subroutine prodmat3(a1,a2,kk,transp,prod)
8092       implicit none
8093       integer i,j
8094       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8095       logical transp
8096 crc      double precision auxmat(2,2),prod_(2,2)
8097
8098       if (transp) then
8099 crc        call transpose2(kk(1,1),auxmat(1,1))
8100 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8101 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8102
8103            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8104      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8105            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8106      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8107            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8108      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8109            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8110      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8111
8112       else
8113 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8114 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8115
8116            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8117      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8118            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8119      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8120            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8121      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8122            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8123      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8124
8125       endif
8126 c      call transpose2(a2(1,1),a2t(1,1))
8127
8128 crc      print *,transp
8129 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8130 crc      print *,((prod(i,j),i=1,2),j=1,2)
8131
8132       return
8133       end
8134 C-----------------------------------------------------------------------------
8135       double precision function scalar(u,v)
8136       implicit none
8137       double precision u(3),v(3)
8138       double precision sc
8139       integer i
8140       sc=0.0d0
8141       do i=1,3
8142         sc=sc+u(i)*v(i)
8143       enddo
8144       scalar=sc
8145       return
8146       end
8147