source/wham/src-restraints/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
 118 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 119 #ifdef SPLITELE
 120       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 121      & +wvdwpp*evdw1
 122      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 123      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 124      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 125      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 126      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 127      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 128 #else
 129       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 130      & +welec*fact(1)*(ees+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 #endif
 138       energia(0)=etot
 139       energia(1)=evdw
 140 #ifdef SCP14
 141       energia(2)=evdw2-evdw2_14
 142       energia(17)=evdw2_14
 143 #else
 144       energia(2)=evdw2
 145       energia(17)=0.0d0
 146 #endif
 147 #ifdef SPLITELE
 148       energia(3)=ees
 149       energia(16)=evdw1
 150 #else
 151       energia(3)=ees+evdw1
 152       energia(16)=0.0d0
 153 #endif
 154       energia(4)=ecorr
 155       energia(5)=ecorr5
 156       energia(6)=ecorr6
 157       energia(7)=eel_loc
 158       energia(8)=eello_turn3
 159       energia(9)=eello_turn4
 160       energia(10)=eturn6
 161       energia(11)=ebe
 162       energia(12)=escloc
 163       energia(13)=etors
 164       energia(14)=etors_d
 165       energia(15)=ehpb
 166       energia(18)=estr
 167       energia(19)=esccor
 168       energia(20)=edihcnstr
 169       energia(21)=evdw_t
 170       energia(22)=ehomology_constr
 171 c      if (dyn_ss) call dyn_set_nss
 172 c detecting NaNQ
 173 #ifdef ISNAN
 174 #ifdef AIX
 175       if (isnan(etot).ne.0) energia(0)=1.0d+99
 176 #else
 177       if (isnan(etot)) energia(0)=1.0d+99
 178 #endif
 179 #else
 180       i=0
 181 #ifdef WINPGI
 182       idumm=proc_proc(etot,i)
 183 #else
 184       call proc_proc(etot,i)
 185 #endif
 186       if(i.eq.1)energia(0)=1.0d+99
 187 #endif
 188 #ifdef MPL
 189 c     endif
 190 #endif
 191       if (calc_grad) then
 192 C
 193 C Sum up the components of the Cartesian gradient.
 194 C
 195 #ifdef SPLITELE
 196       do i=1,nct
 197         do j=1,3
 198           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 199      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 200      &                wbond*gradb(j,i)+
 201      &                wstrain*ghpbc(j,i)+
 202      &                wcorr*fact(3)*gradcorr(j,i)+
 203      &                wel_loc*fact(2)*gel_loc(j,i)+
 204      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 205      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 206      &                wcorr5*fact(4)*gradcorr5(j,i)+
 207      &                wcorr6*fact(5)*gradcorr6(j,i)+
 208      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 209      &                wsccor*fact(2)*gsccorc(j,i)
 210           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 211      &                  wbond*gradbx(j,i)+
 212      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 213      &                  wsccor*fact(2)*gsccorx(j,i)
 214         enddo
 215 #else
 216       do i=1,nct
 217         do j=1,3
 218           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 219      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 220      &                wbond*gradb(j,i)+
 221      &                wcorr*fact(3)*gradcorr(j,i)+
 222      &                wel_loc*fact(2)*gel_loc(j,i)+
 223      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 224      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 225      &                wcorr5*fact(4)*gradcorr5(j,i)+
 226      &                wcorr6*fact(5)*gradcorr6(j,i)+
 227      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 228      &                wsccor*fact(2)*gsccorc(j,i)
 229           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 230      &                  wbond*gradbx(j,i)+
 231      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 232      &                  wsccor*fact(1)*gsccorx(j,i)
 233         enddo
 234 #endif
 235       enddo
 236
 237
 238       do i=1,nres-3
 239         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 240      &   +wcorr5*fact(4)*g_corr5_loc(i)
 241      &   +wcorr6*fact(5)*g_corr6_loc(i)
 242      &   +wturn4*fact(3)*gel_loc_turn4(i)
 243      &   +wturn3*fact(2)*gel_loc_turn3(i)
 244      &   +wturn6*fact(5)*gel_loc_turn6(i)
 245      &   +wel_loc*fact(2)*gel_loc_loc(i)
 246      &   +wsccor*fact(1)*gsccor_loc(i)
 247       enddo
 248       endif
 249       return
 250       end
 251 C------------------------------------------------------------------------
 252       subroutine enerprint(energia,fact)
 253       implicit real*8 (a-h,o-z)
 254       include 'DIMENSIONS'
 255       include 'DIMENSIONS.ZSCOPT'
 256       include 'COMMON.IOUNITS'
 257       include 'COMMON.FFIELD'
 258       include 'COMMON.SBRIDGE'
 259       double precision energia(0:max_ene),fact(6)
 260       etot=energia(0)
 261       evdw=energia(1)+fact(6)*energia(21)
 262 #ifdef SCP14
 263       evdw2=energia(2)+energia(17)
 264 #else
 265       evdw2=energia(2)
 266 #endif
 267       ees=energia(3)
 268 #ifdef SPLITELE
 269       evdw1=energia(16)
 270 #endif
 271       ecorr=energia(4)
 272       ecorr5=energia(5)
 273       ecorr6=energia(6)
 274       eel_loc=energia(7)
 275       eello_turn3=energia(8)
 276       eello_turn4=energia(9)
 277       eello_turn6=energia(10)
 278       ebe=energia(11)
 279       escloc=energia(12)
 280       etors=energia(13)
 281       etors_d=energia(14)
 282       ehpb=energia(15)
 283       esccor=energia(19)
 284       edihcnstr=energia(20)
 285       estr=energia(18)
 286       ehomology_constr=energia(22)
 287 #ifdef SPLITELE
 288       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 289      &  wvdwpp,
 290      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 291      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 292      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 293      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 294      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 295      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,etot
 296    10 format (/'Virtual-chain energies:'//
 297      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 298      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 299      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 300      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 301      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 302      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 303      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 304      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 305      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 306      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 307      & ' (SS bridges & dist. cnstr.)'/
 308      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 309      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 310      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 311      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 312      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 313      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 314      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 315      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 316      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 317      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 318      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 319      & 'ETOT=  ',1pE16.6,' (total)')
 320 #else
 321       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 322      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 323      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 324      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 325      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 326      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 327      &  edihcnstr,ehomology_constr,ebr*nss,etot
 328    10 format (/'Virtual-chain energies:'//
 329      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 330      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 331      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 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      & 'ETOT=  ',1pE16.6,' (total)')
 351 #endif
 352       return
 353       end
 354 C-----------------------------------------------------------------------
 355       subroutine elj(evdw,evdw_t)
 356 C
 357 C This subroutine calculates the interaction energy of nonbonded side chains
 358 C assuming the LJ potential of interaction.
 359 C
 360       implicit real*8 (a-h,o-z)
 361       include 'DIMENSIONS'
 362       include 'DIMENSIONS.ZSCOPT'
 363       include "DIMENSIONS.COMPAR"
 364       parameter (accur=1.0d-10)
 365       include 'COMMON.GEO'
 366       include 'COMMON.VAR'
 367       include 'COMMON.LOCAL'
 368       include 'COMMON.CHAIN'
 369       include 'COMMON.DERIV'
 370       include 'COMMON.INTERACT'
 371       include 'COMMON.TORSION'
 372       include 'COMMON.ENEPS'
 373       include 'COMMON.SBRIDGE'
 374       include 'COMMON.NAMES'
 375       include 'COMMON.IOUNITS'
 376       include 'COMMON.CONTACTS'
 377       dimension gg(3)
 378       integer icant
 379       external icant
 380 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 381       do i=1,210
 382         do j=1,2
 383           eneps_temp(j,i)=0.0d0
 384         enddo
 385       enddo
 386       evdw=0.0D0
 387       evdw_t=0.0d0
 388       do i=iatsc_s,iatsc_e
 389         itypi=itype(i)
 390         itypi1=itype(i+1)
 391         xi=c(1,nres+i)
 392         yi=c(2,nres+i)
 393         zi=c(3,nres+i)
 394 C Change 12/1/95
 395         num_conti=0
 396 C
 397 C Calculate SC interaction energy.
 398 C
 399         do iint=1,nint_gr(i)
 400 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 401 cd   &                  'iend=',iend(i,iint)
 402           do j=istart(i,iint),iend(i,iint)
 403             itypj=itype(j)
 404             xj=c(1,nres+j)-xi
 405             yj=c(2,nres+j)-yi
 406             zj=c(3,nres+j)-zi
 407 C Change 12/1/95 to calculate four-body interactions
 408             rij=xj*xj+yj*yj+zj*zj
 409             rrij=1.0D0/rij
 410 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 411             eps0ij=eps(itypi,itypj)
 412             fac=rrij**expon2
 413             e1=fac*fac*aa(itypi,itypj)
 414             e2=fac*bb(itypi,itypj)
 415             evdwij=e1+e2
 416             ij=icant(itypi,itypj)
 417             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 418             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 419 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 420 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 421 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 422 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 423 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 424 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 425             if (bb(itypi,itypj).gt.0.0d0) then
 426               evdw=evdw+evdwij
 427             else
 428               evdw_t=evdw_t+evdwij
 429             endif
 430             if (calc_grad) then
 431 C
 432 C Calculate the components of the gradient in DC and X
 433 C
 434             fac=-rrij*(e1+evdwij)
 435             gg(1)=xj*fac
 436             gg(2)=yj*fac
 437             gg(3)=zj*fac
 438             do k=1,3
 439               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 440               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 441             enddo
 442             do k=i,j-1
 443               do l=1,3
 444                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 445               enddo
 446             enddo
 447             endif
 448 C
 449 C 12/1/95, revised on 5/20/97
 450 C
 451 C Calculate the contact function. The ith column of the array JCONT will
 452 C contain the numbers of atoms that make contacts with the atom I (of numbers
 453 C greater than I). The arrays FACONT and GACONT will contain the values of
 454 C the contact function and its derivative.
 455 C
 456 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 457 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 458 C Uncomment next line, if the correlation interactions are contact function only
 459             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 460               rij=dsqrt(rij)
 461               sigij=sigma(itypi,itypj)
 462               r0ij=rs0(itypi,itypj)
 463 C
 464 C Check whether the SC's are not too far to make a contact.
 465 C
 466               rcut=1.5d0*r0ij
 467               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 468 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 469 C
 470               if (fcont.gt.0.0D0) then
 471 C If the SC-SC distance if close to sigma, apply spline.
 472 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 473 cAdam &             fcont1,fprimcont1)
 474 cAdam           fcont1=1.0d0-fcont1
 475 cAdam           if (fcont1.gt.0.0d0) then
 476 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 477 cAdam             fcont=fcont*fcont1
 478 cAdam           endif
 479 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 480 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 481 cga             do k=1,3
 482 cga               gg(k)=gg(k)*eps0ij
 483 cga             enddo
 484 cga             eps0ij=-evdwij*eps0ij
 485 C Uncomment for AL's type of SC correlation interactions.
 486 cadam           eps0ij=-evdwij
 487                 num_conti=num_conti+1
 488                 jcont(num_conti,i)=j
 489                 facont(num_conti,i)=fcont*eps0ij
 490                 fprimcont=eps0ij*fprimcont/rij
 491                 fcont=expon*fcont
 492 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 493 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 494 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 495 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 496                 gacont(1,num_conti,i)=-fprimcont*xj
 497                 gacont(2,num_conti,i)=-fprimcont*yj
 498                 gacont(3,num_conti,i)=-fprimcont*zj
 499 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 500 cd              write (iout,'(2i3,3f10.5)')
 501 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 502               endif
 503             endif
 504           enddo      ! j
 505         enddo        ! iint
 506 C Change 12/1/95
 507         num_cont(i)=num_conti
 508       enddo          ! i
 509       if (calc_grad) then
 510       do i=1,nct
 511         do j=1,3
 512           gvdwc(j,i)=expon*gvdwc(j,i)
 513           gvdwx(j,i)=expon*gvdwx(j,i)
 514         enddo
 515       enddo
 516       endif
 517 C******************************************************************************
 518 C
 519 C                              N O T E !!!
 520 C
 521 C To save time, the factor of EXPON has been extracted from ALL components
 522 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 523 C use!
 524 C
 525 C******************************************************************************
 526       return
 527       end
 528 C-----------------------------------------------------------------------------
 529       subroutine eljk(evdw,evdw_t)
 530 C
 531 C This subroutine calculates the interaction energy of nonbonded side chains
 532 C assuming the LJK potential of interaction.
 533 C
 534       implicit real*8 (a-h,o-z)
 535       include 'DIMENSIONS'
 536       include 'DIMENSIONS.ZSCOPT'
 537       include "DIMENSIONS.COMPAR"
 538       include 'COMMON.GEO'
 539       include 'COMMON.VAR'
 540       include 'COMMON.LOCAL'
 541       include 'COMMON.CHAIN'
 542       include 'COMMON.DERIV'
 543       include 'COMMON.INTERACT'
 544       include 'COMMON.ENEPS'
 545       include 'COMMON.IOUNITS'
 546       include 'COMMON.NAMES'
 547       dimension gg(3)
 548       logical scheck
 549       integer icant
 550       external icant
 551 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 552       do i=1,210
 553         do j=1,2
 554           eneps_temp(j,i)=0.0d0
 555         enddo
 556       enddo
 557       evdw=0.0D0
 558       evdw_t=0.0d0
 559       do i=iatsc_s,iatsc_e
 560         itypi=itype(i)
 561         itypi1=itype(i+1)
 562         xi=c(1,nres+i)
 563         yi=c(2,nres+i)
 564         zi=c(3,nres+i)
 565 C
 566 C Calculate SC interaction energy.
 567 C
 568         do iint=1,nint_gr(i)
 569           do j=istart(i,iint),iend(i,iint)
 570             itypj=itype(j)
 571             xj=c(1,nres+j)-xi
 572             yj=c(2,nres+j)-yi
 573             zj=c(3,nres+j)-zi
 574             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 575             fac_augm=rrij**expon
 576             e_augm=augm(itypi,itypj)*fac_augm
 577             r_inv_ij=dsqrt(rrij)
 578             rij=1.0D0/r_inv_ij
 579             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 580             fac=r_shift_inv**expon
 581             e1=fac*fac*aa(itypi,itypj)
 582             e2=fac*bb(itypi,itypj)
 583             evdwij=e_augm+e1+e2
 584             ij=icant(itypi,itypj)
 585             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 586      &        /dabs(eps(itypi,itypj))
 587             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 588 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 589 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 590 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 591 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 592 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 593 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 594 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 595             if (bb(itypi,itypj).gt.0.0d0) then
 596               evdw=evdw+evdwij
 597             else
 598               evdw_t=evdw_t+evdwij
 599             endif
 600             if (calc_grad) then
 601 C
 602 C Calculate the components of the gradient in DC and X
 603 C
 604             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 605             gg(1)=xj*fac
 606             gg(2)=yj*fac
 607             gg(3)=zj*fac
 608             do k=1,3
 609               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 610               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 611             enddo
 612             do k=i,j-1
 613               do l=1,3
 614                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 615               enddo
 616             enddo
 617             endif
 618           enddo      ! j
 619         enddo        ! iint
 620       enddo          ! i
 621       if (calc_grad) then
 622       do i=1,nct
 623         do j=1,3
 624           gvdwc(j,i)=expon*gvdwc(j,i)
 625           gvdwx(j,i)=expon*gvdwx(j,i)
 626         enddo
 627       enddo
 628       endif
 629       return
 630       end
 631 C-----------------------------------------------------------------------------
 632       subroutine ebp(evdw,evdw_t)
 633 C
 634 C This subroutine calculates the interaction energy of nonbonded side chains
 635 C assuming the Berne-Pechukas potential of interaction.
 636 C
 637       implicit real*8 (a-h,o-z)
 638       include 'DIMENSIONS'
 639       include 'DIMENSIONS.ZSCOPT'
 640       include "DIMENSIONS.COMPAR"
 641       include 'COMMON.GEO'
 642       include 'COMMON.VAR'
 643       include 'COMMON.LOCAL'
 644       include 'COMMON.CHAIN'
 645       include 'COMMON.DERIV'
 646       include 'COMMON.NAMES'
 647       include 'COMMON.INTERACT'
 648       include 'COMMON.ENEPS'
 649       include 'COMMON.IOUNITS'
 650       include 'COMMON.CALC'
 651       common /srutu/ icall
 652 c     double precision rrsave(maxdim)
 653       logical lprn
 654       integer icant
 655       external icant
 656       do i=1,210
 657         do j=1,2
 658           eneps_temp(j,i)=0.0d0
 659         enddo
 660       enddo
 661       evdw=0.0D0
 662       evdw_t=0.0d0
 663 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 664 c     if (icall.eq.0) then
 665 c       lprn=.true.
 666 c     else
 667         lprn=.false.
 668 c     endif
 669       ind=0
 670       do i=iatsc_s,iatsc_e
 671         itypi=itype(i)
 672         itypi1=itype(i+1)
 673         xi=c(1,nres+i)
 674         yi=c(2,nres+i)
 675         zi=c(3,nres+i)
 676         dxi=dc_norm(1,nres+i)
 677         dyi=dc_norm(2,nres+i)
 678         dzi=dc_norm(3,nres+i)
 679         dsci_inv=vbld_inv(i+nres)
 680 C
 681 C Calculate SC interaction energy.
 682 C
 683         do iint=1,nint_gr(i)
 684           do j=istart(i,iint),iend(i,iint)
 685             ind=ind+1
 686             itypj=itype(j)
 687             dscj_inv=vbld_inv(j+nres)
 688             chi1=chi(itypi,itypj)
 689             chi2=chi(itypj,itypi)
 690             chi12=chi1*chi2
 691             chip1=chip(itypi)
 692             chip2=chip(itypj)
 693             chip12=chip1*chip2
 694             alf1=alp(itypi)
 695             alf2=alp(itypj)
 696             alf12=0.5D0*(alf1+alf2)
 697 C For diagnostics only!!!
 698 c           chi1=0.0D0
 699 c           chi2=0.0D0
 700 c           chi12=0.0D0
 701 c           chip1=0.0D0
 702 c           chip2=0.0D0
 703 c           chip12=0.0D0
 704 c           alf1=0.0D0
 705 c           alf2=0.0D0
 706 c           alf12=0.0D0
 707             xj=c(1,nres+j)-xi
 708             yj=c(2,nres+j)-yi
 709             zj=c(3,nres+j)-zi
 710             dxj=dc_norm(1,nres+j)
 711             dyj=dc_norm(2,nres+j)
 712             dzj=dc_norm(3,nres+j)
 713             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 714 cd          if (icall.eq.0) then
 715 cd            rrsave(ind)=rrij
 716 cd          else
 717 cd            rrij=rrsave(ind)
 718 cd          endif
 719             rij=dsqrt(rrij)
 720 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 721             call sc_angular
 722 C Calculate whole angle-dependent part of epsilon and contributions
 723 C to its derivatives
 724             fac=(rrij*sigsq)**expon2
 725             e1=fac*fac*aa(itypi,itypj)
 726             e2=fac*bb(itypi,itypj)
 727             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 728             eps2der=evdwij*eps3rt
 729             eps3der=evdwij*eps2rt
 730             evdwij=evdwij*eps2rt*eps3rt
 731             ij=icant(itypi,itypj)
 732             aux=eps1*eps2rt**2*eps3rt**2
 733             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 734      &        /dabs(eps(itypi,itypj))
 735             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 736             if (bb(itypi,itypj).gt.0.0d0) then
 737               evdw=evdw+evdwij
 738             else
 739               evdw_t=evdw_t+evdwij
 740             endif
 741             if (calc_grad) then
 742             if (lprn) then
 743             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 744             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 745 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 746 cd     &        restyp(itypi),i,restyp(itypj),j,
 747 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 748 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 749 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 750 cd     &        evdwij
 751             endif
 752 C Calculate gradient components.
 753             e1=e1*eps1*eps2rt**2*eps3rt**2
 754             fac=-expon*(e1+evdwij)
 755             sigder=fac/sigsq
 756             fac=rrij*fac
 757 C Calculate radial part of the gradient
 758             gg(1)=xj*fac
 759             gg(2)=yj*fac
 760             gg(3)=zj*fac
 761 C Calculate the angular part of the gradient and sum add the contributions
 762 C to the appropriate components of the Cartesian gradient.
 763             call sc_grad
 764             endif
 765           enddo      ! j
 766         enddo        ! iint
 767       enddo          ! i
 768 c     stop
 769       return
 770       end
 771 C-----------------------------------------------------------------------------
 772       subroutine egb(evdw,evdw_t)
 773 C
 774 C This subroutine calculates the interaction energy of nonbonded side chains
 775 C assuming the Gay-Berne potential of interaction.
 776 C
 777       implicit real*8 (a-h,o-z)
 778       include 'DIMENSIONS'
 779       include 'DIMENSIONS.ZSCOPT'
 780       include "DIMENSIONS.COMPAR"
 781       include 'COMMON.GEO'
 782       include 'COMMON.VAR'
 783       include 'COMMON.LOCAL'
 784       include 'COMMON.CHAIN'
 785       include 'COMMON.DERIV'
 786       include 'COMMON.NAMES'
 787       include 'COMMON.INTERACT'
 788       include 'COMMON.ENEPS'
 789       include 'COMMON.IOUNITS'
 790       include 'COMMON.CALC'
 791       include 'COMMON.SBRIDGE'
 792       logical lprn
 793       common /srutu/icall
 794       integer icant
 795       external icant
 796       do i=1,210
 797         do j=1,2
 798           eneps_temp(j,i)=0.0d0
 799         enddo
 800       enddo
 801 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 802       evdw=0.0D0
 803       evdw_t=0.0d0
 804       lprn=.false.
 805 c      if (icall.gt.0) lprn=.true.
 806       ind=0
 807       do i=iatsc_s,iatsc_e
 808         itypi=itype(i)
 809         itypi1=itype(i+1)
 810         xi=c(1,nres+i)
 811         yi=c(2,nres+i)
 812         zi=c(3,nres+i)
 813         dxi=dc_norm(1,nres+i)
 814         dyi=dc_norm(2,nres+i)
 815         dzi=dc_norm(3,nres+i)
 816         dsci_inv=vbld_inv(i+nres)
 817 C
 818 C Calculate SC interaction energy.
 819 C
 820         do iint=1,nint_gr(i)
 821           do j=istart(i,iint),iend(i,iint)
 822 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 823 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 824 C formation no electrostatic interactions should be calculated. If it
 825 C would be allowed NaN would appear
 826             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 827 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 828 C residue can or cannot form disulfide bond. There is still bug allowing
 829 C Cys...Cys...Cys bond formation
 830               call dyn_ssbond_ene(i,j,evdwij)
 831 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 832 C function in ssMD.F
 833               evdw=evdw+evdwij
 834 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 835 c     &                        'evdw',i,j,evdwij,' ss'
 836             ELSE
 837             ind=ind+1
 838             itypj=itype(j)
 839             dscj_inv=vbld_inv(j+nres)
 840             sig0ij=sigma(itypi,itypj)
 841             chi1=chi(itypi,itypj)
 842             chi2=chi(itypj,itypi)
 843             chi12=chi1*chi2
 844             chip1=chip(itypi)
 845             chip2=chip(itypj)
 846             chip12=chip1*chip2
 847             alf1=alp(itypi)
 848             alf2=alp(itypj)
 849             alf12=0.5D0*(alf1+alf2)
 850 C For diagnostics only!!!
 851 c           chi1=0.0D0
 852 c           chi2=0.0D0
 853 c           chi12=0.0D0
 854 c           chip1=0.0D0
 855 c           chip2=0.0D0
 856 c           chip12=0.0D0
 857 c           alf1=0.0D0
 858 c           alf2=0.0D0
 859 c           alf12=0.0D0
 860             xj=c(1,nres+j)-xi
 861             yj=c(2,nres+j)-yi
 862             zj=c(3,nres+j)-zi
 863             dxj=dc_norm(1,nres+j)
 864             dyj=dc_norm(2,nres+j)
 865             dzj=dc_norm(3,nres+j)
 866 c            write (iout,*) i,j,xj,yj,zj
 867             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 868             rij=dsqrt(rrij)
 869 C Calculate angle-dependent terms of energy and contributions to their
 870 C derivatives.
 871             call sc_angular
 872             sigsq=1.0D0/sigsq
 873             sig=sig0ij*dsqrt(sigsq)
 874             rij_shift=1.0D0/rij-sig+sig0ij
 875 C I hate to put IF's in the loops, but here don't have another choice!!!!
 876             if (rij_shift.le.0.0D0) then
 877               evdw=1.0D20
 878               return
 879             endif
 880             sigder=-sig*sigsq
 881 c---------------------------------------------------------------
 882             rij_shift=1.0D0/rij_shift
 883             fac=rij_shift**expon
 884             e1=fac*fac*aa(itypi,itypj)
 885             e2=fac*bb(itypi,itypj)
 886             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 887             eps2der=evdwij*eps3rt
 888             eps3der=evdwij*eps2rt
 889             evdwij=evdwij*eps2rt*eps3rt
 890             if (bb(itypi,itypj).gt.0) then
 891               evdw=evdw+evdwij
 892             else
 893               evdw_t=evdw_t+evdwij
 894             endif
 895             ij=icant(itypi,itypj)
 896             aux=eps1*eps2rt**2*eps3rt**2
 897             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 898      &        /dabs(eps(itypi,itypj))
 899             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 900 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 901 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 902 c     &         aux*e2/eps(itypi,itypj)
 903 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 904             if (lprn) then
 905             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 906             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 907             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 908      &        restyp(itypi),i,restyp(itypj),j,
 909      &        epsi,sigm,chi1,chi2,chip1,chip2,
 910      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 911      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 912      &        evdwij
 913             endif
 914             if (calc_grad) then
 915 C Calculate gradient components.
 916             e1=e1*eps1*eps2rt**2*eps3rt**2
 917             fac=-expon*(e1+evdwij)*rij_shift
 918             sigder=fac*sigder
 919             fac=rij*fac
 920 C Calculate the radial part of the gradient
 921             gg(1)=xj*fac
 922             gg(2)=yj*fac
 923             gg(3)=zj*fac
 924 C Calculate angular part of the gradient.
 925             call sc_grad
 926             endif
 927             ENDIF    ! dyn_ss
 928           enddo      ! j
 929         enddo        ! iint
 930       enddo          ! i
 931       return
 932       end
 933 C-----------------------------------------------------------------------------
 934       subroutine egbv(evdw,evdw_t)
 935 C
 936 C This subroutine calculates the interaction energy of nonbonded side chains
 937 C assuming the Gay-Berne-Vorobjev potential of interaction.
 938 C
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'DIMENSIONS.ZSCOPT'
 942       include "DIMENSIONS.COMPAR"
 943       include 'COMMON.GEO'
 944       include 'COMMON.VAR'
 945       include 'COMMON.LOCAL'
 946       include 'COMMON.CHAIN'
 947       include 'COMMON.DERIV'
 948       include 'COMMON.NAMES'
 949       include 'COMMON.INTERACT'
 950       include 'COMMON.ENEPS'
 951       include 'COMMON.IOUNITS'
 952       include 'COMMON.CALC'
 953       common /srutu/ icall
 954       logical lprn
 955       integer icant
 956       external icant
 957       do i=1,210
 958         do j=1,2
 959           eneps_temp(j,i)=0.0d0
 960         enddo
 961       enddo
 962       evdw=0.0D0
 963       evdw_t=0.0d0
 964 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 965       evdw=0.0D0
 966       lprn=.false.
 967 c      if (icall.gt.0) lprn=.true.
 968       ind=0
 969       do i=iatsc_s,iatsc_e
 970         itypi=itype(i)
 971         itypi1=itype(i+1)
 972         xi=c(1,nres+i)
 973         yi=c(2,nres+i)
 974         zi=c(3,nres+i)
 975         dxi=dc_norm(1,nres+i)
 976         dyi=dc_norm(2,nres+i)
 977         dzi=dc_norm(3,nres+i)
 978         dsci_inv=vbld_inv(i+nres)
 979 C
 980 C Calculate SC interaction energy.
 981 C
 982         do iint=1,nint_gr(i)
 983           do j=istart(i,iint),iend(i,iint)
 984             ind=ind+1
 985             itypj=itype(j)
 986             dscj_inv=vbld_inv(j+nres)
 987             sig0ij=sigma(itypi,itypj)
 988             r0ij=r0(itypi,itypj)
 989             chi1=chi(itypi,itypj)
 990             chi2=chi(itypj,itypi)
 991             chi12=chi1*chi2
 992             chip1=chip(itypi)
 993             chip2=chip(itypj)
 994             chip12=chip1*chip2
 995             alf1=alp(itypi)
 996             alf2=alp(itypj)
 997             alf12=0.5D0*(alf1+alf2)
 998 C For diagnostics only!!!
 999 c           chi1=0.0D0
1000 c           chi2=0.0D0
1001 c           chi12=0.0D0
1002 c           chip1=0.0D0
1003 c           chip2=0.0D0
1004 c           chip12=0.0D0
1005 c           alf1=0.0D0
1006 c           alf2=0.0D0
1007 c           alf12=0.0D0
1008             xj=c(1,nres+j)-xi
1009             yj=c(2,nres+j)-yi
1010             zj=c(3,nres+j)-zi
1011             dxj=dc_norm(1,nres+j)
1012             dyj=dc_norm(2,nres+j)
1013             dzj=dc_norm(3,nres+j)
1014             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1015             rij=dsqrt(rrij)
1016 C Calculate angle-dependent terms of energy and contributions to their
1017 C derivatives.
1018             call sc_angular
1019             sigsq=1.0D0/sigsq
1020             sig=sig0ij*dsqrt(sigsq)
1021             rij_shift=1.0D0/rij-sig+r0ij
1022 C I hate to put IF's in the loops, but here don't have another choice!!!!
1023             if (rij_shift.le.0.0D0) then
1024               evdw=1.0D20
1025               return
1026             endif
1027             sigder=-sig*sigsq
1028 c---------------------------------------------------------------
1029             rij_shift=1.0D0/rij_shift
1030             fac=rij_shift**expon
1031             e1=fac*fac*aa(itypi,itypj)
1032             e2=fac*bb(itypi,itypj)
1033             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1034             eps2der=evdwij*eps3rt
1035             eps3der=evdwij*eps2rt
1036             fac_augm=rrij**expon
1037             e_augm=augm(itypi,itypj)*fac_augm
1038             evdwij=evdwij*eps2rt*eps3rt
1039             if (bb(itypi,itypj).gt.0.0d0) then
1040               evdw=evdw+evdwij+e_augm
1041             else
1042               evdw_t=evdw_t+evdwij+e_augm
1043             endif
1044             ij=icant(itypi,itypj)
1045             aux=eps1*eps2rt**2*eps3rt**2
1046             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1047      &        /dabs(eps(itypi,itypj))
1048             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1049 c            eneps_temp(ij)=eneps_temp(ij)
1050 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1051 c            if (lprn) then
1052 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1053 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1054 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1055 c     &        restyp(itypi),i,restyp(itypj),j,
1056 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1057 c     &        chi1,chi2,chip1,chip2,
1058 c     &        eps1,eps2rt**2,eps3rt**2,
1059 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1060 c     &        evdwij+e_augm
1061 c            endif
1062             if (calc_grad) then
1063 C Calculate gradient components.
1064             e1=e1*eps1*eps2rt**2*eps3rt**2
1065             fac=-expon*(e1+evdwij)*rij_shift
1066             sigder=fac*sigder
1067             fac=rij*fac-2*expon*rrij*e_augm
1068 C Calculate the radial part of the gradient
1069             gg(1)=xj*fac
1070             gg(2)=yj*fac
1071             gg(3)=zj*fac
1072 C Calculate angular part of the gradient.
1073             call sc_grad
1074             endif
1075           enddo      ! j
1076         enddo        ! iint
1077       enddo          ! i
1078       return
1079       end
1080 C-----------------------------------------------------------------------------
1081       subroutine sc_angular
1082 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1083 C om12. Called by ebp, egb, and egbv.
1084       implicit none
1085       include 'COMMON.CALC'
1086       erij(1)=xj*rij
1087       erij(2)=yj*rij
1088       erij(3)=zj*rij
1089       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1090       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1091       om12=dxi*dxj+dyi*dyj+dzi*dzj
1092       chiom12=chi12*om12
1093 C Calculate eps1(om12) and its derivative in om12
1094       faceps1=1.0D0-om12*chiom12
1095       faceps1_inv=1.0D0/faceps1
1096       eps1=dsqrt(faceps1_inv)
1097 C Following variable is eps1*deps1/dom12
1098       eps1_om12=faceps1_inv*chiom12
1099 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1100 C and om12.
1101       om1om2=om1*om2
1102       chiom1=chi1*om1
1103       chiom2=chi2*om2
1104       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1105       sigsq=1.0D0-facsig*faceps1_inv
1106       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1107       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1108       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1109 C Calculate eps2 and its derivatives in om1, om2, and om12.
1110       chipom1=chip1*om1
1111       chipom2=chip2*om2
1112       chipom12=chip12*om12
1113       facp=1.0D0-om12*chipom12
1114       facp_inv=1.0D0/facp
1115       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1116 C Following variable is the square root of eps2
1117       eps2rt=1.0D0-facp1*facp_inv
1118 C Following three variables are the derivatives of the square root of eps
1119 C in om1, om2, and om12.
1120       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1121       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1122       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1123 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1124       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1125 C Calculate whole angle-dependent part of epsilon and contributions
1126 C to its derivatives
1127       return
1128       end
1129 C----------------------------------------------------------------------------
1130       subroutine sc_grad
1131       implicit real*8 (a-h,o-z)
1132       include 'DIMENSIONS'
1133       include 'DIMENSIONS.ZSCOPT'
1134       include 'COMMON.CHAIN'
1135       include 'COMMON.DERIV'
1136       include 'COMMON.CALC'
1137       double precision dcosom1(3),dcosom2(3)
1138       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1139       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1140       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1141      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1142       do k=1,3
1143         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1144         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1145       enddo
1146       do k=1,3
1147         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1148       enddo
1149       do k=1,3
1150         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1151      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1152      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1153         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1154      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1155      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1156       enddo
1157 C
1158 C Calculate the components of the gradient in DC and X
1159 C
1160       do k=i,j-1
1161         do l=1,3
1162           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1163         enddo
1164       enddo
1165       return
1166       end
1167 c------------------------------------------------------------------------------
1168       subroutine vec_and_deriv
1169       implicit real*8 (a-h,o-z)
1170       include 'DIMENSIONS'
1171       include 'DIMENSIONS.ZSCOPT'
1172       include 'COMMON.IOUNITS'
1173       include 'COMMON.GEO'
1174       include 'COMMON.VAR'
1175       include 'COMMON.LOCAL'
1176       include 'COMMON.CHAIN'
1177       include 'COMMON.VECTORS'
1178       include 'COMMON.DERIV'
1179       include 'COMMON.INTERACT'
1180       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1181 C Compute the local reference systems. For reference system (i), the
1182 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1183 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1184       do i=1,nres-1
1185 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1186           if (i.eq.nres-1) then
1187 C Case of the last full residue
1188 C Compute the Z-axis
1189             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1190             costh=dcos(pi-theta(nres))
1191             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1192             do k=1,3
1193               uz(k,i)=fac*uz(k,i)
1194             enddo
1195             if (calc_grad) then
1196 C Compute the derivatives of uz
1197             uzder(1,1,1)= 0.0d0
1198             uzder(2,1,1)=-dc_norm(3,i-1)
1199             uzder(3,1,1)= dc_norm(2,i-1)
1200             uzder(1,2,1)= dc_norm(3,i-1)
1201             uzder(2,2,1)= 0.0d0
1202             uzder(3,2,1)=-dc_norm(1,i-1)
1203             uzder(1,3,1)=-dc_norm(2,i-1)
1204             uzder(2,3,1)= dc_norm(1,i-1)
1205             uzder(3,3,1)= 0.0d0
1206             uzder(1,1,2)= 0.0d0
1207             uzder(2,1,2)= dc_norm(3,i)
1208             uzder(3,1,2)=-dc_norm(2,i)
1209             uzder(1,2,2)=-dc_norm(3,i)
1210             uzder(2,2,2)= 0.0d0
1211             uzder(3,2,2)= dc_norm(1,i)
1212             uzder(1,3,2)= dc_norm(2,i)
1213             uzder(2,3,2)=-dc_norm(1,i)
1214             uzder(3,3,2)= 0.0d0
1215             endif
1216 C Compute the Y-axis
1217             facy=fac
1218             do k=1,3
1219               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1220             enddo
1221             if (calc_grad) then
1222 C Compute the derivatives of uy
1223             do j=1,3
1224               do k=1,3
1225                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1226      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1227                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1228               enddo
1229               uyder(j,j,1)=uyder(j,j,1)-costh
1230               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1231             enddo
1232             do j=1,2
1233               do k=1,3
1234                 do l=1,3
1235                   uygrad(l,k,j,i)=uyder(l,k,j)
1236                   uzgrad(l,k,j,i)=uzder(l,k,j)
1237                 enddo
1238               enddo
1239             enddo
1240             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1241             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1242             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1243             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1244             endif
1245           else
1246 C Other residues
1247 C Compute the Z-axis
1248             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1249             costh=dcos(pi-theta(i+2))
1250             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1251             do k=1,3
1252               uz(k,i)=fac*uz(k,i)
1253             enddo
1254             if (calc_grad) then
1255 C Compute the derivatives of uz
1256             uzder(1,1,1)= 0.0d0
1257             uzder(2,1,1)=-dc_norm(3,i+1)
1258             uzder(3,1,1)= dc_norm(2,i+1)
1259             uzder(1,2,1)= dc_norm(3,i+1)
1260             uzder(2,2,1)= 0.0d0
1261             uzder(3,2,1)=-dc_norm(1,i+1)
1262             uzder(1,3,1)=-dc_norm(2,i+1)
1263             uzder(2,3,1)= dc_norm(1,i+1)
1264             uzder(3,3,1)= 0.0d0
1265             uzder(1,1,2)= 0.0d0
1266             uzder(2,1,2)= dc_norm(3,i)
1267             uzder(3,1,2)=-dc_norm(2,i)
1268             uzder(1,2,2)=-dc_norm(3,i)
1269             uzder(2,2,2)= 0.0d0
1270             uzder(3,2,2)= dc_norm(1,i)
1271             uzder(1,3,2)= dc_norm(2,i)
1272             uzder(2,3,2)=-dc_norm(1,i)
1273             uzder(3,3,2)= 0.0d0
1274             endif
1275 C Compute the Y-axis
1276             facy=fac
1277             do k=1,3
1278               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1279             enddo
1280             if (calc_grad) then
1281 C Compute the derivatives of uy
1282             do j=1,3
1283               do k=1,3
1284                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1285      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1286                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1287               enddo
1288               uyder(j,j,1)=uyder(j,j,1)-costh
1289               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1290             enddo
1291             do j=1,2
1292               do k=1,3
1293                 do l=1,3
1294                   uygrad(l,k,j,i)=uyder(l,k,j)
1295                   uzgrad(l,k,j,i)=uzder(l,k,j)
1296                 enddo
1297               enddo
1298             enddo
1299             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1300             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1301             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1302             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1303           endif
1304           endif
1305       enddo
1306       if (calc_grad) then
1307       do i=1,nres-1
1308         vbld_inv_temp(1)=vbld_inv(i+1)
1309         if (i.lt.nres-1) then
1310           vbld_inv_temp(2)=vbld_inv(i+2)
1311         else
1312           vbld_inv_temp(2)=vbld_inv(i)
1313         endif
1314         do j=1,2
1315           do k=1,3
1316             do l=1,3
1317               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1318               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1319             enddo
1320           enddo
1321         enddo
1322       enddo
1323       endif
1324       return
1325       end
1326 C-----------------------------------------------------------------------------
1327       subroutine vec_and_deriv_test
1328       implicit real*8 (a-h,o-z)
1329       include 'DIMENSIONS'
1330       include 'DIMENSIONS.ZSCOPT'
1331       include 'COMMON.IOUNITS'
1332       include 'COMMON.GEO'
1333       include 'COMMON.VAR'
1334       include 'COMMON.LOCAL'
1335       include 'COMMON.CHAIN'
1336       include 'COMMON.VECTORS'
1337       dimension uyder(3,3,2),uzder(3,3,2)
1338 C Compute the local reference systems. For reference system (i), the
1339 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1340 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1341       do i=1,nres-1
1342           if (i.eq.nres-1) then
1343 C Case of the last full residue
1344 C Compute the Z-axis
1345             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1346             costh=dcos(pi-theta(nres))
1347             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1348 c            write (iout,*) 'fac',fac,
1349 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1350             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1351             do k=1,3
1352               uz(k,i)=fac*uz(k,i)
1353             enddo
1354 C Compute the derivatives of uz
1355             uzder(1,1,1)= 0.0d0
1356             uzder(2,1,1)=-dc_norm(3,i-1)
1357             uzder(3,1,1)= dc_norm(2,i-1)
1358             uzder(1,2,1)= dc_norm(3,i-1)
1359             uzder(2,2,1)= 0.0d0
1360             uzder(3,2,1)=-dc_norm(1,i-1)
1361             uzder(1,3,1)=-dc_norm(2,i-1)
1362             uzder(2,3,1)= dc_norm(1,i-1)
1363             uzder(3,3,1)= 0.0d0
1364             uzder(1,1,2)= 0.0d0
1365             uzder(2,1,2)= dc_norm(3,i)
1366             uzder(3,1,2)=-dc_norm(2,i)
1367             uzder(1,2,2)=-dc_norm(3,i)
1368             uzder(2,2,2)= 0.0d0
1369             uzder(3,2,2)= dc_norm(1,i)
1370             uzder(1,3,2)= dc_norm(2,i)
1371             uzder(2,3,2)=-dc_norm(1,i)
1372             uzder(3,3,2)= 0.0d0
1373 C Compute the Y-axis
1374             do k=1,3
1375               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1376             enddo
1377             facy=fac
1378             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1379      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1380      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1381             do k=1,3
1382 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1383               uy(k,i)=
1384 c     &        facy*(
1385      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1386      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1387 c     &        )
1388             enddo
1389 c            write (iout,*) 'facy',facy,
1390 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1391             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1392             do k=1,3
1393               uy(k,i)=facy*uy(k,i)
1394             enddo
1395 C Compute the derivatives of uy
1396             do j=1,3
1397               do k=1,3
1398                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1399      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1400                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1401               enddo
1402 c              uyder(j,j,1)=uyder(j,j,1)-costh
1403 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1404               uyder(j,j,1)=uyder(j,j,1)
1405      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1406               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1407      &          +uyder(j,j,2)
1408             enddo
1409             do j=1,2
1410               do k=1,3
1411                 do l=1,3
1412                   uygrad(l,k,j,i)=uyder(l,k,j)
1413                   uzgrad(l,k,j,i)=uzder(l,k,j)
1414                 enddo
1415               enddo
1416             enddo
1417             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1418             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1419             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1420             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1421           else
1422 C Other residues
1423 C Compute the Z-axis
1424             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1425             costh=dcos(pi-theta(i+2))
1426             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1427             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1428             do k=1,3
1429               uz(k,i)=fac*uz(k,i)
1430             enddo
1431 C Compute the derivatives of uz
1432             uzder(1,1,1)= 0.0d0
1433             uzder(2,1,1)=-dc_norm(3,i+1)
1434             uzder(3,1,1)= dc_norm(2,i+1)
1435             uzder(1,2,1)= dc_norm(3,i+1)
1436             uzder(2,2,1)= 0.0d0
1437             uzder(3,2,1)=-dc_norm(1,i+1)
1438             uzder(1,3,1)=-dc_norm(2,i+1)
1439             uzder(2,3,1)= dc_norm(1,i+1)
1440             uzder(3,3,1)= 0.0d0
1441             uzder(1,1,2)= 0.0d0
1442             uzder(2,1,2)= dc_norm(3,i)
1443             uzder(3,1,2)=-dc_norm(2,i)
1444             uzder(1,2,2)=-dc_norm(3,i)
1445             uzder(2,2,2)= 0.0d0
1446             uzder(3,2,2)= dc_norm(1,i)
1447             uzder(1,3,2)= dc_norm(2,i)
1448             uzder(2,3,2)=-dc_norm(1,i)
1449             uzder(3,3,2)= 0.0d0
1450 C Compute the Y-axis
1451             facy=fac
1452             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1453      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1454      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1455             do k=1,3
1456 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1457               uy(k,i)=
1458 c     &        facy*(
1459      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1460      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1461 c     &        )
1462             enddo
1463 c            write (iout,*) 'facy',facy,
1464 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1465             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1466             do k=1,3
1467               uy(k,i)=facy*uy(k,i)
1468             enddo
1469 C Compute the derivatives of uy
1470             do j=1,3
1471               do k=1,3
1472                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1473      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1474                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1475               enddo
1476 c              uyder(j,j,1)=uyder(j,j,1)-costh
1477 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1478               uyder(j,j,1)=uyder(j,j,1)
1479      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1480               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1481      &          +uyder(j,j,2)
1482             enddo
1483             do j=1,2
1484               do k=1,3
1485                 do l=1,3
1486                   uygrad(l,k,j,i)=uyder(l,k,j)
1487                   uzgrad(l,k,j,i)=uzder(l,k,j)
1488                 enddo
1489               enddo
1490             enddo
1491             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1492             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1493             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1494             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1495           endif
1496       enddo
1497       do i=1,nres-1
1498         do j=1,2
1499           do k=1,3
1500             do l=1,3
1501               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1502               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1503             enddo
1504           enddo
1505         enddo
1506       enddo
1507       return
1508       end
1509 C-----------------------------------------------------------------------------
1510       subroutine check_vecgrad
1511       implicit real*8 (a-h,o-z)
1512       include 'DIMENSIONS'
1513       include 'DIMENSIONS.ZSCOPT'
1514       include 'COMMON.IOUNITS'
1515       include 'COMMON.GEO'
1516       include 'COMMON.VAR'
1517       include 'COMMON.LOCAL'
1518       include 'COMMON.CHAIN'
1519       include 'COMMON.VECTORS'
1520       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1521       dimension uyt(3,maxres),uzt(3,maxres)
1522       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1523       double precision delta /1.0d-7/
1524       call vec_and_deriv
1525 cd      do i=1,nres
1526 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1527 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1528 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1529 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1530 cd     &     (dc_norm(if90,i),if90=1,3)
1531 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1532 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1533 cd          write(iout,'(a)')
1534 cd      enddo
1535       do i=1,nres
1536         do j=1,2
1537           do k=1,3
1538             do l=1,3
1539               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1540               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1541             enddo
1542           enddo
1543         enddo
1544       enddo
1545       call vec_and_deriv
1546       do i=1,nres
1547         do j=1,3
1548           uyt(j,i)=uy(j,i)
1549           uzt(j,i)=uz(j,i)
1550         enddo
1551       enddo
1552       do i=1,nres
1553 cd        write (iout,*) 'i=',i
1554         do k=1,3
1555           erij(k)=dc_norm(k,i)
1556         enddo
1557         do j=1,3
1558           do k=1,3
1559             dc_norm(k,i)=erij(k)
1560           enddo
1561           dc_norm(j,i)=dc_norm(j,i)+delta
1562 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1563 c          do k=1,3
1564 c            dc_norm(k,i)=dc_norm(k,i)/fac
1565 c          enddo
1566 c          write (iout,*) (dc_norm(k,i),k=1,3)
1567 c          write (iout,*) (erij(k),k=1,3)
1568           call vec_and_deriv
1569           do k=1,3
1570             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1571             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1572             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1573             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1574           enddo
1575 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1576 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1577 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1578         enddo
1579         do k=1,3
1580           dc_norm(k,i)=erij(k)
1581         enddo
1582 cd        do k=1,3
1583 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1584 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1585 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1586 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1587 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1588 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1589 cd          write (iout,'(a)')
1590 cd        enddo
1591       enddo
1592       return
1593       end
1594 C--------------------------------------------------------------------------
1595       subroutine set_matrices
1596       implicit real*8 (a-h,o-z)
1597       include 'DIMENSIONS'
1598       include 'DIMENSIONS.ZSCOPT'
1599       include 'COMMON.IOUNITS'
1600       include 'COMMON.GEO'
1601       include 'COMMON.VAR'
1602       include 'COMMON.LOCAL'
1603       include 'COMMON.CHAIN'
1604       include 'COMMON.DERIV'
1605       include 'COMMON.INTERACT'
1606       include 'COMMON.CONTACTS'
1607       include 'COMMON.TORSION'
1608       include 'COMMON.VECTORS'
1609       include 'COMMON.FFIELD'
1610       double precision auxvec(2),auxmat(2,2)
1611 C
1612 C Compute the virtual-bond-torsional-angle dependent quantities needed
1613 C to calculate the el-loc multibody terms of various order.
1614 C
1615       do i=3,nres+1
1616         if (i .lt. nres+1) then
1617           sin1=dsin(phi(i))
1618           cos1=dcos(phi(i))
1619           sintab(i-2)=sin1
1620           costab(i-2)=cos1
1621           obrot(1,i-2)=cos1
1622           obrot(2,i-2)=sin1
1623           sin2=dsin(2*phi(i))
1624           cos2=dcos(2*phi(i))
1625           sintab2(i-2)=sin2
1626           costab2(i-2)=cos2
1627           obrot2(1,i-2)=cos2
1628           obrot2(2,i-2)=sin2
1629           Ug(1,1,i-2)=-cos1
1630           Ug(1,2,i-2)=-sin1
1631           Ug(2,1,i-2)=-sin1
1632           Ug(2,2,i-2)= cos1
1633           Ug2(1,1,i-2)=-cos2
1634           Ug2(1,2,i-2)=-sin2
1635           Ug2(2,1,i-2)=-sin2
1636           Ug2(2,2,i-2)= cos2
1637         else
1638           costab(i-2)=1.0d0
1639           sintab(i-2)=0.0d0
1640           obrot(1,i-2)=1.0d0
1641           obrot(2,i-2)=0.0d0
1642           obrot2(1,i-2)=0.0d0
1643           obrot2(2,i-2)=0.0d0
1644           Ug(1,1,i-2)=1.0d0
1645           Ug(1,2,i-2)=0.0d0
1646           Ug(2,1,i-2)=0.0d0
1647           Ug(2,2,i-2)=1.0d0
1648           Ug2(1,1,i-2)=0.0d0
1649           Ug2(1,2,i-2)=0.0d0
1650           Ug2(2,1,i-2)=0.0d0
1651           Ug2(2,2,i-2)=0.0d0
1652         endif
1653         if (i .gt. 3 .and. i .lt. nres+1) then
1654           obrot_der(1,i-2)=-sin1
1655           obrot_der(2,i-2)= cos1
1656           Ugder(1,1,i-2)= sin1
1657           Ugder(1,2,i-2)=-cos1
1658           Ugder(2,1,i-2)=-cos1
1659           Ugder(2,2,i-2)=-sin1
1660           dwacos2=cos2+cos2
1661           dwasin2=sin2+sin2
1662           obrot2_der(1,i-2)=-dwasin2
1663           obrot2_der(2,i-2)= dwacos2
1664           Ug2der(1,1,i-2)= dwasin2
1665           Ug2der(1,2,i-2)=-dwacos2
1666           Ug2der(2,1,i-2)=-dwacos2
1667           Ug2der(2,2,i-2)=-dwasin2
1668         else
1669           obrot_der(1,i-2)=0.0d0
1670           obrot_der(2,i-2)=0.0d0
1671           Ugder(1,1,i-2)=0.0d0
1672           Ugder(1,2,i-2)=0.0d0
1673           Ugder(2,1,i-2)=0.0d0
1674           Ugder(2,2,i-2)=0.0d0
1675           obrot2_der(1,i-2)=0.0d0
1676           obrot2_der(2,i-2)=0.0d0
1677           Ug2der(1,1,i-2)=0.0d0
1678           Ug2der(1,2,i-2)=0.0d0
1679           Ug2der(2,1,i-2)=0.0d0
1680           Ug2der(2,2,i-2)=0.0d0
1681         endif
1682         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1683           iti = itortyp(itype(i-2))
1684         else
1685           iti=ntortyp+1
1686         endif
1687         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1688           iti1 = itortyp(itype(i-1))
1689         else
1690           iti1=ntortyp+1
1691         endif
1692 cd        write (iout,*) '*******i',i,' iti1',iti
1693 cd        write (iout,*) 'b1',b1(:,iti)
1694 cd        write (iout,*) 'b2',b2(:,iti)
1695 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1696         if (i .gt. iatel_s+2) then
1697           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1698           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1699           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1700           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1701           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1702           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1703           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1704         else
1705           do k=1,2
1706             Ub2(k,i-2)=0.0d0
1707             Ctobr(k,i-2)=0.0d0
1708             Dtobr2(k,i-2)=0.0d0
1709             do l=1,2
1710               EUg(l,k,i-2)=0.0d0
1711               CUg(l,k,i-2)=0.0d0
1712               DUg(l,k,i-2)=0.0d0
1713               DtUg2(l,k,i-2)=0.0d0
1714             enddo
1715           enddo
1716         endif
1717         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1718         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1719         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1720         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1721         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1722         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1723         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1724         do k=1,2
1725           muder(k,i-2)=Ub2der(k,i-2)
1726         enddo
1727         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1728           iti1 = itortyp(itype(i-1))
1729         else
1730           iti1=ntortyp+1
1731         endif
1732         do k=1,2
1733           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1734         enddo
1735 C Vectors and matrices dependent on a single virtual-bond dihedral.
1736         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1737         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1738         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1739         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1740         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1741         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1742         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1743         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1744         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1745 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1746 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1747       enddo
1748 C Matrices dependent on two consecutive virtual-bond dihedrals.
1749 C The order of matrices is from left to right.
1750       do i=2,nres-1
1751         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1752         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1753         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1754         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1755         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1756         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1757         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1758         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1759       enddo
1760 cd      do i=1,nres
1761 cd        iti = itortyp(itype(i))
1762 cd        write (iout,*) i
1763 cd        do j=1,2
1764 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1765 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1766 cd        enddo
1767 cd      enddo
1768       return
1769       end
1770 C--------------------------------------------------------------------------
1771       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1772 C
1773 C This subroutine calculates the average interaction energy and its gradient
1774 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1775 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1776 C The potential depends both on the distance of peptide-group centers and on
1777 C the orientation of the CA-CA virtual bonds.
1778 C
1779       implicit real*8 (a-h,o-z)
1780       include 'DIMENSIONS'
1781       include 'DIMENSIONS.ZSCOPT'
1782       include 'COMMON.CONTROL'
1783       include 'COMMON.IOUNITS'
1784       include 'COMMON.GEO'
1785       include 'COMMON.VAR'
1786       include 'COMMON.LOCAL'
1787       include 'COMMON.CHAIN'
1788       include 'COMMON.DERIV'
1789       include 'COMMON.INTERACT'
1790       include 'COMMON.CONTACTS'
1791       include 'COMMON.TORSION'
1792       include 'COMMON.VECTORS'
1793       include 'COMMON.FFIELD'
1794       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1795      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1796       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1797      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1798       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1799 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1800       double precision scal_el /0.5d0/
1801 C 12/13/98
1802 C 13-go grudnia roku pamietnego...
1803       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1804      &                   0.0d0,1.0d0,0.0d0,
1805      &                   0.0d0,0.0d0,1.0d0/
1806 cd      write(iout,*) 'In EELEC'
1807 cd      do i=1,nloctyp
1808 cd        write(iout,*) 'Type',i
1809 cd        write(iout,*) 'B1',B1(:,i)
1810 cd        write(iout,*) 'B2',B2(:,i)
1811 cd        write(iout,*) 'CC',CC(:,:,i)
1812 cd        write(iout,*) 'DD',DD(:,:,i)
1813 cd        write(iout,*) 'EE',EE(:,:,i)
1814 cd      enddo
1815 cd      call check_vecgrad
1816 cd      stop
1817       if (icheckgrad.eq.1) then
1818         do i=1,nres-1
1819           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1820           do k=1,3
1821             dc_norm(k,i)=dc(k,i)*fac
1822           enddo
1823 c          write (iout,*) 'i',i,' fac',fac
1824         enddo
1825       endif
1826       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1827      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1828      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1829 cd      if (wel_loc.gt.0.0d0) then
1830         if (icheckgrad.eq.1) then
1831         call vec_and_deriv_test
1832         else
1833         call vec_and_deriv
1834         endif
1835         call set_matrices
1836       endif
1837 cd      do i=1,nres-1
1838 cd        write (iout,*) 'i=',i
1839 cd        do k=1,3
1840 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1841 cd        enddo
1842 cd        do k=1,3
1843 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1844 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1845 cd        enddo
1846 cd      enddo
1847       num_conti_hb=0
1848       ees=0.0D0
1849       evdw1=0.0D0
1850       eel_loc=0.0d0
1851       eello_turn3=0.0d0
1852       eello_turn4=0.0d0
1853       ind=0
1854       do i=1,nres
1855         num_cont_hb(i)=0
1856       enddo
1857 cd      print '(a)','Enter EELEC'
1858 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1859       do i=1,nres
1860         gel_loc_loc(i)=0.0d0
1861         gcorr_loc(i)=0.0d0
1862       enddo
1863       do i=iatel_s,iatel_e
1864         if (itel(i).eq.0) goto 1215
1865         dxi=dc(1,i)
1866         dyi=dc(2,i)
1867         dzi=dc(3,i)
1868         dx_normi=dc_norm(1,i)
1869         dy_normi=dc_norm(2,i)
1870         dz_normi=dc_norm(3,i)
1871         xmedi=c(1,i)+0.5d0*dxi
1872         ymedi=c(2,i)+0.5d0*dyi
1873         zmedi=c(3,i)+0.5d0*dzi
1874         num_conti=0
1875 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1876         do j=ielstart(i),ielend(i)
1877           if (itel(j).eq.0) goto 1216
1878           ind=ind+1
1879           iteli=itel(i)
1880           itelj=itel(j)
1881           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1882           aaa=app(iteli,itelj)
1883           bbb=bpp(iteli,itelj)
1884 C Diagnostics only!!!
1885 c         aaa=0.0D0
1886 c         bbb=0.0D0
1887 c         ael6i=0.0D0
1888 c         ael3i=0.0D0
1889 C End diagnostics
1890           ael6i=ael6(iteli,itelj)
1891           ael3i=ael3(iteli,itelj)
1892           dxj=dc(1,j)
1893           dyj=dc(2,j)
1894           dzj=dc(3,j)
1895           dx_normj=dc_norm(1,j)
1896           dy_normj=dc_norm(2,j)
1897           dz_normj=dc_norm(3,j)
1898           xj=c(1,j)+0.5D0*dxj-xmedi
1899           yj=c(2,j)+0.5D0*dyj-ymedi
1900           zj=c(3,j)+0.5D0*dzj-zmedi
1901           rij=xj*xj+yj*yj+zj*zj
1902           rrmij=1.0D0/rij
1903           rij=dsqrt(rij)
1904           rmij=1.0D0/rij
1905           r3ij=rrmij*rmij
1906           r6ij=r3ij*r3ij
1907           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1908           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1909           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1910           fac=cosa-3.0D0*cosb*cosg
1911           ev1=aaa*r6ij*r6ij
1912 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1913           if (j.eq.i+2) ev1=scal_el*ev1
1914           ev2=bbb*r6ij
1915           fac3=ael6i*r6ij
1916           fac4=ael3i*r3ij
1917           evdwij=ev1+ev2
1918           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1919           el2=fac4*fac
1920           eesij=el1+el2
1921 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1922 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1923           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1924           ees=ees+eesij
1925           evdw1=evdw1+evdwij
1926 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1927 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1928 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1929 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1930 C
1931 C Calculate contributions to the Cartesian gradient.
1932 C
1933 #ifdef SPLITELE
1934           facvdw=-6*rrmij*(ev1+evdwij)
1935           facel=-3*rrmij*(el1+eesij)
1936           fac1=fac
1937           erij(1)=xj*rmij
1938           erij(2)=yj*rmij
1939           erij(3)=zj*rmij
1940           if (calc_grad) then
1941 *
1942 * Radial derivatives. First process both termini of the fragment (i,j)
1943 *
1944           ggg(1)=facel*xj
1945           ggg(2)=facel*yj
1946           ggg(3)=facel*zj
1947           do k=1,3
1948             ghalf=0.5D0*ggg(k)
1949             gelc(k,i)=gelc(k,i)+ghalf
1950             gelc(k,j)=gelc(k,j)+ghalf
1951           enddo
1952 *
1953 * Loop over residues i+1 thru j-1.
1954 *
1955           do k=i+1,j-1
1956             do l=1,3
1957               gelc(l,k)=gelc(l,k)+ggg(l)
1958             enddo
1959           enddo
1960           ggg(1)=facvdw*xj
1961           ggg(2)=facvdw*yj
1962           ggg(3)=facvdw*zj
1963           do k=1,3
1964             ghalf=0.5D0*ggg(k)
1965             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1966             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1967           enddo
1968 *
1969 * Loop over residues i+1 thru j-1.
1970 *
1971           do k=i+1,j-1
1972             do l=1,3
1973               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1974             enddo
1975           enddo
1976 #else
1977           facvdw=ev1+evdwij
1978           facel=el1+eesij
1979           fac1=fac
1980           fac=-3*rrmij*(facvdw+facvdw+facel)
1981           erij(1)=xj*rmij
1982           erij(2)=yj*rmij
1983           erij(3)=zj*rmij
1984           if (calc_grad) then
1985 *
1986 * Radial derivatives. First process both termini of the fragment (i,j)
1987 *
1988           ggg(1)=fac*xj
1989           ggg(2)=fac*yj
1990           ggg(3)=fac*zj
1991           do k=1,3
1992             ghalf=0.5D0*ggg(k)
1993             gelc(k,i)=gelc(k,i)+ghalf
1994             gelc(k,j)=gelc(k,j)+ghalf
1995           enddo
1996 *
1997 * Loop over residues i+1 thru j-1.
1998 *
1999           do k=i+1,j-1
2000             do l=1,3
2001               gelc(l,k)=gelc(l,k)+ggg(l)
2002             enddo
2003           enddo
2004 #endif
2005 *
2006 * Angular part
2007 *
2008           ecosa=2.0D0*fac3*fac1+fac4
2009           fac4=-3.0D0*fac4
2010           fac3=-6.0D0*fac3
2011           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2012           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2013           do k=1,3
2014             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2015             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2016           enddo
2017 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2018 cd   &          (dcosg(k),k=1,3)
2019           do k=1,3
2020             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2021           enddo
2022           do k=1,3
2023             ghalf=0.5D0*ggg(k)
2024             gelc(k,i)=gelc(k,i)+ghalf
2025      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2026      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2027             gelc(k,j)=gelc(k,j)+ghalf
2028      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2029      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2030           enddo
2031           do k=i+1,j-1
2032             do l=1,3
2033               gelc(l,k)=gelc(l,k)+ggg(l)
2034             enddo
2035           enddo
2036           endif
2037
2038           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2039      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2040      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2041 C
2042 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2043 C   energy of a peptide unit is assumed in the form of a second-order
2044 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2045 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2046 C   are computed for EVERY pair of non-contiguous peptide groups.
2047 C
2048           if (j.lt.nres-1) then
2049             j1=j+1
2050             j2=j-1
2051           else
2052             j1=j-1
2053             j2=j-2
2054           endif
2055           kkk=0
2056           do k=1,2
2057             do l=1,2
2058               kkk=kkk+1
2059               muij(kkk)=mu(k,i)*mu(l,j)
2060             enddo
2061           enddo
2062 cd         write (iout,*) 'EELEC: i',i,' j',j
2063 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2064 cd          write(iout,*) 'muij',muij
2065           ury=scalar(uy(1,i),erij)
2066           urz=scalar(uz(1,i),erij)
2067           vry=scalar(uy(1,j),erij)
2068           vrz=scalar(uz(1,j),erij)
2069           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2070           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2071           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2072           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2073 C For diagnostics only
2074 cd          a22=1.0d0
2075 cd          a23=1.0d0
2076 cd          a32=1.0d0
2077 cd          a33=1.0d0
2078           fac=dsqrt(-ael6i)*r3ij
2079 cd          write (2,*) 'fac=',fac
2080 C For diagnostics only
2081 cd          fac=1.0d0
2082           a22=a22*fac
2083           a23=a23*fac
2084           a32=a32*fac
2085           a33=a33*fac
2086 cd          write (iout,'(4i5,4f10.5)')
2087 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2088 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2089 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2090 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2091 cd          write (iout,'(4f10.5)')
2092 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2093 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2094 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2095 cd           write (iout,'(2i3,9f10.5/)') i,j,
2096 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2097           if (calc_grad) then
2098 C Derivatives of the elements of A in virtual-bond vectors
2099           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2100 cd          do k=1,3
2101 cd            do l=1,3
2102 cd              erder(k,l)=0.0d0
2103 cd            enddo
2104 cd          enddo
2105           do k=1,3
2106             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2107             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2108             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2109             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2110             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2111             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2112             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2113             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2114             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2115             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2116             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2117             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2118           enddo
2119 cd          do k=1,3
2120 cd            do l=1,3
2121 cd              uryg(k,l)=0.0d0
2122 cd              urzg(k,l)=0.0d0
2123 cd              vryg(k,l)=0.0d0
2124 cd              vrzg(k,l)=0.0d0
2125 cd            enddo
2126 cd          enddo
2127 C Compute radial contributions to the gradient
2128           facr=-3.0d0*rrmij
2129           a22der=a22*facr
2130           a23der=a23*facr
2131           a32der=a32*facr
2132           a33der=a33*facr
2133 cd          a22der=0.0d0
2134 cd          a23der=0.0d0
2135 cd          a32der=0.0d0
2136 cd          a33der=0.0d0
2137           agg(1,1)=a22der*xj
2138           agg(2,1)=a22der*yj
2139           agg(3,1)=a22der*zj
2140           agg(1,2)=a23der*xj
2141           agg(2,2)=a23der*yj
2142           agg(3,2)=a23der*zj
2143           agg(1,3)=a32der*xj
2144           agg(2,3)=a32der*yj
2145           agg(3,3)=a32der*zj
2146           agg(1,4)=a33der*xj
2147           agg(2,4)=a33der*yj
2148           agg(3,4)=a33der*zj
2149 C Add the contributions coming from er
2150           fac3=-3.0d0*fac
2151           do k=1,3
2152             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2153             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2154             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2155             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2156           enddo
2157           do k=1,3
2158 C Derivatives in DC(i)
2159             ghalf1=0.5d0*agg(k,1)
2160             ghalf2=0.5d0*agg(k,2)
2161             ghalf3=0.5d0*agg(k,3)
2162             ghalf4=0.5d0*agg(k,4)
2163             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2164      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2165             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2166      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2167             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2168      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2169             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2170      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2171 C Derivatives in DC(i+1)
2172             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2173      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2174             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2175      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2176             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2177      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2178             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2179      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2180 C Derivatives in DC(j)
2181             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2182      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2183             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2184      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2185             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2186      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2187             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2188      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2189 C Derivatives in DC(j+1) or DC(nres-1)
2190             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2191      &      -3.0d0*vryg(k,3)*ury)
2192             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2193      &      -3.0d0*vrzg(k,3)*ury)
2194             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2195      &      -3.0d0*vryg(k,3)*urz)
2196             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2197      &      -3.0d0*vrzg(k,3)*urz)
2198 cd            aggi(k,1)=ghalf1
2199 cd            aggi(k,2)=ghalf2
2200 cd            aggi(k,3)=ghalf3
2201 cd            aggi(k,4)=ghalf4
2202 C Derivatives in DC(i+1)
2203 cd            aggi1(k,1)=agg(k,1)
2204 cd            aggi1(k,2)=agg(k,2)
2205 cd            aggi1(k,3)=agg(k,3)
2206 cd            aggi1(k,4)=agg(k,4)
2207 C Derivatives in DC(j)
2208 cd            aggj(k,1)=ghalf1
2209 cd            aggj(k,2)=ghalf2
2210 cd            aggj(k,3)=ghalf3
2211 cd            aggj(k,4)=ghalf4
2212 C Derivatives in DC(j+1)
2213 cd            aggj1(k,1)=0.0d0
2214 cd            aggj1(k,2)=0.0d0
2215 cd            aggj1(k,3)=0.0d0
2216 cd            aggj1(k,4)=0.0d0
2217             if (j.eq.nres-1 .and. i.lt.j-2) then
2218               do l=1,4
2219                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2220 cd                aggj1(k,l)=agg(k,l)
2221               enddo
2222             endif
2223           enddo
2224           endif
2225 c          goto 11111
2226 C Check the loc-el terms by numerical integration
2227           acipa(1,1)=a22
2228           acipa(1,2)=a23
2229           acipa(2,1)=a32
2230           acipa(2,2)=a33
2231           a22=-a22
2232           a23=-a23
2233           do l=1,2
2234             do k=1,3
2235               agg(k,l)=-agg(k,l)
2236               aggi(k,l)=-aggi(k,l)
2237               aggi1(k,l)=-aggi1(k,l)
2238               aggj(k,l)=-aggj(k,l)
2239               aggj1(k,l)=-aggj1(k,l)
2240             enddo
2241           enddo
2242           if (j.lt.nres-1) then
2243             a22=-a22
2244             a32=-a32
2245             do l=1,3,2
2246               do k=1,3
2247                 agg(k,l)=-agg(k,l)
2248                 aggi(k,l)=-aggi(k,l)
2249                 aggi1(k,l)=-aggi1(k,l)
2250                 aggj(k,l)=-aggj(k,l)
2251                 aggj1(k,l)=-aggj1(k,l)
2252               enddo
2253             enddo
2254           else
2255             a22=-a22
2256             a23=-a23
2257             a32=-a32
2258             a33=-a33
2259             do l=1,4
2260               do k=1,3
2261                 agg(k,l)=-agg(k,l)
2262                 aggi(k,l)=-aggi(k,l)
2263                 aggi1(k,l)=-aggi1(k,l)
2264                 aggj(k,l)=-aggj(k,l)
2265                 aggj1(k,l)=-aggj1(k,l)
2266               enddo
2267             enddo
2268           endif
2269           ENDIF ! WCORR
2270 11111     continue
2271           IF (wel_loc.gt.0.0d0) THEN
2272 C Contribution to the local-electrostatic energy coming from the i-j pair
2273           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2274      &     +a33*muij(4)
2275 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2276 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2277           eel_loc=eel_loc+eel_loc_ij
2278 C Partial derivatives in virtual-bond dihedral angles gamma
2279           if (calc_grad) then
2280           if (i.gt.1)
2281      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2282      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2283      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2284           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2285      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2286      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2287 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2288 cd          write(iout,*) 'agg  ',agg
2289 cd          write(iout,*) 'aggi ',aggi
2290 cd          write(iout,*) 'aggi1',aggi1
2291 cd          write(iout,*) 'aggj ',aggj
2292 cd          write(iout,*) 'aggj1',aggj1
2293
2294 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2295           do l=1,3
2296             ggg(l)=agg(l,1)*muij(1)+
2297      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2298           enddo
2299           do k=i+2,j2
2300             do l=1,3
2301               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2302             enddo
2303           enddo
2304 C Remaining derivatives of eello
2305           do l=1,3
2306             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2307      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2308             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2309      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2310             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2311      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2312             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2313      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2314           enddo
2315           endif
2316           ENDIF
2317           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2318 C Contributions from turns
2319             a_temp(1,1)=a22
2320             a_temp(1,2)=a23
2321             a_temp(2,1)=a32
2322             a_temp(2,2)=a33
2323             call eturn34(i,j,eello_turn3,eello_turn4)
2324           endif
2325 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2326           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2327 C
2328 C Calculate the contact function. The ith column of the array JCONT will
2329 C contain the numbers of atoms that make contacts with the atom I (of numbers
2330 C greater than I). The arrays FACONT and GACONT will contain the values of
2331 C the contact function and its derivative.
2332 c           r0ij=1.02D0*rpp(iteli,itelj)
2333 c           r0ij=1.11D0*rpp(iteli,itelj)
2334             r0ij=2.20D0*rpp(iteli,itelj)
2335 c           r0ij=1.55D0*rpp(iteli,itelj)
2336             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2337             if (fcont.gt.0.0D0) then
2338               num_conti=num_conti+1
2339               if (num_conti.gt.maxconts) then
2340                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2341      &                         ' will skip next contacts for this conf.'
2342               else
2343                 jcont_hb(num_conti,i)=j
2344                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2345      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2346 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2347 C  terms.
2348                 d_cont(num_conti,i)=rij
2349 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2350 C     --- Electrostatic-interaction matrix ---
2351                 a_chuj(1,1,num_conti,i)=a22
2352                 a_chuj(1,2,num_conti,i)=a23
2353                 a_chuj(2,1,num_conti,i)=a32
2354                 a_chuj(2,2,num_conti,i)=a33
2355 C     --- Gradient of rij
2356                 do kkk=1,3
2357                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2358                 enddo
2359 c             if (i.eq.1) then
2360 c                a_chuj(1,1,num_conti,i)=-0.61d0
2361 c                a_chuj(1,2,num_conti,i)= 0.4d0
2362 c                a_chuj(2,1,num_conti,i)= 0.65d0
2363 c                a_chuj(2,2,num_conti,i)= 0.50d0
2364 c             else if (i.eq.2) then
2365 c                a_chuj(1,1,num_conti,i)= 0.0d0
2366 c                a_chuj(1,2,num_conti,i)= 0.0d0
2367 c                a_chuj(2,1,num_conti,i)= 0.0d0
2368 c                a_chuj(2,2,num_conti,i)= 0.0d0
2369 c             endif
2370 C     --- and its gradients
2371 cd                write (iout,*) 'i',i,' j',j
2372 cd                do kkk=1,3
2373 cd                write (iout,*) 'iii 1 kkk',kkk
2374 cd                write (iout,*) agg(kkk,:)
2375 cd                enddo
2376 cd                do kkk=1,3
2377 cd                write (iout,*) 'iii 2 kkk',kkk
2378 cd                write (iout,*) aggi(kkk,:)
2379 cd                enddo
2380 cd                do kkk=1,3
2381 cd                write (iout,*) 'iii 3 kkk',kkk
2382 cd                write (iout,*) aggi1(kkk,:)
2383 cd                enddo
2384 cd                do kkk=1,3
2385 cd                write (iout,*) 'iii 4 kkk',kkk
2386 cd                write (iout,*) aggj(kkk,:)
2387 cd                enddo
2388 cd                do kkk=1,3
2389 cd                write (iout,*) 'iii 5 kkk',kkk
2390 cd                write (iout,*) aggj1(kkk,:)
2391 cd                enddo
2392                 kkll=0
2393                 do k=1,2
2394                   do l=1,2
2395                     kkll=kkll+1
2396                     do m=1,3
2397                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2398                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2399                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2400                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2401                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2402 c                      do mm=1,5
2403 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2404 c                      enddo
2405                     enddo
2406                   enddo
2407                 enddo
2408                 ENDIF
2409                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2410 C Calculate contact energies
2411                 cosa4=4.0D0*cosa
2412                 wij=cosa-3.0D0*cosb*cosg
2413                 cosbg1=cosb+cosg
2414                 cosbg2=cosb-cosg
2415 c               fac3=dsqrt(-ael6i)/r0ij**3
2416                 fac3=dsqrt(-ael6i)*r3ij
2417                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2418                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2419 c               ees0mij=0.0D0
2420                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2421                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2422 C Diagnostics. Comment out or remove after debugging!
2423 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2424 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2425 c               ees0m(num_conti,i)=0.0D0
2426 C End diagnostics.
2427 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2428 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2429                 facont_hb(num_conti,i)=fcont
2430                 if (calc_grad) then
2431 C Angular derivatives of the contact function
2432                 ees0pij1=fac3/ees0pij
2433                 ees0mij1=fac3/ees0mij
2434                 fac3p=-3.0D0*fac3*rrmij
2435                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2436                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2437 c               ees0mij1=0.0D0
2438                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2439                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2440                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2441                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2442                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2443                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2444                 ecosap=ecosa1+ecosa2
2445                 ecosbp=ecosb1+ecosb2
2446                 ecosgp=ecosg1+ecosg2
2447                 ecosam=ecosa1-ecosa2
2448                 ecosbm=ecosb1-ecosb2
2449                 ecosgm=ecosg1-ecosg2
2450 C Diagnostics
2451 c               ecosap=ecosa1
2452 c               ecosbp=ecosb1
2453 c               ecosgp=ecosg1
2454 c               ecosam=0.0D0
2455 c               ecosbm=0.0D0
2456 c               ecosgm=0.0D0
2457 C End diagnostics
2458                 fprimcont=fprimcont/rij
2459 cd              facont_hb(num_conti,i)=1.0D0
2460 C Following line is for diagnostics.
2461 cd              fprimcont=0.0D0
2462                 do k=1,3
2463                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2464                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2465                 enddo
2466                 do k=1,3
2467                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2468                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2469                 enddo
2470                 gggp(1)=gggp(1)+ees0pijp*xj
2471                 gggp(2)=gggp(2)+ees0pijp*yj
2472                 gggp(3)=gggp(3)+ees0pijp*zj
2473                 gggm(1)=gggm(1)+ees0mijp*xj
2474                 gggm(2)=gggm(2)+ees0mijp*yj
2475                 gggm(3)=gggm(3)+ees0mijp*zj
2476 C Derivatives due to the contact function
2477                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2478                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2479                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2480                 do k=1,3
2481                   ghalfp=0.5D0*gggp(k)
2482                   ghalfm=0.5D0*gggm(k)
2483                   gacontp_hb1(k,num_conti,i)=ghalfp
2484      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2485      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2486                   gacontp_hb2(k,num_conti,i)=ghalfp
2487      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2488      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2489                   gacontp_hb3(k,num_conti,i)=gggp(k)
2490                   gacontm_hb1(k,num_conti,i)=ghalfm
2491      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2492      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2493                   gacontm_hb2(k,num_conti,i)=ghalfm
2494      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2495      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2496                   gacontm_hb3(k,num_conti,i)=gggm(k)
2497                 enddo
2498                 endif
2499 C Diagnostics. Comment out or remove after debugging!
2500 cdiag           do k=1,3
2501 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2502 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2503 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2504 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2505 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2506 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2507 cdiag           enddo
2508               ENDIF ! wcorr
2509               endif  ! num_conti.le.maxconts
2510             endif  ! fcont.gt.0
2511           endif    ! j.gt.i+1
2512  1216     continue
2513         enddo ! j
2514         num_cont_hb(i)=num_conti
2515  1215   continue
2516       enddo   ! i
2517 cd      do i=1,nres
2518 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2519 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2520 cd      enddo
2521 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2522 ccc      eel_loc=eel_loc+eello_turn3
2523       return
2524       end
2525 C-----------------------------------------------------------------------------
2526       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2527 C Third- and fourth-order contributions from turns
2528       implicit real*8 (a-h,o-z)
2529       include 'DIMENSIONS'
2530       include 'DIMENSIONS.ZSCOPT'
2531       include 'COMMON.IOUNITS'
2532       include 'COMMON.GEO'
2533       include 'COMMON.VAR'
2534       include 'COMMON.LOCAL'
2535       include 'COMMON.CHAIN'
2536       include 'COMMON.DERIV'
2537       include 'COMMON.INTERACT'
2538       include 'COMMON.CONTACTS'
2539       include 'COMMON.TORSION'
2540       include 'COMMON.VECTORS'
2541       include 'COMMON.FFIELD'
2542       dimension ggg(3)
2543       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2544      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2545      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2546       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2547      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2548       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2549       if (j.eq.i+2) then
2550 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2551 C
2552 C               Third-order contributions
2553 C
2554 C                 (i+2)o----(i+3)
2555 C                      | |
2556 C                      | |
2557 C                 (i+1)o----i
2558 C
2559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2560 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2561         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2562         call transpose2(auxmat(1,1),auxmat1(1,1))
2563         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2564         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2565 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2566 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2567 cd     &    ' eello_turn3_num',4*eello_turn3_num
2568         if (calc_grad) then
2569 C Derivatives in gamma(i)
2570         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2571         call transpose2(auxmat2(1,1),pizda(1,1))
2572         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2573         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2574 C Derivatives in gamma(i+1)
2575         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2576         call transpose2(auxmat2(1,1),pizda(1,1))
2577         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2578         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2579      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2580 C Cartesian derivatives
2581         do l=1,3
2582           a_temp(1,1)=aggi(l,1)
2583           a_temp(1,2)=aggi(l,2)
2584           a_temp(2,1)=aggi(l,3)
2585           a_temp(2,2)=aggi(l,4)
2586           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2587           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2588      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2589           a_temp(1,1)=aggi1(l,1)
2590           a_temp(1,2)=aggi1(l,2)
2591           a_temp(2,1)=aggi1(l,3)
2592           a_temp(2,2)=aggi1(l,4)
2593           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2594           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2595      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2596           a_temp(1,1)=aggj(l,1)
2597           a_temp(1,2)=aggj(l,2)
2598           a_temp(2,1)=aggj(l,3)
2599           a_temp(2,2)=aggj(l,4)
2600           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2601           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2602      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2603           a_temp(1,1)=aggj1(l,1)
2604           a_temp(1,2)=aggj1(l,2)
2605           a_temp(2,1)=aggj1(l,3)
2606           a_temp(2,2)=aggj1(l,4)
2607           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2608           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2609      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2610         enddo
2611         endif
2612       else if (j.eq.i+3) then
2613 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2614 C
2615 C               Fourth-order contributions
2616 C
2617 C                 (i+3)o----(i+4)
2618 C                     /  |
2619 C               (i+2)o   |
2620 C                     \  |
2621 C                 (i+1)o----i
2622 C
2623 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2624 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2625         iti1=itortyp(itype(i+1))
2626         iti2=itortyp(itype(i+2))
2627         iti3=itortyp(itype(i+3))
2628         call transpose2(EUg(1,1,i+1),e1t(1,1))
2629         call transpose2(Eug(1,1,i+2),e2t(1,1))
2630         call transpose2(Eug(1,1,i+3),e3t(1,1))
2631         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2632         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2633         s1=scalar2(b1(1,iti2),auxvec(1))
2634         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2635         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2636         s2=scalar2(b1(1,iti1),auxvec(1))
2637         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2638         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2639         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2640         eello_turn4=eello_turn4-(s1+s2+s3)
2641 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2642 cd     &    ' eello_turn4_num',8*eello_turn4_num
2643 C Derivatives in gamma(i)
2644         if (calc_grad) then
2645         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2646         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2647         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2648         s1=scalar2(b1(1,iti2),auxvec(1))
2649         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2650         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2651         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2652 C Derivatives in gamma(i+1)
2653         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2654         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2655         s2=scalar2(b1(1,iti1),auxvec(1))
2656         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2657         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2658         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2659         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2660 C Derivatives in gamma(i+2)
2661         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2662         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2663         s1=scalar2(b1(1,iti2),auxvec(1))
2664         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2665         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2666         s2=scalar2(b1(1,iti1),auxvec(1))
2667         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2668         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2669         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2670         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2671 C Cartesian derivatives
2672 C Derivatives of this turn contributions in DC(i+2)
2673         if (j.lt.nres-1) then
2674           do l=1,3
2675             a_temp(1,1)=agg(l,1)
2676             a_temp(1,2)=agg(l,2)
2677             a_temp(2,1)=agg(l,3)
2678             a_temp(2,2)=agg(l,4)
2679             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2680             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2681             s1=scalar2(b1(1,iti2),auxvec(1))
2682             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2683             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2684             s2=scalar2(b1(1,iti1),auxvec(1))
2685             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2686             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2687             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2688             ggg(l)=-(s1+s2+s3)
2689             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2690           enddo
2691         endif
2692 C Remaining derivatives of this turn contribution
2693         do l=1,3
2694           a_temp(1,1)=aggi(l,1)
2695           a_temp(1,2)=aggi(l,2)
2696           a_temp(2,1)=aggi(l,3)
2697           a_temp(2,2)=aggi(l,4)
2698           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2699           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2700           s1=scalar2(b1(1,iti2),auxvec(1))
2701           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2702           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2703           s2=scalar2(b1(1,iti1),auxvec(1))
2704           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2705           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2706           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2707           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2708           a_temp(1,1)=aggi1(l,1)
2709           a_temp(1,2)=aggi1(l,2)
2710           a_temp(2,1)=aggi1(l,3)
2711           a_temp(2,2)=aggi1(l,4)
2712           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2713           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2714           s1=scalar2(b1(1,iti2),auxvec(1))
2715           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2716           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2717           s2=scalar2(b1(1,iti1),auxvec(1))
2718           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2719           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2720           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2721           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2722           a_temp(1,1)=aggj(l,1)
2723           a_temp(1,2)=aggj(l,2)
2724           a_temp(2,1)=aggj(l,3)
2725           a_temp(2,2)=aggj(l,4)
2726           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2727           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2728           s1=scalar2(b1(1,iti2),auxvec(1))
2729           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2730           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2731           s2=scalar2(b1(1,iti1),auxvec(1))
2732           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2733           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2734           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2735           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2736           a_temp(1,1)=aggj1(l,1)
2737           a_temp(1,2)=aggj1(l,2)
2738           a_temp(2,1)=aggj1(l,3)
2739           a_temp(2,2)=aggj1(l,4)
2740           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2741           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2742           s1=scalar2(b1(1,iti2),auxvec(1))
2743           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2744           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2745           s2=scalar2(b1(1,iti1),auxvec(1))
2746           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2747           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2748           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2749           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2750         enddo
2751         endif
2752       endif
2753       return
2754       end
2755 C-----------------------------------------------------------------------------
2756       subroutine vecpr(u,v,w)
2757       implicit real*8(a-h,o-z)
2758       dimension u(3),v(3),w(3)
2759       w(1)=u(2)*v(3)-u(3)*v(2)
2760       w(2)=-u(1)*v(3)+u(3)*v(1)
2761       w(3)=u(1)*v(2)-u(2)*v(1)
2762       return
2763       end
2764 C-----------------------------------------------------------------------------
2765       subroutine unormderiv(u,ugrad,unorm,ungrad)
2766 C This subroutine computes the derivatives of a normalized vector u, given
2767 C the derivatives computed without normalization conditions, ugrad. Returns
2768 C ungrad.
2769       implicit none
2770       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2771       double precision vec(3)
2772       double precision scalar
2773       integer i,j
2774 c      write (2,*) 'ugrad',ugrad
2775 c      write (2,*) 'u',u
2776       do i=1,3
2777         vec(i)=scalar(ugrad(1,i),u(1))
2778       enddo
2779 c      write (2,*) 'vec',vec
2780       do i=1,3
2781         do j=1,3
2782           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2783         enddo
2784       enddo
2785 c      write (2,*) 'ungrad',ungrad
2786       return
2787       end
2788 C-----------------------------------------------------------------------------
2789       subroutine escp(evdw2,evdw2_14)
2790 C
2791 C This subroutine calculates the excluded-volume interaction energy between
2792 C peptide-group centers and side chains and its gradient in virtual-bond and
2793 C side-chain vectors.
2794 C
2795       implicit real*8 (a-h,o-z)
2796       include 'DIMENSIONS'
2797       include 'DIMENSIONS.ZSCOPT'
2798       include 'COMMON.GEO'
2799       include 'COMMON.VAR'
2800       include 'COMMON.LOCAL'
2801       include 'COMMON.CHAIN'
2802       include 'COMMON.DERIV'
2803       include 'COMMON.INTERACT'
2804       include 'COMMON.FFIELD'
2805       include 'COMMON.IOUNITS'
2806       dimension ggg(3)
2807       evdw2=0.0D0
2808       evdw2_14=0.0d0
2809 cd    print '(a)','Enter ESCP'
2810 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2811 c     &  ' scal14',scal14
2812       do i=iatscp_s,iatscp_e
2813         iteli=itel(i)
2814 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2815 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2816         if (iteli.eq.0) goto 1225
2817         xi=0.5D0*(c(1,i)+c(1,i+1))
2818         yi=0.5D0*(c(2,i)+c(2,i+1))
2819         zi=0.5D0*(c(3,i)+c(3,i+1))
2820
2821         do iint=1,nscp_gr(i)
2822
2823         do j=iscpstart(i,iint),iscpend(i,iint)
2824           itypj=itype(j)
2825 C Uncomment following three lines for SC-p interactions
2826 c         xj=c(1,nres+j)-xi
2827 c         yj=c(2,nres+j)-yi
2828 c         zj=c(3,nres+j)-zi
2829 C Uncomment following three lines for Ca-p interactions
2830           xj=c(1,j)-xi
2831           yj=c(2,j)-yi
2832           zj=c(3,j)-zi
2833           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2834           fac=rrij**expon2
2835           e1=fac*fac*aad(itypj,iteli)
2836           e2=fac*bad(itypj,iteli)
2837           if (iabs(j-i) .le. 2) then
2838             e1=scal14*e1
2839             e2=scal14*e2
2840             evdw2_14=evdw2_14+e1+e2
2841           endif
2842           evdwij=e1+e2
2843 c          write (iout,*) i,j,evdwij
2844           evdw2=evdw2+evdwij
2845           if (calc_grad) then
2846 C
2847 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2848 C
2849           fac=-(evdwij+e1)*rrij
2850           ggg(1)=xj*fac
2851           ggg(2)=yj*fac
2852           ggg(3)=zj*fac
2853           if (j.lt.i) then
2854 cd          write (iout,*) 'j<i'
2855 C Uncomment following three lines for SC-p interactions
2856 c           do k=1,3
2857 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2858 c           enddo
2859           else
2860 cd          write (iout,*) 'j>i'
2861             do k=1,3
2862               ggg(k)=-ggg(k)
2863 C Uncomment following line for SC-p interactions
2864 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2865             enddo
2866           endif
2867           do k=1,3
2868             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2869           enddo
2870           kstart=min0(i+1,j)
2871           kend=max0(i-1,j-1)
2872 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2873 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2874           do k=kstart,kend
2875             do l=1,3
2876               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2877             enddo
2878           enddo
2879           endif
2880         enddo
2881         enddo ! iint
2882  1225   continue
2883       enddo ! i
2884       do i=1,nct
2885         do j=1,3
2886           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2887           gradx_scp(j,i)=expon*gradx_scp(j,i)
2888         enddo
2889       enddo
2890 C******************************************************************************
2891 C
2892 C                              N O T E !!!
2893 C
2894 C To save time the factor EXPON has been extracted from ALL components
2895 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2896 C use!
2897 C
2898 C******************************************************************************
2899       return
2900       end
2901 C--------------------------------------------------------------------------
2902       subroutine edis(ehpb)
2903 C
2904 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2905 C
2906       implicit real*8 (a-h,o-z)
2907       include 'DIMENSIONS'
2908       include 'COMMON.SBRIDGE'
2909       include 'COMMON.CHAIN'
2910       include 'COMMON.DERIV'
2911       include 'COMMON.VAR'
2912       include 'COMMON.INTERACT'
2913       include 'COMMON.IOUNITS'
2914       dimension ggg(3)
2915       ehpb=0.0D0
2916 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2917 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2918       if (link_end.eq.0) return
2919       do i=link_start,link_end
2920 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2921 C CA-CA distance used in regularization of structure.
2922         ii=ihpb(i)
2923         jj=jhpb(i)
2924 C iii and jjj point to the residues for which the distance is assigned.
2925         if (ii.gt.nres) then
2926           iii=ii-nres
2927           jjj=jj-nres
2928         else
2929           iii=ii
2930           jjj=jj
2931         endif
2932 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2933 c     &    dhpb(i),dhpb1(i),forcon(i)
2934 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2935 C    distance and angle dependent SS bond potential.
2936         if (.not.dyn_ss .and. i.le.nss) then
2937 C 15/02/13 CC dynamic SSbond - additional check
2938         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2939           call ssbond_ene(iii,jjj,eij)
2940           ehpb=ehpb+2*eij
2941          endif
2942 cd          write (iout,*) "eij",eij
2943         else if (ii.gt.nres .and. jj.gt.nres) then
2944 c Restraints from contact prediction
2945           dd=dist(ii,jj)
2946           if (dhpb1(i).gt.0.0d0) then
2947             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2948             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2949 c            write (iout,*) "beta nmr",
2950 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2951           else
2952             dd=dist(ii,jj)
2953             rdis=dd-dhpb(i)
2954 C Get the force constant corresponding to this distance.
2955             waga=forcon(i)
2956 C Calculate the contribution to energy.
2957             ehpb=ehpb+waga*rdis*rdis
2958 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2959 C
2960 C Evaluate gradient.
2961 C
2962             fac=waga*rdis/dd
2963           endif
2964           do j=1,3
2965             ggg(j)=fac*(c(j,jj)-c(j,ii))
2966           enddo
2967           do j=1,3
2968             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2969             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2970           enddo
2971           do k=1,3
2972             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2973             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2974           enddo
2975         else
2976 C Calculate the distance between the two points and its difference from the
2977 C target distance.
2978           dd=dist(ii,jj)
2979           if (dhpb1(i).gt.0.0d0) then
2980             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2981             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2982 c            write (iout,*) "alph nmr",
2983 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2984           else
2985             rdis=dd-dhpb(i)
2986 C Get the force constant corresponding to this distance.
2987             waga=forcon(i)
2988 C Calculate the contribution to energy.
2989             ehpb=ehpb+waga*rdis*rdis
2990 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2991 C
2992 C Evaluate gradient.
2993 C
2994             fac=waga*rdis/dd
2995           endif
2996 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2997 cd   &   ' waga=',waga,' fac=',fac
2998             do j=1,3
2999               ggg(j)=fac*(c(j,jj)-c(j,ii))
3000             enddo
3001 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3002 C If this is a SC-SC distance, we need to calculate the contributions to the
3003 C Cartesian gradient in the SC vectors (ghpbx).
3004           if (iii.lt.ii) then
3005           do j=1,3
3006             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3007             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3008           enddo
3009           endif
3010           do k=1,3
3011             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3012             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3013           enddo
3014         endif
3015       enddo
3016       ehpb=0.5D0*ehpb
3017       return
3018       end
3019 C--------------------------------------------------------------------------
3020       subroutine ssbond_ene(i,j,eij)
3021 C
3022 C Calculate the distance and angle dependent SS-bond potential energy
3023 C using a free-energy function derived based on RHF/6-31G** ab initio
3024 C calculations of diethyl disulfide.
3025 C
3026 C A. Liwo and U. Kozlowska, 11/24/03
3027 C
3028       implicit real*8 (a-h,o-z)
3029       include 'DIMENSIONS'
3030       include 'DIMENSIONS.ZSCOPT'
3031       include 'COMMON.SBRIDGE'
3032       include 'COMMON.CHAIN'
3033       include 'COMMON.DERIV'
3034       include 'COMMON.LOCAL'
3035       include 'COMMON.INTERACT'
3036       include 'COMMON.VAR'
3037       include 'COMMON.IOUNITS'
3038       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3039       itypi=itype(i)
3040       xi=c(1,nres+i)
3041       yi=c(2,nres+i)
3042       zi=c(3,nres+i)
3043       dxi=dc_norm(1,nres+i)
3044       dyi=dc_norm(2,nres+i)
3045       dzi=dc_norm(3,nres+i)
3046       dsci_inv=dsc_inv(itypi)
3047       itypj=itype(j)
3048       dscj_inv=dsc_inv(itypj)
3049       xj=c(1,nres+j)-xi
3050       yj=c(2,nres+j)-yi
3051       zj=c(3,nres+j)-zi
3052       dxj=dc_norm(1,nres+j)
3053       dyj=dc_norm(2,nres+j)
3054       dzj=dc_norm(3,nres+j)
3055       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3056       rij=dsqrt(rrij)
3057       erij(1)=xj*rij
3058       erij(2)=yj*rij
3059       erij(3)=zj*rij
3060       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3061       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3062       om12=dxi*dxj+dyi*dyj+dzi*dzj
3063       do k=1,3
3064         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3065         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3066       enddo
3067       rij=1.0d0/rij
3068       deltad=rij-d0cm
3069       deltat1=1.0d0-om1
3070       deltat2=1.0d0+om2
3071       deltat12=om2-om1+2.0d0
3072       cosphi=om12-om1*om2
3073       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3074      &  +akct*deltad*deltat12+ebr
3075 c     &  +akct*deltad*deltat12
3076      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3077       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3078      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3079      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3080       ed=2*akcm*deltad+akct*deltat12
3081       pom1=akct*deltad
3082       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3083       eom1=-2*akth*deltat1-pom1-om2*pom2
3084       eom2= 2*akth*deltat2+pom1-om1*pom2
3085       eom12=pom2
3086       do k=1,3
3087         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3088       enddo
3089       do k=1,3
3090         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3091      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3092         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3093      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3094       enddo
3095 C
3096 C Calculate the components of the gradient in DC and X
3097 C
3098       do k=i,j-1
3099         do l=1,3
3100           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3101         enddo
3102       enddo
3103       return
3104       end
3105 C--------------------------------------------------------------------------
3106 c MODELLER restraint function
3107       subroutine e_modeller(ehomology_constr)
3108       implicit real*8 (a-h,o-z)
3109       include 'DIMENSIONS'
3110
3111       integer nnn, i, j, k, ki, irec, l
3112       integer katy, odleglosci, test7
3113       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3114       real*8 distance(max_template),distancek(max_template),
3115      &    min_odl,godl(max_template),dih_diff(max_template)
3116
3117       include 'COMMON.SBRIDGE'
3118       include 'COMMON.CHAIN'
3119       include 'COMMON.GEO'
3120       include 'COMMON.DERIV'
3121       include 'COMMON.LOCAL'
3122       include 'COMMON.INTERACT'
3123       include 'COMMON.VAR'
3124       include 'COMMON.IOUNITS'
3125       include 'COMMON.CONTROL'
3126
3127
3128       do i=1,19
3129         distancek(i)=9999999.9
3130       enddo
3131
3132
3133       odleg=0.0d0
3134 c      write (iout,*) "waga_dist",waga_dist
3135
3136 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3137 c function)
3138 C AL 5/2/14 - Introduce list of restraints
3139       do ii = link_start_homo,link_end_homo
3140          i = ires_homo(ii)
3141          j = jres_homo(ii)
3142          dij=dist(i,j)
3143          do k=1,constr_homology
3144            distance(k)=odl(k,ii)-dij
3145            distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3146          enddo
3147
3148          min_odl=minval(distancek)
3149 #ifdef DEBUG
3150          write (iout,*) "ij dij",i,j,dij
3151          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3152          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3153          write (iout,* )"min_odl",min_odl
3154 #endif
3155          odleg2=0.0d0
3156          do k=1,constr_homology
3157 c Nie wiem po co to liczycie jeszcze raz!
3158 c            odleg3=-waga_dist*((distance(i,j,k)**2)/
3159 c     &              (2*(sigma_odl(i,j,k))**2))
3160             godl(k)=dexp(-distancek(k)+min_odl)
3161             odleg2=odleg2+godl(k)
3162
3163 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3164 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3165 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3166 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3167
3168          enddo
3169 #ifdef DEBUG
3170          write (iout,*) "godl",(godl(k),k=1,constr_homology)
3171          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
3172 #endif
3173          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3174 c Gradient
3175          sum_godl=odleg2
3176          sum_sgodl=0.0
3177          do k=1,constr_homology
3178 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3179 c     &           *waga_dist)+min_odl
3180            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3181            sum_sgodl=sum_sgodl+sgodl
3182
3183 c            sgodl2=sgodl2+sgodl
3184 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3185 c      write(iout,*) "constr_homology=",constr_homology
3186 c      write(iout,*) i, j, k, "TEST K"
3187          enddo
3188
3189          grad_odl3=sum_sgodl/(sum_godl*dij)
3190
3191
3192 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3193 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3194 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3195
3196 ccc      write(iout,*) godl, sgodl, grad_odl3
3197
3198 c          grad_odl=grad_odl+grad_odl3
3199
3200          do jik=1,3
3201             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3202 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3203 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3204 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3205             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3206             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3207 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3208 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3209
3210          enddo
3211 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3212 ccc     & dLOG(odleg2),"-odleg=", -odleg
3213
3214       enddo ! ii
3215 c Pseudo-energy and gradient from dihedral-angle restraints from
3216 c homology templates
3217 c      write (iout,*) "End of distance loop"
3218 c      call flush(iout)
3219       kat=0.0d0
3220 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3221       do i=idihconstr_start_homo,idihconstr_end_homo
3222         kat2=0.0d0
3223 c        betai=beta(i,i+1,i+2,i+3)
3224         betai = phi(i+3)
3225         do k=1,constr_homology
3226           dih_diff(k)=pinorm(dih(k,i)-betai)
3227 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3228 c     &                                   -(6.28318-dih_diff(i,k))
3229 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3230 c     &                                   6.28318+dih_diff(i,k)
3231
3232           kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3233           gdih(k)=dexp(kat3)
3234           kat2=kat2+gdih(k)
3235 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3236 c          write(*,*)""
3237         enddo
3238 #ifdef DEBUG
3239         write (iout,*) "i",i," betai",betai," kat2",kat2
3240         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3241 #endif
3242         if (kat2.le.1.0d-14) cycle
3243         kat=kat-dLOG(kat2/constr_homology)
3244
3245 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3246 ccc     & dLOG(kat2), "-kat=", -kat
3247
3248 c ----------------------------------------------------------------------
3249 c Gradient
3250 c ----------------------------------------------------------------------
3251
3252         sum_gdih=kat2
3253         sum_sgdih=0.0
3254         do k=1,constr_homology
3255           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3256           sum_sgdih=sum_sgdih+sgdih
3257         enddo
3258         grad_dih3=sum_sgdih/sum_gdih
3259
3260 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3261 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3262 ccc     & gloc(nphi+i-3,icg)
3263         gloc(i,icg)=gloc(i,icg)+grad_dih3
3264 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3265 ccc     & gloc(nphi+i-3,icg)
3266
3267       enddo
3268
3269
3270 c Total energy from homology restraints
3271 #ifdef DEBUG
3272       write (iout,*) "odleg",odleg," kat",kat
3273 #endif
3274       ehomology_constr=odleg+kat
3275       return
3276
3277   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3278   747 format(a12,i4,i4,i4,f8.3,f8.3)
3279   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3280   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3281   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3282      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3283       end
3284 c-----------------------------------------------------------------------
3285       subroutine ebond(estr)
3286 c
3287 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3288 c
3289       implicit real*8 (a-h,o-z)
3290       include 'DIMENSIONS'
3291       include 'DIMENSIONS.ZSCOPT'
3292       include 'COMMON.LOCAL'
3293       include 'COMMON.GEO'
3294       include 'COMMON.INTERACT'
3295       include 'COMMON.DERIV'
3296       include 'COMMON.VAR'
3297       include 'COMMON.CHAIN'
3298       include 'COMMON.IOUNITS'
3299       include 'COMMON.NAMES'
3300       include 'COMMON.FFIELD'
3301       include 'COMMON.CONTROL'
3302       double precision u(3),ud(3)
3303       logical :: lprn=.false.
3304       estr=0.0d0
3305       do i=nnt+1,nct
3306         diff = vbld(i)-vbldp0
3307 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3308         estr=estr+diff*diff
3309         do j=1,3
3310           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3311         enddo
3312       enddo
3313       estr=0.5d0*AKP*estr
3314 c
3315 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3316 c
3317       do i=nnt,nct
3318         iti=itype(i)
3319         if (iti.ne.10) then
3320           nbi=nbondterm(iti)
3321           if (nbi.eq.1) then
3322             diff=vbld(i+nres)-vbldsc0(1,iti)
3323             if (lprn)
3324      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3325      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3326             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3327             do j=1,3
3328               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3329             enddo
3330           else
3331             do j=1,nbi
3332               diff=vbld(i+nres)-vbldsc0(j,iti)
3333               ud(j)=aksc(j,iti)*diff
3334               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3335             enddo
3336             uprod=u(1)
3337             do j=2,nbi
3338               uprod=uprod*u(j)
3339             enddo
3340             usum=0.0d0
3341             usumsqder=0.0d0
3342             do j=1,nbi
3343               uprod1=1.0d0
3344               uprod2=1.0d0
3345               do k=1,nbi
3346                 if (k.ne.j) then
3347                   uprod1=uprod1*u(k)
3348                   uprod2=uprod2*u(k)*u(k)
3349                 endif
3350               enddo
3351               usum=usum+uprod1
3352               usumsqder=usumsqder+ud(j)*uprod2
3353             enddo
3354             if (lprn)
3355      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3356      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3357             estr=estr+uprod/usum
3358             do j=1,3
3359              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3360             enddo
3361           endif
3362         endif
3363       enddo
3364       return
3365       end
3366 #ifdef CRYST_THETA
3367 C--------------------------------------------------------------------------
3368       subroutine ebend(etheta)
3369 C
3370 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3371 C angles gamma and its derivatives in consecutive thetas and gammas.
3372 C
3373       implicit real*8 (a-h,o-z)
3374       include 'DIMENSIONS'
3375       include 'DIMENSIONS.ZSCOPT'
3376       include 'COMMON.LOCAL'
3377       include 'COMMON.GEO'
3378       include 'COMMON.INTERACT'
3379       include 'COMMON.DERIV'
3380       include 'COMMON.VAR'
3381       include 'COMMON.CHAIN'
3382       include 'COMMON.IOUNITS'
3383       include 'COMMON.NAMES'
3384       include 'COMMON.FFIELD'
3385       common /calcthet/ term1,term2,termm,diffak,ratak,
3386      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3387      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3388       double precision y(2),z(2)
3389       delta=0.02d0*pi
3390       time11=dexp(-2*time)
3391       time12=1.0d0
3392       etheta=0.0D0
3393 c      write (iout,*) "nres",nres
3394 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3395 c      write (iout,*) ithet_start,ithet_end
3396       do i=ithet_start,ithet_end
3397 C Zero the energy function and its derivative at 0 or pi.
3398         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3399         it=itype(i-1)
3400 c        if (i.gt.ithet_start .and.
3401 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3402 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3403 c          phii=phi(i)
3404 c          y(1)=dcos(phii)
3405 c          y(2)=dsin(phii)
3406 c        else
3407 c          y(1)=0.0D0
3408 c          y(2)=0.0D0
3409 c        endif
3410 c        if (i.lt.nres .and. itel(i).ne.0) then
3411 c          phii1=phi(i+1)
3412 c          z(1)=dcos(phii1)
3413 c          z(2)=dsin(phii1)
3414 c        else
3415 c          z(1)=0.0D0
3416 c          z(2)=0.0D0
3417 c        endif
3418         if (i.gt.3) then
3419 #ifdef OSF
3420           phii=phi(i)
3421           icrc=0
3422           call proc_proc(phii,icrc)
3423           if (icrc.eq.1) phii=150.0
3424 #else
3425           phii=phi(i)
3426 #endif
3427           y(1)=dcos(phii)
3428           y(2)=dsin(phii)
3429         else
3430           y(1)=0.0D0
3431           y(2)=0.0D0
3432         endif
3433         if (i.lt.nres) then
3434 #ifdef OSF
3435           phii1=phi(i+1)
3436           icrc=0
3437           call proc_proc(phii1,icrc)
3438           if (icrc.eq.1) phii1=150.0
3439           phii1=pinorm(phii1)
3440           z(1)=cos(phii1)
3441 #else
3442           phii1=phi(i+1)
3443           z(1)=dcos(phii1)
3444 #endif
3445           z(2)=dsin(phii1)
3446         else
3447           z(1)=0.0D0
3448           z(2)=0.0D0
3449         endif
3450 C Calculate the "mean" value of theta from the part of the distribution
3451 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3452 C In following comments this theta will be referred to as t_c.
3453         thet_pred_mean=0.0d0
3454         do k=1,2
3455           athetk=athet(k,it)
3456           bthetk=bthet(k,it)
3457           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3458         enddo
3459 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3460         dthett=thet_pred_mean*ssd
3461         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3462 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3463 C Derivatives of the "mean" values in gamma1 and gamma2.
3464         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3465         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3466         if (theta(i).gt.pi-delta) then
3467           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3468      &         E_tc0)
3469           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3470           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3471           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3472      &        E_theta)
3473           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3474      &        E_tc)
3475         else if (theta(i).lt.delta) then
3476           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3477           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3478           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3479      &        E_theta)
3480           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3481           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3482      &        E_tc)
3483         else
3484           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3485      &        E_theta,E_tc)
3486         endif
3487         etheta=etheta+ethetai
3488 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3489 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3490         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3491         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3492         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3493  1215   continue
3494       enddo
3495 C Ufff.... We've done all this!!!
3496       return
3497       end
3498 C---------------------------------------------------------------------------
3499       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3500      &     E_tc)
3501       implicit real*8 (a-h,o-z)
3502       include 'DIMENSIONS'
3503       include 'COMMON.LOCAL'
3504       include 'COMMON.IOUNITS'
3505       common /calcthet/ term1,term2,termm,diffak,ratak,
3506      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3507      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3508 C Calculate the contributions to both Gaussian lobes.
3509 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3510 C The "polynomial part" of the "standard deviation" of this part of
3511 C the distribution.
3512         sig=polthet(3,it)
3513         do j=2,0,-1
3514           sig=sig*thet_pred_mean+polthet(j,it)
3515         enddo
3516 C Derivative of the "interior part" of the "standard deviation of the"
3517 C gamma-dependent Gaussian lobe in t_c.
3518         sigtc=3*polthet(3,it)
3519         do j=2,1,-1
3520           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3521         enddo
3522         sigtc=sig*sigtc
3523 C Set the parameters of both Gaussian lobes of the distribution.
3524 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3525         fac=sig*sig+sigc0(it)
3526         sigcsq=fac+fac
3527         sigc=1.0D0/sigcsq
3528 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3529         sigsqtc=-4.0D0*sigcsq*sigtc
3530 c       print *,i,sig,sigtc,sigsqtc
3531 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3532         sigtc=-sigtc/(fac*fac)
3533 C Following variable is sigma(t_c)**(-2)
3534         sigcsq=sigcsq*sigcsq
3535         sig0i=sig0(it)
3536         sig0inv=1.0D0/sig0i**2
3537         delthec=thetai-thet_pred_mean
3538         delthe0=thetai-theta0i
3539         term1=-0.5D0*sigcsq*delthec*delthec
3540         term2=-0.5D0*sig0inv*delthe0*delthe0
3541 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3542 C NaNs in taking the logarithm. We extract the largest exponent which is added
3543 C to the energy (this being the log of the distribution) at the end of energy
3544 C term evaluation for this virtual-bond angle.
3545         if (term1.gt.term2) then
3546           termm=term1
3547           term2=dexp(term2-termm)
3548           term1=1.0d0
3549         else
3550           termm=term2
3551           term1=dexp(term1-termm)
3552           term2=1.0d0
3553         endif
3554 C The ratio between the gamma-independent and gamma-dependent lobes of
3555 C the distribution is a Gaussian function of thet_pred_mean too.
3556         diffak=gthet(2,it)-thet_pred_mean
3557         ratak=diffak/gthet(3,it)**2
3558         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3559 C Let's differentiate it in thet_pred_mean NOW.
3560         aktc=ak*ratak
3561 C Now put together the distribution terms to make complete distribution.
3562         termexp=term1+ak*term2
3563         termpre=sigc+ak*sig0i
3564 C Contribution of the bending energy from this theta is just the -log of
3565 C the sum of the contributions from the two lobes and the pre-exponential
3566 C factor. Simple enough, isn't it?
3567         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3568 C NOW the derivatives!!!
3569 C 6/6/97 Take into account the deformation.
3570         E_theta=(delthec*sigcsq*term1
3571      &       +ak*delthe0*sig0inv*term2)/termexp
3572         E_tc=((sigtc+aktc*sig0i)/termpre
3573      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3574      &       aktc*term2)/termexp)
3575       return
3576       end
3577 c-----------------------------------------------------------------------------
3578       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3579       implicit real*8 (a-h,o-z)
3580       include 'DIMENSIONS'
3581       include 'COMMON.LOCAL'
3582       include 'COMMON.IOUNITS'
3583       common /calcthet/ term1,term2,termm,diffak,ratak,
3584      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3585      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3586       delthec=thetai-thet_pred_mean
3587       delthe0=thetai-theta0i
3588 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3589       t3 = thetai-thet_pred_mean
3590       t6 = t3**2
3591       t9 = term1
3592       t12 = t3*sigcsq
3593       t14 = t12+t6*sigsqtc
3594       t16 = 1.0d0
3595       t21 = thetai-theta0i
3596       t23 = t21**2
3597       t26 = term2
3598       t27 = t21*t26
3599       t32 = termexp
3600       t40 = t32**2
3601       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3602      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3603      & *(-t12*t9-ak*sig0inv*t27)
3604       return
3605       end
3606 #else
3607 C--------------------------------------------------------------------------
3608       subroutine ebend(etheta)
3609 C
3610 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3611 C angles gamma and its derivatives in consecutive thetas and gammas.
3612 C ab initio-derived potentials from
3613 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3614 C
3615       implicit real*8 (a-h,o-z)
3616       include 'DIMENSIONS'
3617       include 'DIMENSIONS.ZSCOPT'
3618       include 'COMMON.LOCAL'
3619       include 'COMMON.GEO'
3620       include 'COMMON.INTERACT'
3621       include 'COMMON.DERIV'
3622       include 'COMMON.VAR'
3623       include 'COMMON.CHAIN'
3624       include 'COMMON.IOUNITS'
3625       include 'COMMON.NAMES'
3626       include 'COMMON.FFIELD'
3627       include 'COMMON.CONTROL'
3628       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3629      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3630      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3631      & sinph1ph2(maxdouble,maxdouble)
3632       logical lprn /.false./, lprn1 /.false./
3633       etheta=0.0D0
3634 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3635       do i=ithet_start,ithet_end
3636         dethetai=0.0d0
3637         dephii=0.0d0
3638         dephii1=0.0d0
3639         theti2=0.5d0*theta(i)
3640         ityp2=ithetyp(itype(i-1))
3641         do k=1,nntheterm
3642           coskt(k)=dcos(k*theti2)
3643           sinkt(k)=dsin(k*theti2)
3644         enddo
3645         if (i.gt.3) then
3646 #ifdef OSF
3647           phii=phi(i)
3648           if (phii.ne.phii) phii=150.0
3649 #else
3650           phii=phi(i)
3651 #endif
3652           ityp1=ithetyp(itype(i-2))
3653           do k=1,nsingle
3654             cosph1(k)=dcos(k*phii)
3655             sinph1(k)=dsin(k*phii)
3656           enddo
3657         else
3658           phii=0.0d0
3659           ityp1=nthetyp+1
3660           do k=1,nsingle
3661             cosph1(k)=0.0d0
3662             sinph1(k)=0.0d0
3663           enddo
3664         endif
3665         if (i.lt.nres) then
3666 #ifdef OSF
3667           phii1=phi(i+1)
3668           if (phii1.ne.phii1) phii1=150.0
3669           phii1=pinorm(phii1)
3670 #else
3671           phii1=phi(i+1)
3672 #endif
3673           ityp3=ithetyp(itype(i))
3674           do k=1,nsingle
3675             cosph2(k)=dcos(k*phii1)
3676             sinph2(k)=dsin(k*phii1)
3677           enddo
3678         else
3679           phii1=0.0d0
3680           ityp3=nthetyp+1
3681           do k=1,nsingle
3682             cosph2(k)=0.0d0
3683             sinph2(k)=0.0d0
3684           enddo
3685         endif
3686 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3687 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3688 c        call flush(iout)
3689         ethetai=aa0thet(ityp1,ityp2,ityp3)
3690         do k=1,ndouble
3691           do l=1,k-1
3692             ccl=cosph1(l)*cosph2(k-l)
3693             ssl=sinph1(l)*sinph2(k-l)
3694             scl=sinph1(l)*cosph2(k-l)
3695             csl=cosph1(l)*sinph2(k-l)
3696             cosph1ph2(l,k)=ccl-ssl
3697             cosph1ph2(k,l)=ccl+ssl
3698             sinph1ph2(l,k)=scl+csl
3699             sinph1ph2(k,l)=scl-csl
3700           enddo
3701         enddo
3702         if (lprn) then
3703         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3704      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3705         write (iout,*) "coskt and sinkt"
3706         do k=1,nntheterm
3707           write (iout,*) k,coskt(k),sinkt(k)
3708         enddo
3709         endif
3710         do k=1,ntheterm
3711           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3712           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3713      &      *coskt(k)
3714           if (lprn)
3715      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3716      &     " ethetai",ethetai
3717         enddo
3718         if (lprn) then
3719         write (iout,*) "cosph and sinph"
3720         do k=1,nsingle
3721           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3722         enddo
3723         write (iout,*) "cosph1ph2 and sinph2ph2"
3724         do k=2,ndouble
3725           do l=1,k-1
3726             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3727      &         sinph1ph2(l,k),sinph1ph2(k,l)
3728           enddo
3729         enddo
3730         write(iout,*) "ethetai",ethetai
3731         endif
3732         do m=1,ntheterm2
3733           do k=1,nsingle
3734             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3735      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3736      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3737      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3738             ethetai=ethetai+sinkt(m)*aux
3739             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3740             dephii=dephii+k*sinkt(m)*(
3741      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3742      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3743             dephii1=dephii1+k*sinkt(m)*(
3744      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3745      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3746             if (lprn)
3747      &      write (iout,*) "m",m," k",k," bbthet",
3748      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3749      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3750      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3751      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3752           enddo
3753         enddo
3754         if (lprn)
3755      &  write(iout,*) "ethetai",ethetai
3756         do m=1,ntheterm3
3757           do k=2,ndouble
3758             do l=1,k-1
3759               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3760      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3761      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3762      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3763               ethetai=ethetai+sinkt(m)*aux
3764               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3765               dephii=dephii+l*sinkt(m)*(
3766      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3767      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3768      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3769      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3770               dephii1=dephii1+(k-l)*sinkt(m)*(
3771      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3772      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3773      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3774      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3775               if (lprn) then
3776               write (iout,*) "m",m," k",k," l",l," ffthet",
3777      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3778      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3779      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3780      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3781               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3782      &            cosph1ph2(k,l)*sinkt(m),
3783      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3784               endif
3785             enddo
3786           enddo
3787         enddo
3788 10      continue
3789 c        lprn1=.true.
3790         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
3791      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
3792      &   phii1*rad2deg,ethetai
3793 c        lprn1=.false.
3794         etheta=etheta+ethetai
3795
3796         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3797         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3798         gloc(nphi+i-2,icg)=wang*dethetai
3799       enddo
3800       return
3801       end
3802 #endif
3803 #ifdef CRYST_SC
3804 c-----------------------------------------------------------------------------
3805       subroutine esc(escloc)
3806 C Calculate the local energy of a side chain and its derivatives in the
3807 C corresponding virtual-bond valence angles THETA and the spherical angles
3808 C ALPHA and OMEGA.
3809       implicit real*8 (a-h,o-z)
3810       include 'DIMENSIONS'
3811       include 'DIMENSIONS.ZSCOPT'
3812       include 'COMMON.GEO'
3813       include 'COMMON.LOCAL'
3814       include 'COMMON.VAR'
3815       include 'COMMON.INTERACT'
3816       include 'COMMON.DERIV'
3817       include 'COMMON.CHAIN'
3818       include 'COMMON.IOUNITS'
3819       include 'COMMON.NAMES'
3820       include 'COMMON.FFIELD'
3821       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3822      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3823       common /sccalc/ time11,time12,time112,theti,it,nlobit
3824       delta=0.02d0*pi
3825       escloc=0.0D0
3826 c     write (iout,'(a)') 'ESC'
3827       do i=loc_start,loc_end
3828         it=itype(i)
3829         if (it.eq.10) goto 1
3830         nlobit=nlob(it)
3831 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3832 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3833         theti=theta(i+1)-pipol
3834         x(1)=dtan(theti)
3835         x(2)=alph(i)
3836         x(3)=omeg(i)
3837 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3838
3839         if (x(2).gt.pi-delta) then
3840           xtemp(1)=x(1)
3841           xtemp(2)=pi-delta
3842           xtemp(3)=x(3)
3843           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3844           xtemp(2)=pi
3845           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3846           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3847      &        escloci,dersc(2))
3848           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3849      &        ddersc0(1),dersc(1))
3850           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3851      &        ddersc0(3),dersc(3))
3852           xtemp(2)=pi-delta
3853           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3854           xtemp(2)=pi
3855           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3856           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3857      &            dersc0(2),esclocbi,dersc02)
3858           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3859      &            dersc12,dersc01)
3860           call splinthet(x(2),0.5d0*delta,ss,ssd)
3861           dersc0(1)=dersc01
3862           dersc0(2)=dersc02
3863           dersc0(3)=0.0d0
3864           do k=1,3
3865             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3866           enddo
3867           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3868 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3869 c    &             esclocbi,ss,ssd
3870           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3871 c         escloci=esclocbi
3872 c         write (iout,*) escloci
3873         else if (x(2).lt.delta) then
3874           xtemp(1)=x(1)
3875           xtemp(2)=delta
3876           xtemp(3)=x(3)
3877           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3878           xtemp(2)=0.0d0
3879           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3880           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3881      &        escloci,dersc(2))
3882           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3883      &        ddersc0(1),dersc(1))
3884           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3885      &        ddersc0(3),dersc(3))
3886           xtemp(2)=delta
3887           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3888           xtemp(2)=0.0d0
3889           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3890           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3891      &            dersc0(2),esclocbi,dersc02)
3892           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3893      &            dersc12,dersc01)
3894           dersc0(1)=dersc01
3895           dersc0(2)=dersc02
3896           dersc0(3)=0.0d0
3897           call splinthet(x(2),0.5d0*delta,ss,ssd)
3898           do k=1,3
3899             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3900           enddo
3901           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3902 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3903 c    &             esclocbi,ss,ssd
3904           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3905 c         write (iout,*) escloci
3906         else
3907           call enesc(x,escloci,dersc,ddummy,.false.)
3908         endif
3909
3910         escloc=escloc+escloci
3911 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3912
3913         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3914      &   wscloc*dersc(1)
3915         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3916         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3917     1   continue
3918       enddo
3919       return
3920       end
3921 C---------------------------------------------------------------------------
3922       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3923       implicit real*8 (a-h,o-z)
3924       include 'DIMENSIONS'
3925       include 'COMMON.GEO'
3926       include 'COMMON.LOCAL'
3927       include 'COMMON.IOUNITS'
3928       common /sccalc/ time11,time12,time112,theti,it,nlobit
3929       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3930       double precision contr(maxlob,-1:1)
3931       logical mixed
3932 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3933         escloc_i=0.0D0
3934         do j=1,3
3935           dersc(j)=0.0D0
3936           if (mixed) ddersc(j)=0.0d0
3937         enddo
3938         x3=x(3)
3939
3940 C Because of periodicity of the dependence of the SC energy in omega we have
3941 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3942 C To avoid underflows, first compute & store the exponents.
3943
3944         do iii=-1,1
3945
3946           x(3)=x3+iii*dwapi
3947
3948           do j=1,nlobit
3949             do k=1,3
3950               z(k)=x(k)-censc(k,j,it)
3951             enddo
3952             do k=1,3
3953               Axk=0.0D0
3954               do l=1,3
3955                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3956               enddo
3957               Ax(k,j,iii)=Axk
3958             enddo
3959             expfac=0.0D0
3960             do k=1,3
3961               expfac=expfac+Ax(k,j,iii)*z(k)
3962             enddo
3963             contr(j,iii)=expfac
3964           enddo ! j
3965
3966         enddo ! iii
3967
3968         x(3)=x3
3969 C As in the case of ebend, we want to avoid underflows in exponentiation and
3970 C subsequent NaNs and INFs in energy calculation.
3971 C Find the largest exponent
3972         emin=contr(1,-1)
3973         do iii=-1,1
3974           do j=1,nlobit
3975             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3976           enddo
3977         enddo
3978         emin=0.5D0*emin
3979 cd      print *,'it=',it,' emin=',emin
3980
3981 C Compute the contribution to SC energy and derivatives
3982         do iii=-1,1
3983
3984           do j=1,nlobit
3985             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3986 cd          print *,'j=',j,' expfac=',expfac
3987             escloc_i=escloc_i+expfac
3988             do k=1,3
3989               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3990             enddo
3991             if (mixed) then
3992               do k=1,3,2
3993                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3994      &            +gaussc(k,2,j,it))*expfac
3995               enddo
3996             endif
3997           enddo
3998
3999         enddo ! iii
4000
4001         dersc(1)=dersc(1)/cos(theti)**2
4002         ddersc(1)=ddersc(1)/cos(theti)**2
4003         ddersc(3)=ddersc(3)
4004
4005         escloci=-(dlog(escloc_i)-emin)
4006         do j=1,3
4007           dersc(j)=dersc(j)/escloc_i
4008         enddo
4009         if (mixed) then
4010           do j=1,3,2
4011             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4012           enddo
4013         endif
4014       return
4015       end
4016 C------------------------------------------------------------------------------
4017       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4018       implicit real*8 (a-h,o-z)
4019       include 'DIMENSIONS'
4020       include 'COMMON.GEO'
4021       include 'COMMON.LOCAL'
4022       include 'COMMON.IOUNITS'
4023       common /sccalc/ time11,time12,time112,theti,it,nlobit
4024       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4025       double precision contr(maxlob)
4026       logical mixed
4027
4028       escloc_i=0.0D0
4029
4030       do j=1,3
4031         dersc(j)=0.0D0
4032       enddo
4033
4034       do j=1,nlobit
4035         do k=1,2
4036           z(k)=x(k)-censc(k,j,it)
4037         enddo
4038         z(3)=dwapi
4039         do k=1,3
4040           Axk=0.0D0
4041           do l=1,3
4042             Axk=Axk+gaussc(l,k,j,it)*z(l)
4043           enddo
4044           Ax(k,j)=Axk
4045         enddo
4046         expfac=0.0D0
4047         do k=1,3
4048           expfac=expfac+Ax(k,j)*z(k)
4049         enddo
4050         contr(j)=expfac
4051       enddo ! j
4052
4053 C As in the case of ebend, we want to avoid underflows in exponentiation and
4054 C subsequent NaNs and INFs in energy calculation.
4055 C Find the largest exponent
4056       emin=contr(1)
4057       do j=1,nlobit
4058         if (emin.gt.contr(j)) emin=contr(j)
4059       enddo
4060       emin=0.5D0*emin
4061
4062 C Compute the contribution to SC energy and derivatives
4063
4064       dersc12=0.0d0
4065       do j=1,nlobit
4066         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4067         escloc_i=escloc_i+expfac
4068         do k=1,2
4069           dersc(k)=dersc(k)+Ax(k,j)*expfac
4070         enddo
4071         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4072      &            +gaussc(1,2,j,it))*expfac
4073         dersc(3)=0.0d0
4074       enddo
4075
4076       dersc(1)=dersc(1)/cos(theti)**2
4077       dersc12=dersc12/cos(theti)**2
4078       escloci=-(dlog(escloc_i)-emin)
4079       do j=1,2
4080         dersc(j)=dersc(j)/escloc_i
4081       enddo
4082       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4083       return
4084       end
4085 #else
4086 c----------------------------------------------------------------------------------
4087       subroutine esc(escloc)
4088 C Calculate the local energy of a side chain and its derivatives in the
4089 C corresponding virtual-bond valence angles THETA and the spherical angles
4090 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4091 C added by Urszula Kozlowska. 07/11/2007
4092 C
4093       implicit real*8 (a-h,o-z)
4094       include 'DIMENSIONS'
4095       include 'DIMENSIONS.ZSCOPT'
4096       include 'COMMON.GEO'
4097       include 'COMMON.LOCAL'
4098       include 'COMMON.VAR'
4099       include 'COMMON.SCROT'
4100       include 'COMMON.INTERACT'
4101       include 'COMMON.DERIV'
4102       include 'COMMON.CHAIN'
4103       include 'COMMON.IOUNITS'
4104       include 'COMMON.NAMES'
4105       include 'COMMON.FFIELD'
4106       include 'COMMON.CONTROL'
4107       include 'COMMON.VECTORS'
4108       double precision x_prime(3),y_prime(3),z_prime(3)
4109      &    , sumene,dsc_i,dp2_i,x(65),
4110      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4111      &    de_dxx,de_dyy,de_dzz,de_dt
4112       double precision s1_t,s1_6_t,s2_t,s2_6_t
4113       double precision
4114      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4115      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4116      & dt_dCi(3),dt_dCi1(3)
4117       common /sccalc/ time11,time12,time112,theti,it,nlobit
4118       delta=0.02d0*pi
4119       escloc=0.0D0
4120       do i=loc_start,loc_end
4121         costtab(i+1) =dcos(theta(i+1))
4122         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4123         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4124         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4125         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4126         cosfac=dsqrt(cosfac2)
4127         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4128         sinfac=dsqrt(sinfac2)
4129         it=itype(i)
4130         if (it.eq.10) goto 1
4131 c
4132 C  Compute the axes of tghe local cartesian coordinates system; store in
4133 c   x_prime, y_prime and z_prime
4134 c
4135         do j=1,3
4136           x_prime(j) = 0.00
4137           y_prime(j) = 0.00
4138           z_prime(j) = 0.00
4139         enddo
4140 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4141 C     &   dc_norm(3,i+nres)
4142         do j = 1,3
4143           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4144           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4145         enddo
4146         do j = 1,3
4147           z_prime(j) = -uz(j,i-1)
4148         enddo
4149 c       write (2,*) "i",i
4150 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4151 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4152 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4153 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4154 c      & " xy",scalar(x_prime(1),y_prime(1)),
4155 c      & " xz",scalar(x_prime(1),z_prime(1)),
4156 c      & " yy",scalar(y_prime(1),y_prime(1)),
4157 c      & " yz",scalar(y_prime(1),z_prime(1)),
4158 c      & " zz",scalar(z_prime(1),z_prime(1))
4159 c
4160 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4161 C to local coordinate system. Store in xx, yy, zz.
4162 c
4163         xx=0.0d0
4164         yy=0.0d0
4165         zz=0.0d0
4166         do j = 1,3
4167           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4168           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4169           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4170         enddo
4171
4172         xxtab(i)=xx
4173         yytab(i)=yy
4174         zztab(i)=zz
4175 C
4176 C Compute the energy of the ith side cbain
4177 C
4178 c        write (2,*) "xx",xx," yy",yy," zz",zz
4179         it=itype(i)
4180         do j = 1,65
4181           x(j) = sc_parmin(j,it)
4182         enddo
4183 #ifdef CHECK_COORD
4184 Cc diagnostics - remove later
4185         xx1 = dcos(alph(2))
4186         yy1 = dsin(alph(2))*dcos(omeg(2))
4187         zz1 = -dsin(alph(2))*dsin(omeg(2))
4188         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4189      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4190      &    xx1,yy1,zz1
4191 C,"  --- ", xx_w,yy_w,zz_w
4192 c end diagnostics
4193 #endif
4194         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4195      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4196      &   + x(10)*yy*zz
4197         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4198      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4199      & + x(20)*yy*zz
4200         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4201      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4202      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4203      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4204      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4205      &  +x(40)*xx*yy*zz
4206         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4207      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4208      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4209      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4210      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4211      &  +x(60)*xx*yy*zz
4212         dsc_i   = 0.743d0+x(61)
4213         dp2_i   = 1.9d0+x(62)
4214         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4215      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4216         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4217      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4218         s1=(1+x(63))/(0.1d0 + dscp1)
4219         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4220         s2=(1+x(65))/(0.1d0 + dscp2)
4221         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4222         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4223      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4224 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4225 c     &   sumene4,
4226 c     &   dscp1,dscp2,sumene
4227 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4228         escloc = escloc + sumene
4229 c        write (2,*) "escloc",escloc
4230         if (.not. calc_grad) goto 1
4231
4232 #ifdef DEBUG2
4233 C
4234 C This section to check the numerical derivatives of the energy of ith side
4235 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4236 C #define DEBUG in the code to turn it on.
4237 C
4238         write (2,*) "sumene               =",sumene
4239         aincr=1.0d-7
4240         xxsave=xx
4241         xx=xx+aincr
4242         write (2,*) xx,yy,zz
4243         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4244         de_dxx_num=(sumenep-sumene)/aincr
4245         xx=xxsave
4246         write (2,*) "xx+ sumene from enesc=",sumenep
4247         yysave=yy
4248         yy=yy+aincr
4249         write (2,*) xx,yy,zz
4250         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4251         de_dyy_num=(sumenep-sumene)/aincr
4252         yy=yysave
4253         write (2,*) "yy+ sumene from enesc=",sumenep
4254         zzsave=zz
4255         zz=zz+aincr
4256         write (2,*) xx,yy,zz
4257         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4258         de_dzz_num=(sumenep-sumene)/aincr
4259         zz=zzsave
4260         write (2,*) "zz+ sumene from enesc=",sumenep
4261         costsave=cost2tab(i+1)
4262         sintsave=sint2tab(i+1)
4263         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4264         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4265         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4266         de_dt_num=(sumenep-sumene)/aincr
4267         write (2,*) " t+ sumene from enesc=",sumenep
4268         cost2tab(i+1)=costsave
4269         sint2tab(i+1)=sintsave
4270 C End of diagnostics section.
4271 #endif
4272 C
4273 C Compute the gradient of esc
4274 C
4275         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4276         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4277         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4278         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4279         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4280         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4281         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4282         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4283         pom1=(sumene3*sint2tab(i+1)+sumene1)
4284      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4285         pom2=(sumene4*cost2tab(i+1)+sumene2)
4286      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4287         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4288         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4289      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4290      &  +x(40)*yy*zz
4291         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4292         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4293      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4294      &  +x(60)*yy*zz
4295         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4296      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4297      &        +(pom1+pom2)*pom_dx
4298 #ifdef DEBUG
4299         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4300 #endif
4301 C
4302         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4303         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4304      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4305      &  +x(40)*xx*zz
4306         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4307         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4308      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4309      &  +x(59)*zz**2 +x(60)*xx*zz
4310         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4311      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4312      &        +(pom1-pom2)*pom_dy
4313 #ifdef DEBUG
4314         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4315 #endif
4316 C
4317         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4318      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4319      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4320      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4321      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4322      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4323      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4324      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4325 #ifdef DEBUG
4326         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4327 #endif
4328 C
4329         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4330      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4331      &  +pom1*pom_dt1+pom2*pom_dt2
4332 #ifdef DEBUG
4333         write(2,*), "de_dt = ", de_dt,de_dt_num
4334 #endif
4335 c
4336 C
4337        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4338        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4339        cosfac2xx=cosfac2*xx
4340        sinfac2yy=sinfac2*yy
4341        do k = 1,3
4342          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4343      &      vbld_inv(i+1)
4344          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4345      &      vbld_inv(i)
4346          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4347          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4348 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4349 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4350 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4351 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4352          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4353          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4354          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4355          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4356          dZZ_Ci1(k)=0.0d0
4357          dZZ_Ci(k)=0.0d0
4358          do j=1,3
4359            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4360            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4361          enddo
4362
4363          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4364          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4365          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4366 c
4367          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4368          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4369        enddo
4370
4371        do k=1,3
4372          dXX_Ctab(k,i)=dXX_Ci(k)
4373          dXX_C1tab(k,i)=dXX_Ci1(k)
4374          dYY_Ctab(k,i)=dYY_Ci(k)
4375          dYY_C1tab(k,i)=dYY_Ci1(k)
4376          dZZ_Ctab(k,i)=dZZ_Ci(k)
4377          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4378          dXX_XYZtab(k,i)=dXX_XYZ(k)
4379          dYY_XYZtab(k,i)=dYY_XYZ(k)
4380          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4381        enddo
4382
4383        do k = 1,3
4384 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4385 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4386 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4387 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4388 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4389 c     &    dt_dci(k)
4390 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4391 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4392          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4393      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4394          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4395      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4396          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4397      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4398        enddo
4399 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4400 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4401
4402 C to check gradient call subroutine check_grad
4403
4404     1 continue
4405       enddo
4406       return
4407       end
4408 #endif
4409 c------------------------------------------------------------------------------
4410       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4411 C
4412 C This procedure calculates two-body contact function g(rij) and its derivative:
4413 C
4414 C           eps0ij                                     !       x < -1
4415 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4416 C            0                                         !       x > 1
4417 C
4418 C where x=(rij-r0ij)/delta
4419 C
4420 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4421 C
4422       implicit none
4423       double precision rij,r0ij,eps0ij,fcont,fprimcont
4424       double precision x,x2,x4,delta
4425 c     delta=0.02D0*r0ij
4426 c      delta=0.2D0*r0ij
4427       x=(rij-r0ij)/delta
4428       if (x.lt.-1.0D0) then
4429         fcont=eps0ij
4430         fprimcont=0.0D0
4431       else if (x.le.1.0D0) then
4432         x2=x*x
4433         x4=x2*x2
4434         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4435         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4436       else
4437         fcont=0.0D0
4438         fprimcont=0.0D0
4439       endif
4440       return
4441       end
4442 c------------------------------------------------------------------------------
4443       subroutine splinthet(theti,delta,ss,ssder)
4444       implicit real*8 (a-h,o-z)
4445       include 'DIMENSIONS'
4446       include 'DIMENSIONS.ZSCOPT'
4447       include 'COMMON.VAR'
4448       include 'COMMON.GEO'
4449       thetup=pi-delta
4450       thetlow=delta
4451       if (theti.gt.pipol) then
4452         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4453       else
4454         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4455         ssder=-ssder
4456       endif
4457       return
4458       end
4459 c------------------------------------------------------------------------------
4460       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4461       implicit none
4462       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4463       double precision ksi,ksi2,ksi3,a1,a2,a3
4464       a1=fprim0*delta/(f1-f0)
4465       a2=3.0d0-2.0d0*a1
4466       a3=a1-2.0d0
4467       ksi=(x-x0)/delta
4468       ksi2=ksi*ksi
4469       ksi3=ksi2*ksi
4470       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4471       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4472       return
4473       end
4474 c------------------------------------------------------------------------------
4475       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4476       implicit none
4477       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4478       double precision ksi,ksi2,ksi3,a1,a2,a3
4479       ksi=(x-x0)/delta
4480       ksi2=ksi*ksi
4481       ksi3=ksi2*ksi
4482       a1=fprim0x*delta
4483       a2=3*(f1x-f0x)-2*fprim0x*delta
4484       a3=fprim0x*delta-2*(f1x-f0x)
4485       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4486       return
4487       end
4488 C-----------------------------------------------------------------------------
4489 #ifdef CRYST_TOR
4490 C-----------------------------------------------------------------------------
4491       subroutine etor(etors,edihcnstr,fact)
4492       implicit real*8 (a-h,o-z)
4493       include 'DIMENSIONS'
4494       include 'DIMENSIONS.ZSCOPT'
4495       include 'COMMON.VAR'
4496       include 'COMMON.GEO'
4497       include 'COMMON.LOCAL'
4498       include 'COMMON.TORSION'
4499       include 'COMMON.INTERACT'
4500       include 'COMMON.DERIV'
4501       include 'COMMON.CHAIN'
4502       include 'COMMON.NAMES'
4503       include 'COMMON.IOUNITS'
4504       include 'COMMON.FFIELD'
4505       include 'COMMON.TORCNSTR'
4506       logical lprn
4507 C Set lprn=.true. for debugging
4508       lprn=.false.
4509 c      lprn=.true.
4510       etors=0.0D0
4511       do i=iphi_start,iphi_end
4512         itori=itortyp(itype(i-2))
4513         itori1=itortyp(itype(i-1))
4514         phii=phi(i)
4515         gloci=0.0D0
4516 C Proline-Proline pair is a special case...
4517         if (itori.eq.3 .and. itori1.eq.3) then
4518           if (phii.gt.-dwapi3) then
4519             cosphi=dcos(3*phii)
4520             fac=1.0D0/(1.0D0-cosphi)
4521             etorsi=v1(1,3,3)*fac
4522             etorsi=etorsi+etorsi
4523             etors=etors+etorsi-v1(1,3,3)
4524             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4525           endif
4526           do j=1,3
4527             v1ij=v1(j+1,itori,itori1)
4528             v2ij=v2(j+1,itori,itori1)
4529             cosphi=dcos(j*phii)
4530             sinphi=dsin(j*phii)
4531             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4532             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4533           enddo
4534         else
4535           do j=1,nterm_old
4536             v1ij=v1(j,itori,itori1)
4537             v2ij=v2(j,itori,itori1)
4538             cosphi=dcos(j*phii)
4539             sinphi=dsin(j*phii)
4540             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4541             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4542           enddo
4543         endif
4544         if (lprn)
4545      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4546      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4547      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4548         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4549 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4550       enddo
4551 ! 6/20/98 - dihedral angle constraints
4552       edihcnstr=0.0d0
4553       do i=1,ndih_constr
4554         itori=idih_constr(i)
4555         phii=phi(itori)
4556         difi=phii-phi0(i)
4557         if (difi.gt.drange(i)) then
4558           difi=difi-drange(i)
4559           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4560           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4561         else if (difi.lt.-drange(i)) then
4562           difi=difi+drange(i)
4563           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4564           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4565         endif
4566 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4567 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4568       enddo
4569 !      write (iout,*) 'edihcnstr',edihcnstr
4570       return
4571       end
4572 c------------------------------------------------------------------------------
4573 #else
4574       subroutine etor(etors,edihcnstr,fact)
4575       implicit real*8 (a-h,o-z)
4576       include 'DIMENSIONS'
4577       include 'DIMENSIONS.ZSCOPT'
4578       include 'COMMON.VAR'
4579       include 'COMMON.GEO'
4580       include 'COMMON.LOCAL'
4581       include 'COMMON.TORSION'
4582       include 'COMMON.INTERACT'
4583       include 'COMMON.DERIV'
4584       include 'COMMON.CHAIN'
4585       include 'COMMON.NAMES'
4586       include 'COMMON.IOUNITS'
4587       include 'COMMON.FFIELD'
4588       include 'COMMON.TORCNSTR'
4589       logical lprn
4590 C Set lprn=.true. for debugging
4591       lprn=.false.
4592 c      lprn=.true.
4593       etors=0.0D0
4594       do i=iphi_start,iphi_end
4595         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4596         itori=itortyp(itype(i-2))
4597         itori1=itortyp(itype(i-1))
4598         phii=phi(i)
4599         gloci=0.0D0
4600 C Regular cosine and sine terms
4601         do j=1,nterm(itori,itori1)
4602           v1ij=v1(j,itori,itori1)
4603           v2ij=v2(j,itori,itori1)
4604           cosphi=dcos(j*phii)
4605           sinphi=dsin(j*phii)
4606           etors=etors+v1ij*cosphi+v2ij*sinphi
4607           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4608         enddo
4609 C Lorentz terms
4610 C                         v1
4611 C  E = SUM ----------------------------------- - v1
4612 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4613 C
4614         cosphi=dcos(0.5d0*phii)
4615         sinphi=dsin(0.5d0*phii)
4616         do j=1,nlor(itori,itori1)
4617           vl1ij=vlor1(j,itori,itori1)
4618           vl2ij=vlor2(j,itori,itori1)
4619           vl3ij=vlor3(j,itori,itori1)
4620           pom=vl2ij*cosphi+vl3ij*sinphi
4621           pom1=1.0d0/(pom*pom+1.0d0)
4622           etors=etors+vl1ij*pom1
4623           pom=-pom*pom1*pom1
4624           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4625         enddo
4626 C Subtract the constant term
4627         etors=etors-v0(itori,itori1)
4628         if (lprn)
4629      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4630      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4631      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4632         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4633 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4634  1215   continue
4635       enddo
4636 ! 6/20/98 - dihedral angle constraints
4637       edihcnstr=0.0d0
4638       do i=1,ndih_constr
4639         itori=idih_constr(i)
4640         phii=phi(itori)
4641         difi=pinorm(phii-phi0(i))
4642         edihi=0.0d0
4643         if (difi.gt.drange(i)) then
4644           difi=difi-drange(i)
4645           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4646           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4647           edihi=0.25d0*ftors*difi**4
4648         else if (difi.lt.-drange(i)) then
4649           difi=difi+drange(i)
4650           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4651           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4652           edihi=0.25d0*ftors*difi**4
4653         else
4654           difi=0.0d0
4655         endif
4656 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4657 c     &    drange(i),edihi
4658 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4659 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4660       enddo
4661 !      write (iout,*) 'edihcnstr',edihcnstr
4662       return
4663       end
4664 c----------------------------------------------------------------------------
4665       subroutine etor_d(etors_d,fact2)
4666 C 6/23/01 Compute double torsional energy
4667       implicit real*8 (a-h,o-z)
4668       include 'DIMENSIONS'
4669       include 'DIMENSIONS.ZSCOPT'
4670       include 'COMMON.VAR'
4671       include 'COMMON.GEO'
4672       include 'COMMON.LOCAL'
4673       include 'COMMON.TORSION'
4674       include 'COMMON.INTERACT'
4675       include 'COMMON.DERIV'
4676       include 'COMMON.CHAIN'
4677       include 'COMMON.NAMES'
4678       include 'COMMON.IOUNITS'
4679       include 'COMMON.FFIELD'
4680       include 'COMMON.TORCNSTR'
4681       logical lprn
4682 C Set lprn=.true. for debugging
4683       lprn=.false.
4684 c     lprn=.true.
4685       etors_d=0.0D0
4686       do i=iphi_start,iphi_end-1
4687         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4688      &     goto 1215
4689         itori=itortyp(itype(i-2))
4690         itori1=itortyp(itype(i-1))
4691         itori2=itortyp(itype(i))
4692         phii=phi(i)
4693         phii1=phi(i+1)
4694         gloci1=0.0D0
4695         gloci2=0.0D0
4696 C Regular cosine and sine terms
4697         do j=1,ntermd_1(itori,itori1,itori2)
4698           v1cij=v1c(1,j,itori,itori1,itori2)
4699           v1sij=v1s(1,j,itori,itori1,itori2)
4700           v2cij=v1c(2,j,itori,itori1,itori2)
4701           v2sij=v1s(2,j,itori,itori1,itori2)
4702           cosphi1=dcos(j*phii)
4703           sinphi1=dsin(j*phii)
4704           cosphi2=dcos(j*phii1)
4705           sinphi2=dsin(j*phii1)
4706           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4707      &     v2cij*cosphi2+v2sij*sinphi2
4708           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4709           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4710         enddo
4711         do k=2,ntermd_2(itori,itori1,itori2)
4712           do l=1,k-1
4713             v1cdij = v2c(k,l,itori,itori1,itori2)
4714             v2cdij = v2c(l,k,itori,itori1,itori2)
4715             v1sdij = v2s(k,l,itori,itori1,itori2)
4716             v2sdij = v2s(l,k,itori,itori1,itori2)
4717             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4718             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4719             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4720             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4721             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4722      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4723             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4724      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4725             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4726      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4727           enddo
4728         enddo
4729         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4730         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4731  1215   continue
4732       enddo
4733       return
4734       end
4735 #endif
4736 c------------------------------------------------------------------------------
4737       subroutine eback_sc_corr(esccor)
4738 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4739 c        conformational states; temporarily implemented as differences
4740 c        between UNRES torsional potentials (dependent on three types of
4741 c        residues) and the torsional potentials dependent on all 20 types
4742 c        of residues computed from AM1 energy surfaces of terminally-blocked
4743 c        amino-acid residues.
4744       implicit real*8 (a-h,o-z)
4745       include 'DIMENSIONS'
4746       include 'DIMENSIONS.ZSCOPT'
4747       include 'COMMON.VAR'
4748       include 'COMMON.GEO'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.TORSION'
4751       include 'COMMON.SCCOR'
4752       include 'COMMON.INTERACT'
4753       include 'COMMON.DERIV'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.NAMES'
4756       include 'COMMON.IOUNITS'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       logical lprn
4760 C Set lprn=.true. for debugging
4761       lprn=.false.
4762 c      lprn=.true.
4763 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
4764       esccor=0.0D0
4765       do i=itau_start,itau_end
4766         esccor_ii=0.0D0
4767         isccori=isccortyp(itype(i-2))
4768         isccori1=isccortyp(itype(i-1))
4769         phii=phi(i)
4770 cccc  Added 9 May 2012
4771 cc Tauangle is torsional engle depending on the value of first digit
4772 c(see comment below)
4773 cc Omicron is flat angle depending on the value of first digit
4774 c(see comment below)
4775
4776
4777         do intertyp=1,3 !intertyp
4778 cc Added 09 May 2012 (Adasko)
4779 cc  Intertyp means interaction type of backbone mainchain correlation:
4780 c   1 = SC...Ca...Ca...Ca
4781 c   2 = Ca...Ca...Ca...SC
4782 c   3 = SC...Ca...Ca...SCi
4783         gloci=0.0D0
4784         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4785      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
4786      &      (itype(i-1).eq.21)))
4787      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4788      &     .or.(itype(i-2).eq.21)))
4789      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4790      &      (itype(i-1).eq.21)))) cycle
4791         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
4792         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
4793      & cycle
4794         do j=1,nterm_sccor(isccori,isccori1)
4795           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4796           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4797           cosphi=dcos(j*tauangle(intertyp,i))
4798           sinphi=dsin(j*tauangle(intertyp,i))
4799           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4800           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4801         enddo
4802         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4803 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
4804 c     &gloc_sc(intertyp,i-3,icg)
4805         if (lprn)
4806      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4807      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4808      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
4809      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
4810         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4811        enddo !intertyp
4812       enddo
4813 c        do i=1,nres
4814 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
4815 c        enddo
4816       return
4817       end
4818 c------------------------------------------------------------------------------
4819       subroutine multibody(ecorr)
4820 C This subroutine calculates multi-body contributions to energy following
4821 C the idea of Skolnick et al. If side chains I and J make a contact and
4822 C at the same time side chains I+1 and J+1 make a contact, an extra
4823 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4824       implicit real*8 (a-h,o-z)
4825       include 'DIMENSIONS'
4826       include 'COMMON.IOUNITS'
4827       include 'COMMON.DERIV'
4828       include 'COMMON.INTERACT'
4829       include 'COMMON.CONTACTS'
4830       double precision gx(3),gx1(3)
4831       logical lprn
4832
4833 C Set lprn=.true. for debugging
4834       lprn=.false.
4835
4836       if (lprn) then
4837         write (iout,'(a)') 'Contact function values:'
4838         do i=nnt,nct-2
4839           write (iout,'(i2,20(1x,i2,f10.5))')
4840      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4841         enddo
4842       endif
4843       ecorr=0.0D0
4844       do i=nnt,nct
4845         do j=1,3
4846           gradcorr(j,i)=0.0D0
4847           gradxorr(j,i)=0.0D0
4848         enddo
4849       enddo
4850       do i=nnt,nct-2
4851
4852         DO ISHIFT = 3,4
4853
4854         i1=i+ishift
4855         num_conti=num_cont(i)
4856         num_conti1=num_cont(i1)
4857         do jj=1,num_conti
4858           j=jcont(jj,i)
4859           do kk=1,num_conti1
4860             j1=jcont(kk,i1)
4861             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4862 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4863 cd   &                   ' ishift=',ishift
4864 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4865 C The system gains extra energy.
4866               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4867             endif   ! j1==j+-ishift
4868           enddo     ! kk
4869         enddo       ! jj
4870
4871         ENDDO ! ISHIFT
4872
4873       enddo         ! i
4874       return
4875       end
4876 c------------------------------------------------------------------------------
4877       double precision function esccorr(i,j,k,l,jj,kk)
4878       implicit real*8 (a-h,o-z)
4879       include 'DIMENSIONS'
4880       include 'COMMON.IOUNITS'
4881       include 'COMMON.DERIV'
4882       include 'COMMON.INTERACT'
4883       include 'COMMON.CONTACTS'
4884       double precision gx(3),gx1(3)
4885       logical lprn
4886       lprn=.false.
4887       eij=facont(jj,i)
4888       ekl=facont(kk,k)
4889 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4890 C Calculate the multi-body contribution to energy.
4891 C Calculate multi-body contributions to the gradient.
4892 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4893 cd   & k,l,(gacont(m,kk,k),m=1,3)
4894       do m=1,3
4895         gx(m) =ekl*gacont(m,jj,i)
4896         gx1(m)=eij*gacont(m,kk,k)
4897         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4898         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4899         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4900         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4901       enddo
4902       do m=i,j-1
4903         do ll=1,3
4904           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4905         enddo
4906       enddo
4907       do m=k,l-1
4908         do ll=1,3
4909           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4910         enddo
4911       enddo
4912       esccorr=-eij*ekl
4913       return
4914       end
4915 c------------------------------------------------------------------------------
4916 #ifdef MPL
4917       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4918       implicit real*8 (a-h,o-z)
4919       include 'DIMENSIONS'
4920       integer dimen1,dimen2,atom,indx
4921       double precision buffer(dimen1,dimen2)
4922       double precision zapas
4923       common /contacts_hb/ zapas(3,20,maxres,7),
4924      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4925      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4926       num_kont=num_cont_hb(atom)
4927       do i=1,num_kont
4928         do k=1,7
4929           do j=1,3
4930             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4931           enddo ! j
4932         enddo ! k
4933         buffer(i,indx+22)=facont_hb(i,atom)
4934         buffer(i,indx+23)=ees0p(i,atom)
4935         buffer(i,indx+24)=ees0m(i,atom)
4936         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4937       enddo ! i
4938       buffer(1,indx+26)=dfloat(num_kont)
4939       return
4940       end
4941 c------------------------------------------------------------------------------
4942       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4943       implicit real*8 (a-h,o-z)
4944       include 'DIMENSIONS'
4945       integer dimen1,dimen2,atom,indx
4946       double precision buffer(dimen1,dimen2)
4947       double precision zapas
4948       common /contacts_hb/ zapas(3,20,maxres,7),
4949      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4950      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4951       num_kont=buffer(1,indx+26)
4952       num_kont_old=num_cont_hb(atom)
4953       num_cont_hb(atom)=num_kont+num_kont_old
4954       do i=1,num_kont
4955         ii=i+num_kont_old
4956         do k=1,7
4957           do j=1,3
4958             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4959           enddo ! j
4960         enddo ! k
4961         facont_hb(ii,atom)=buffer(i,indx+22)
4962         ees0p(ii,atom)=buffer(i,indx+23)
4963         ees0m(ii,atom)=buffer(i,indx+24)
4964         jcont_hb(ii,atom)=buffer(i,indx+25)
4965       enddo ! i
4966       return
4967       end
4968 c------------------------------------------------------------------------------
4969 #endif
4970       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4971 C This subroutine calculates multi-body contributions to hydrogen-bonding
4972       implicit real*8 (a-h,o-z)
4973       include 'DIMENSIONS'
4974       include 'DIMENSIONS.ZSCOPT'
4975       include 'COMMON.IOUNITS'
4976 #ifdef MPL
4977       include 'COMMON.INFO'
4978 #endif
4979       include 'COMMON.FFIELD'
4980       include 'COMMON.DERIV'
4981       include 'COMMON.INTERACT'
4982       include 'COMMON.CONTACTS'
4983 #ifdef MPL
4984       parameter (max_cont=maxconts)
4985       parameter (max_dim=2*(8*3+2))
4986       parameter (msglen1=max_cont*max_dim*4)
4987       parameter (msglen2=2*msglen1)
4988       integer source,CorrelType,CorrelID,Error
4989       double precision buffer(max_cont,max_dim)
4990 #endif
4991       double precision gx(3),gx1(3)
4992       logical lprn,ldone
4993
4994 C Set lprn=.true. for debugging
4995       lprn=.false.
4996 #ifdef MPL
4997       n_corr=0
4998       n_corr1=0
4999       if (fgProcs.le.1) goto 30
5000       if (lprn) then
5001         write (iout,'(a)') 'Contact function values:'
5002         do i=nnt,nct-2
5003           write (iout,'(2i3,50(1x,i2,f5.2))')
5004      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5005      &    j=1,num_cont_hb(i))
5006         enddo
5007       endif
5008 C Caution! Following code assumes that electrostatic interactions concerning
5009 C a given atom are split among at most two processors!
5010       CorrelType=477
5011       CorrelID=MyID+1
5012       ldone=.false.
5013       do i=1,max_cont
5014         do j=1,max_dim
5015           buffer(i,j)=0.0D0
5016         enddo
5017       enddo
5018       mm=mod(MyRank,2)
5019 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5020       if (mm) 20,20,10
5021    10 continue
5022 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5023       if (MyRank.gt.0) then
5024 C Send correlation contributions to the preceding processor
5025         msglen=msglen1
5026         nn=num_cont_hb(iatel_s)
5027         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5028 cd      write (iout,*) 'The BUFFER array:'
5029 cd      do i=1,nn
5030 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5031 cd      enddo
5032         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5033           msglen=msglen2
5034             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5035 C Clear the contacts of the atom passed to the neighboring processor
5036         nn=num_cont_hb(iatel_s+1)
5037 cd      do i=1,nn
5038 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5039 cd      enddo
5040             num_cont_hb(iatel_s)=0
5041         endif
5042 cd      write (iout,*) 'Processor ',MyID,MyRank,
5043 cd   & ' is sending correlation contribution to processor',MyID-1,
5044 cd   & ' msglen=',msglen
5045 cd      write (*,*) 'Processor ',MyID,MyRank,
5046 cd   & ' is sending correlation contribution to processor',MyID-1,
5047 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5048         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5049 cd      write (iout,*) 'Processor ',MyID,
5050 cd   & ' has sent correlation contribution to processor',MyID-1,
5051 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5052 cd      write (*,*) 'Processor ',MyID,
5053 cd   & ' has sent correlation contribution to processor',MyID-1,
5054 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5055         msglen=msglen1
5056       endif ! (MyRank.gt.0)
5057       if (ldone) goto 30
5058       ldone=.true.
5059    20 continue
5060 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5061       if (MyRank.lt.fgProcs-1) then
5062 C Receive correlation contributions from the next processor
5063         msglen=msglen1
5064         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5065 cd      write (iout,*) 'Processor',MyID,
5066 cd   & ' is receiving correlation contribution from processor',MyID+1,
5067 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5068 cd      write (*,*) 'Processor',MyID,
5069 cd   & ' is receiving correlation contribution from processor',MyID+1,
5070 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5071         nbytes=-1
5072         do while (nbytes.le.0)
5073           call mp_probe(MyID+1,CorrelType,nbytes)
5074         enddo
5075 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5076         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5077 cd      write (iout,*) 'Processor',MyID,
5078 cd   & ' has received correlation contribution from processor',MyID+1,
5079 cd   & ' msglen=',msglen,' nbytes=',nbytes
5080 cd      write (iout,*) 'The received BUFFER array:'
5081 cd      do i=1,max_cont
5082 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5083 cd      enddo
5084         if (msglen.eq.msglen1) then
5085           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5086         else if (msglen.eq.msglen2)  then
5087           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5088           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5089         else
5090           write (iout,*)
5091      & 'ERROR!!!! message length changed while processing correlations.'
5092           write (*,*)
5093      & 'ERROR!!!! message length changed while processing correlations.'
5094           call mp_stopall(Error)
5095         endif ! msglen.eq.msglen1
5096       endif ! MyRank.lt.fgProcs-1
5097       if (ldone) goto 30
5098       ldone=.true.
5099       goto 10
5100    30 continue
5101 #endif
5102       if (lprn) then
5103         write (iout,'(a)') 'Contact function values:'
5104         do i=nnt,nct-2
5105           write (iout,'(2i3,50(1x,i2,f5.2))')
5106      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5107      &    j=1,num_cont_hb(i))
5108         enddo
5109       endif
5110       ecorr=0.0D0
5111 C Remove the loop below after debugging !!!
5112       do i=nnt,nct
5113         do j=1,3
5114           gradcorr(j,i)=0.0D0
5115           gradxorr(j,i)=0.0D0
5116         enddo
5117       enddo
5118 C Calculate the local-electrostatic correlation terms
5119       do i=iatel_s,iatel_e+1
5120         i1=i+1
5121         num_conti=num_cont_hb(i)
5122         num_conti1=num_cont_hb(i+1)
5123         do jj=1,num_conti
5124           j=jcont_hb(jj,i)
5125           do kk=1,num_conti1
5126             j1=jcont_hb(kk,i1)
5127 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5128 c     &         ' jj=',jj,' kk=',kk
5129             if (j1.eq.j+1 .or. j1.eq.j-1) then
5130 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5131 C The system gains extra energy.
5132               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5133               n_corr=n_corr+1
5134             else if (j1.eq.j) then
5135 C Contacts I-J and I-(J+1) occur simultaneously.
5136 C The system loses extra energy.
5137 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5138             endif
5139           enddo ! kk
5140           do kk=1,num_conti
5141             j1=jcont_hb(kk,i)
5142 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5143 c    &         ' jj=',jj,' kk=',kk
5144             if (j1.eq.j+1) then
5145 C Contacts I-J and (I+1)-J occur simultaneously.
5146 C The system loses extra energy.
5147 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5148             endif ! j1==j+1
5149           enddo ! kk
5150         enddo ! jj
5151       enddo ! i
5152       return
5153       end
5154 c------------------------------------------------------------------------------
5155       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5156      &  n_corr1)
5157 C This subroutine calculates multi-body contributions to hydrogen-bonding
5158       implicit real*8 (a-h,o-z)
5159       include 'DIMENSIONS'
5160       include 'DIMENSIONS.ZSCOPT'
5161       include 'COMMON.IOUNITS'
5162 #ifdef MPL
5163       include 'COMMON.INFO'
5164 #endif
5165       include 'COMMON.FFIELD'
5166       include 'COMMON.DERIV'
5167       include 'COMMON.INTERACT'
5168       include 'COMMON.CONTACTS'
5169 #ifdef MPL
5170       parameter (max_cont=maxconts)
5171       parameter (max_dim=2*(8*3+2))
5172       parameter (msglen1=max_cont*max_dim*4)
5173       parameter (msglen2=2*msglen1)
5174       integer source,CorrelType,CorrelID,Error
5175       double precision buffer(max_cont,max_dim)
5176 #endif
5177       double precision gx(3),gx1(3)
5178       logical lprn,ldone
5179
5180 C Set lprn=.true. for debugging
5181       lprn=.false.
5182       eturn6=0.0d0
5183 #ifdef MPL
5184       n_corr=0
5185       n_corr1=0
5186       if (fgProcs.le.1) goto 30
5187       if (lprn) then
5188         write (iout,'(a)') 'Contact function values:'
5189         do i=nnt,nct-2
5190           write (iout,'(2i3,50(1x,i2,f5.2))')
5191      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5192      &    j=1,num_cont_hb(i))
5193         enddo
5194       endif
5195 C Caution! Following code assumes that electrostatic interactions concerning
5196 C a given atom are split among at most two processors!
5197       CorrelType=477
5198       CorrelID=MyID+1
5199       ldone=.false.
5200       do i=1,max_cont
5201         do j=1,max_dim
5202           buffer(i,j)=0.0D0
5203         enddo
5204       enddo
5205       mm=mod(MyRank,2)
5206 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5207       if (mm) 20,20,10
5208    10 continue
5209 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5210       if (MyRank.gt.0) then
5211 C Send correlation contributions to the preceding processor
5212         msglen=msglen1
5213         nn=num_cont_hb(iatel_s)
5214         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5215 cd      write (iout,*) 'The BUFFER array:'
5216 cd      do i=1,nn
5217 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5218 cd      enddo
5219         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5220           msglen=msglen2
5221             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5222 C Clear the contacts of the atom passed to the neighboring processor
5223         nn=num_cont_hb(iatel_s+1)
5224 cd      do i=1,nn
5225 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5226 cd      enddo
5227             num_cont_hb(iatel_s)=0
5228         endif
5229 cd      write (iout,*) 'Processor ',MyID,MyRank,
5230 cd   & ' is sending correlation contribution to processor',MyID-1,
5231 cd   & ' msglen=',msglen
5232 cd      write (*,*) 'Processor ',MyID,MyRank,
5233 cd   & ' is sending correlation contribution to processor',MyID-1,
5234 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5235         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5236 cd      write (iout,*) 'Processor ',MyID,
5237 cd   & ' has sent correlation contribution to processor',MyID-1,
5238 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5239 cd      write (*,*) 'Processor ',MyID,
5240 cd   & ' has sent correlation contribution to processor',MyID-1,
5241 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5242         msglen=msglen1
5243       endif ! (MyRank.gt.0)
5244       if (ldone) goto 30
5245       ldone=.true.
5246    20 continue
5247 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5248       if (MyRank.lt.fgProcs-1) then
5249 C Receive correlation contributions from the next processor
5250         msglen=msglen1
5251         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5252 cd      write (iout,*) 'Processor',MyID,
5253 cd   & ' is receiving correlation contribution from processor',MyID+1,
5254 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5255 cd      write (*,*) 'Processor',MyID,
5256 cd   & ' is receiving correlation contribution from processor',MyID+1,
5257 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5258         nbytes=-1
5259         do while (nbytes.le.0)
5260           call mp_probe(MyID+1,CorrelType,nbytes)
5261         enddo
5262 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5263         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5264 cd      write (iout,*) 'Processor',MyID,
5265 cd   & ' has received correlation contribution from processor',MyID+1,
5266 cd   & ' msglen=',msglen,' nbytes=',nbytes
5267 cd      write (iout,*) 'The received BUFFER array:'
5268 cd      do i=1,max_cont
5269 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5270 cd      enddo
5271         if (msglen.eq.msglen1) then
5272           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5273         else if (msglen.eq.msglen2)  then
5274           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5275           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5276         else
5277           write (iout,*)
5278      & 'ERROR!!!! message length changed while processing correlations.'
5279           write (*,*)
5280      & 'ERROR!!!! message length changed while processing correlations.'
5281           call mp_stopall(Error)
5282         endif ! msglen.eq.msglen1
5283       endif ! MyRank.lt.fgProcs-1
5284       if (ldone) goto 30
5285       ldone=.true.
5286       goto 10
5287    30 continue
5288 #endif
5289       if (lprn) then
5290         write (iout,'(a)') 'Contact function values:'
5291         do i=nnt,nct-2
5292           write (iout,'(2i3,50(1x,i2,f5.2))')
5293      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5294      &    j=1,num_cont_hb(i))
5295         enddo
5296       endif
5297       ecorr=0.0D0
5298       ecorr5=0.0d0
5299       ecorr6=0.0d0
5300 C Remove the loop below after debugging !!!
5301       do i=nnt,nct
5302         do j=1,3
5303           gradcorr(j,i)=0.0D0
5304           gradxorr(j,i)=0.0D0
5305         enddo
5306       enddo
5307 C Calculate the dipole-dipole interaction energies
5308       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5309       do i=iatel_s,iatel_e+1
5310         num_conti=num_cont_hb(i)
5311         do jj=1,num_conti
5312           j=jcont_hb(jj,i)
5313           call dipole(i,j,jj)
5314         enddo
5315       enddo
5316       endif
5317 C Calculate the local-electrostatic correlation terms
5318       do i=iatel_s,iatel_e+1
5319         i1=i+1
5320         num_conti=num_cont_hb(i)
5321         num_conti1=num_cont_hb(i+1)
5322         do jj=1,num_conti
5323           j=jcont_hb(jj,i)
5324           do kk=1,num_conti1
5325             j1=jcont_hb(kk,i1)
5326 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5327 c     &         ' jj=',jj,' kk=',kk
5328             if (j1.eq.j+1 .or. j1.eq.j-1) then
5329 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5330 C The system gains extra energy.
5331               n_corr=n_corr+1
5332               sqd1=dsqrt(d_cont(jj,i))
5333               sqd2=dsqrt(d_cont(kk,i1))
5334               sred_geom = sqd1*sqd2
5335               IF (sred_geom.lt.cutoff_corr) THEN
5336                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5337      &            ekont,fprimcont)
5338 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5339 c     &         ' jj=',jj,' kk=',kk
5340                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5341                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5342                 do l=1,3
5343                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5344                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5345                 enddo
5346                 n_corr1=n_corr1+1
5347 cd               write (iout,*) 'sred_geom=',sred_geom,
5348 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5349                 call calc_eello(i,j,i+1,j1,jj,kk)
5350                 if (wcorr4.gt.0.0d0)
5351      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5352                 if (wcorr5.gt.0.0d0)
5353      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5354 c                print *,"wcorr5",ecorr5
5355 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5356 cd                write(2,*)'ijkl',i,j,i+1,j1
5357                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5358      &               .or. wturn6.eq.0.0d0))then
5359 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5360                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5361 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5362 cd     &            'ecorr6=',ecorr6
5363 cd                write (iout,'(4e15.5)') sred_geom,
5364 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5365 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5366 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5367                 else if (wturn6.gt.0.0d0
5368      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5369 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5370                   eturn6=eturn6+eello_turn6(i,jj,kk)
5371 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5372                 endif
5373               ENDIF
5374 1111          continue
5375             else if (j1.eq.j) then
5376 C Contacts I-J and I-(J+1) occur simultaneously.
5377 C The system loses extra energy.
5378 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5379             endif
5380           enddo ! kk
5381           do kk=1,num_conti
5382             j1=jcont_hb(kk,i)
5383 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5384 c    &         ' jj=',jj,' kk=',kk
5385             if (j1.eq.j+1) then
5386 C Contacts I-J and (I+1)-J occur simultaneously.
5387 C The system loses extra energy.
5388 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5389             endif ! j1==j+1
5390           enddo ! kk
5391         enddo ! jj
5392       enddo ! i
5393       return
5394       end
5395 c------------------------------------------------------------------------------
5396       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5397       implicit real*8 (a-h,o-z)
5398       include 'DIMENSIONS'
5399       include 'COMMON.IOUNITS'
5400       include 'COMMON.DERIV'
5401       include 'COMMON.INTERACT'
5402       include 'COMMON.CONTACTS'
5403       double precision gx(3),gx1(3)
5404       logical lprn
5405       lprn=.false.
5406       eij=facont_hb(jj,i)
5407       ekl=facont_hb(kk,k)
5408       ees0pij=ees0p(jj,i)
5409       ees0pkl=ees0p(kk,k)
5410       ees0mij=ees0m(jj,i)
5411       ees0mkl=ees0m(kk,k)
5412       ekont=eij*ekl
5413       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5414 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5415 C Following 4 lines for diagnostics.
5416 cd    ees0pkl=0.0D0
5417 cd    ees0pij=1.0D0
5418 cd    ees0mkl=0.0D0
5419 cd    ees0mij=1.0D0
5420 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5421 c    &   ' and',k,l
5422 c     write (iout,*)'Contacts have occurred for peptide groups',
5423 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5424 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5425 C Calculate the multi-body contribution to energy.
5426       ecorr=ecorr+ekont*ees
5427       if (calc_grad) then
5428 C Calculate multi-body contributions to the gradient.
5429       do ll=1,3
5430         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5431         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5432      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5433      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5434         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5435      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5436      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5437         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5438         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5439      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5440      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5441         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5442      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5443      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5444       enddo
5445       do m=i+1,j-1
5446         do ll=1,3
5447           gradcorr(ll,m)=gradcorr(ll,m)+
5448      &     ees*ekl*gacont_hbr(ll,jj,i)-
5449      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5450      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5451         enddo
5452       enddo
5453       do m=k+1,l-1
5454         do ll=1,3
5455           gradcorr(ll,m)=gradcorr(ll,m)+
5456      &     ees*eij*gacont_hbr(ll,kk,k)-
5457      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5458      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5459         enddo
5460       enddo
5461       endif
5462       ehbcorr=ekont*ees
5463       return
5464       end
5465 C---------------------------------------------------------------------------
5466       subroutine dipole(i,j,jj)
5467       implicit real*8 (a-h,o-z)
5468       include 'DIMENSIONS'
5469       include 'DIMENSIONS.ZSCOPT'
5470       include 'COMMON.IOUNITS'
5471       include 'COMMON.CHAIN'
5472       include 'COMMON.FFIELD'
5473       include 'COMMON.DERIV'
5474       include 'COMMON.INTERACT'
5475       include 'COMMON.CONTACTS'
5476       include 'COMMON.TORSION'
5477       include 'COMMON.VAR'
5478       include 'COMMON.GEO'
5479       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5480      &  auxmat(2,2)
5481       iti1 = itortyp(itype(i+1))
5482       if (j.lt.nres-1) then
5483         itj1 = itortyp(itype(j+1))
5484       else
5485         itj1=ntortyp+1
5486       endif
5487       do iii=1,2
5488         dipi(iii,1)=Ub2(iii,i)
5489         dipderi(iii)=Ub2der(iii,i)
5490         dipi(iii,2)=b1(iii,iti1)
5491         dipj(iii,1)=Ub2(iii,j)
5492         dipderj(iii)=Ub2der(iii,j)
5493         dipj(iii,2)=b1(iii,itj1)
5494       enddo
5495       kkk=0
5496       do iii=1,2
5497         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5498         do jjj=1,2
5499           kkk=kkk+1
5500           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5501         enddo
5502       enddo
5503       if (.not.calc_grad) return
5504       do kkk=1,5
5505         do lll=1,3
5506           mmm=0
5507           do iii=1,2
5508             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5509      &        auxvec(1))
5510             do jjj=1,2
5511               mmm=mmm+1
5512               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5513             enddo
5514           enddo
5515         enddo
5516       enddo
5517       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5518       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5519       do iii=1,2
5520         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5521       enddo
5522       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5523       do iii=1,2
5524         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5525       enddo
5526       return
5527       end
5528 C---------------------------------------------------------------------------
5529       subroutine calc_eello(i,j,k,l,jj,kk)
5530 C
5531 C This subroutine computes matrices and vectors needed to calculate
5532 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5533 C
5534       implicit real*8 (a-h,o-z)
5535       include 'DIMENSIONS'
5536       include 'DIMENSIONS.ZSCOPT'
5537       include 'COMMON.IOUNITS'
5538       include 'COMMON.CHAIN'
5539       include 'COMMON.DERIV'
5540       include 'COMMON.INTERACT'
5541       include 'COMMON.CONTACTS'
5542       include 'COMMON.TORSION'
5543       include 'COMMON.VAR'
5544       include 'COMMON.GEO'
5545       include 'COMMON.FFIELD'
5546       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5547      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5548       logical lprn
5549       common /kutas/ lprn
5550 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5551 cd     & ' jj=',jj,' kk=',kk
5552 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5553       do iii=1,2
5554         do jjj=1,2
5555           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5556           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5557         enddo
5558       enddo
5559       call transpose2(aa1(1,1),aa1t(1,1))
5560       call transpose2(aa2(1,1),aa2t(1,1))
5561       do kkk=1,5
5562         do lll=1,3
5563           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5564      &      aa1tder(1,1,lll,kkk))
5565           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5566      &      aa2tder(1,1,lll,kkk))
5567         enddo
5568       enddo
5569       if (l.eq.j+1) then
5570 C parallel orientation of the two CA-CA-CA frames.
5571         if (i.gt.1) then
5572           iti=itortyp(itype(i))
5573         else
5574           iti=ntortyp+1
5575         endif
5576         itk1=itortyp(itype(k+1))
5577         itj=itortyp(itype(j))
5578         if (l.lt.nres-1) then
5579           itl1=itortyp(itype(l+1))
5580         else
5581           itl1=ntortyp+1
5582         endif
5583 C A1 kernel(j+1) A2T
5584 cd        do iii=1,2
5585 cd          write (iout,'(3f10.5,5x,3f10.5)')
5586 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5587 cd        enddo
5588         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5589      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5590      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5591 C Following matrices are needed only for 6-th order cumulants
5592         IF (wcorr6.gt.0.0d0) THEN
5593         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5594      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5595      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5596         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5597      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5598      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5599      &   ADtEAderx(1,1,1,1,1,1))
5600         lprn=.false.
5601         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5602      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5603      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5604      &   ADtEA1derx(1,1,1,1,1,1))
5605         ENDIF
5606 C End 6-th order cumulants
5607 cd        lprn=.false.
5608 cd        if (lprn) then
5609 cd        write (2,*) 'In calc_eello6'
5610 cd        do iii=1,2
5611 cd          write (2,*) 'iii=',iii
5612 cd          do kkk=1,5
5613 cd            write (2,*) 'kkk=',kkk
5614 cd            do jjj=1,2
5615 cd              write (2,'(3(2f10.5),5x)')
5616 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5617 cd            enddo
5618 cd          enddo
5619 cd        enddo
5620 cd        endif
5621         call transpose2(EUgder(1,1,k),auxmat(1,1))
5622         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5623         call transpose2(EUg(1,1,k),auxmat(1,1))
5624         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5625         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5626         do iii=1,2
5627           do kkk=1,5
5628             do lll=1,3
5629               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5630      &          EAEAderx(1,1,lll,kkk,iii,1))
5631             enddo
5632           enddo
5633         enddo
5634 C A1T kernel(i+1) A2
5635         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5636      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5637      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5638 C Following matrices are needed only for 6-th order cumulants
5639         IF (wcorr6.gt.0.0d0) THEN
5640         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5641      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5642      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5643         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5644      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5645      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5646      &   ADtEAderx(1,1,1,1,1,2))
5647         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5648      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5649      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5650      &   ADtEA1derx(1,1,1,1,1,2))
5651         ENDIF
5652 C End 6-th order cumulants
5653         call transpose2(EUgder(1,1,l),auxmat(1,1))
5654         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5655         call transpose2(EUg(1,1,l),auxmat(1,1))
5656         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5657         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5658         do iii=1,2
5659           do kkk=1,5
5660             do lll=1,3
5661               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5662      &          EAEAderx(1,1,lll,kkk,iii,2))
5663             enddo
5664           enddo
5665         enddo
5666 C AEAb1 and AEAb2
5667 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5668 C They are needed only when the fifth- or the sixth-order cumulants are
5669 C indluded.
5670         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5671         call transpose2(AEA(1,1,1),auxmat(1,1))
5672         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5673         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5674         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5675         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5676         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5677         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5678         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5679         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5680         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5681         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5682         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5683         call transpose2(AEA(1,1,2),auxmat(1,1))
5684         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5685         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5686         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5687         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5688         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5689         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5690         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5691         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5692         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5693         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5694         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5695 C Calculate the Cartesian derivatives of the vectors.
5696         do iii=1,2
5697           do kkk=1,5
5698             do lll=1,3
5699               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5700               call matvec2(auxmat(1,1),b1(1,iti),
5701      &          AEAb1derx(1,lll,kkk,iii,1,1))
5702               call matvec2(auxmat(1,1),Ub2(1,i),
5703      &          AEAb2derx(1,lll,kkk,iii,1,1))
5704               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5705      &          AEAb1derx(1,lll,kkk,iii,2,1))
5706               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5707      &          AEAb2derx(1,lll,kkk,iii,2,1))
5708               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5709               call matvec2(auxmat(1,1),b1(1,itj),
5710      &          AEAb1derx(1,lll,kkk,iii,1,2))
5711               call matvec2(auxmat(1,1),Ub2(1,j),
5712      &          AEAb2derx(1,lll,kkk,iii,1,2))
5713               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5714      &          AEAb1derx(1,lll,kkk,iii,2,2))
5715               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5716      &          AEAb2derx(1,lll,kkk,iii,2,2))
5717             enddo
5718           enddo
5719         enddo
5720         ENDIF
5721 C End vectors
5722       else
5723 C Antiparallel orientation of the two CA-CA-CA frames.
5724         if (i.gt.1) then
5725           iti=itortyp(itype(i))
5726         else
5727           iti=ntortyp+1
5728         endif
5729         itk1=itortyp(itype(k+1))
5730         itl=itortyp(itype(l))
5731         itj=itortyp(itype(j))
5732         if (j.lt.nres-1) then
5733           itj1=itortyp(itype(j+1))
5734         else
5735           itj1=ntortyp+1
5736         endif
5737 C A2 kernel(j-1)T A1T
5738         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5739      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5740      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5741 C Following matrices are needed only for 6-th order cumulants
5742         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5743      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5744         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5745      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5746      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5747         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5748      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5749      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5750      &   ADtEAderx(1,1,1,1,1,1))
5751         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5752      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5753      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5754      &   ADtEA1derx(1,1,1,1,1,1))
5755         ENDIF
5756 C End 6-th order cumulants
5757         call transpose2(EUgder(1,1,k),auxmat(1,1))
5758         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5759         call transpose2(EUg(1,1,k),auxmat(1,1))
5760         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5761         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5762         do iii=1,2
5763           do kkk=1,5
5764             do lll=1,3
5765               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5766      &          EAEAderx(1,1,lll,kkk,iii,1))
5767             enddo
5768           enddo
5769         enddo
5770 C A2T kernel(i+1)T A1
5771         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5772      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5773      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5774 C Following matrices are needed only for 6-th order cumulants
5775         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5776      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5777         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5778      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5779      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5780         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5781      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5782      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5783      &   ADtEAderx(1,1,1,1,1,2))
5784         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5785      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5786      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5787      &   ADtEA1derx(1,1,1,1,1,2))
5788         ENDIF
5789 C End 6-th order cumulants
5790         call transpose2(EUgder(1,1,j),auxmat(1,1))
5791         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5792         call transpose2(EUg(1,1,j),auxmat(1,1))
5793         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5794         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5795         do iii=1,2
5796           do kkk=1,5
5797             do lll=1,3
5798               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5799      &          EAEAderx(1,1,lll,kkk,iii,2))
5800             enddo
5801           enddo
5802         enddo
5803 C AEAb1 and AEAb2
5804 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5805 C They are needed only when the fifth- or the sixth-order cumulants are
5806 C indluded.
5807         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5808      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5809         call transpose2(AEA(1,1,1),auxmat(1,1))
5810         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5811         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5812         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5813         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5814         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5815         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5816         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5817         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5818         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5819         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5820         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5821         call transpose2(AEA(1,1,2),auxmat(1,1))
5822         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5823         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5824         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5825         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5826         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5827         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5828         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5829         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5830         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5831         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5832         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5833 C Calculate the Cartesian derivatives of the vectors.
5834         do iii=1,2
5835           do kkk=1,5
5836             do lll=1,3
5837               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5838               call matvec2(auxmat(1,1),b1(1,iti),
5839      &          AEAb1derx(1,lll,kkk,iii,1,1))
5840               call matvec2(auxmat(1,1),Ub2(1,i),
5841      &          AEAb2derx(1,lll,kkk,iii,1,1))
5842               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5843      &          AEAb1derx(1,lll,kkk,iii,2,1))
5844               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5845      &          AEAb2derx(1,lll,kkk,iii,2,1))
5846               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5847               call matvec2(auxmat(1,1),b1(1,itl),
5848      &          AEAb1derx(1,lll,kkk,iii,1,2))
5849               call matvec2(auxmat(1,1),Ub2(1,l),
5850      &          AEAb2derx(1,lll,kkk,iii,1,2))
5851               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5852      &          AEAb1derx(1,lll,kkk,iii,2,2))
5853               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5854      &          AEAb2derx(1,lll,kkk,iii,2,2))
5855             enddo
5856           enddo
5857         enddo
5858         ENDIF
5859 C End vectors
5860       endif
5861       return
5862       end
5863 C---------------------------------------------------------------------------
5864       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5865      &  KK,KKderg,AKA,AKAderg,AKAderx)
5866       implicit none
5867       integer nderg
5868       logical transp
5869       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5870      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5871      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5872       integer iii,kkk,lll
5873       integer jjj,mmm
5874       logical lprn
5875       common /kutas/ lprn
5876       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5877       do iii=1,nderg
5878         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5879      &    AKAderg(1,1,iii))
5880       enddo
5881 cd      if (lprn) write (2,*) 'In kernel'
5882       do kkk=1,5
5883 cd        if (lprn) write (2,*) 'kkk=',kkk
5884         do lll=1,3
5885           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5886      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5887 cd          if (lprn) then
5888 cd            write (2,*) 'lll=',lll
5889 cd            write (2,*) 'iii=1'
5890 cd            do jjj=1,2
5891 cd              write (2,'(3(2f10.5),5x)')
5892 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5893 cd            enddo
5894 cd          endif
5895           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5896      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5897 cd          if (lprn) then
5898 cd            write (2,*) 'lll=',lll
5899 cd            write (2,*) 'iii=2'
5900 cd            do jjj=1,2
5901 cd              write (2,'(3(2f10.5),5x)')
5902 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5903 cd            enddo
5904 cd          endif
5905         enddo
5906       enddo
5907       return
5908       end
5909 C---------------------------------------------------------------------------
5910       double precision function eello4(i,j,k,l,jj,kk)
5911       implicit real*8 (a-h,o-z)
5912       include 'DIMENSIONS'
5913       include 'DIMENSIONS.ZSCOPT'
5914       include 'COMMON.IOUNITS'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.DERIV'
5917       include 'COMMON.INTERACT'
5918       include 'COMMON.CONTACTS'
5919       include 'COMMON.TORSION'
5920       include 'COMMON.VAR'
5921       include 'COMMON.GEO'
5922       double precision pizda(2,2),ggg1(3),ggg2(3)
5923 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5924 cd        eello4=0.0d0
5925 cd        return
5926 cd      endif
5927 cd      print *,'eello4:',i,j,k,l,jj,kk
5928 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5929 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5930 cold      eij=facont_hb(jj,i)
5931 cold      ekl=facont_hb(kk,k)
5932 cold      ekont=eij*ekl
5933       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5934       if (calc_grad) then
5935 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5936       gcorr_loc(k-1)=gcorr_loc(k-1)
5937      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5938       if (l.eq.j+1) then
5939         gcorr_loc(l-1)=gcorr_loc(l-1)
5940      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5941       else
5942         gcorr_loc(j-1)=gcorr_loc(j-1)
5943      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5944       endif
5945       do iii=1,2
5946         do kkk=1,5
5947           do lll=1,3
5948             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5949      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5950 cd            derx(lll,kkk,iii)=0.0d0
5951           enddo
5952         enddo
5953       enddo
5954 cd      gcorr_loc(l-1)=0.0d0
5955 cd      gcorr_loc(j-1)=0.0d0
5956 cd      gcorr_loc(k-1)=0.0d0
5957 cd      eel4=1.0d0
5958 cd      write (iout,*)'Contacts have occurred for peptide groups',
5959 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5960 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5961       if (j.lt.nres-1) then
5962         j1=j+1
5963         j2=j-1
5964       else
5965         j1=j-1
5966         j2=j-2
5967       endif
5968       if (l.lt.nres-1) then
5969         l1=l+1
5970         l2=l-1
5971       else
5972         l1=l-1
5973         l2=l-2
5974       endif
5975       do ll=1,3
5976 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5977         ggg1(ll)=eel4*g_contij(ll,1)
5978         ggg2(ll)=eel4*g_contij(ll,2)
5979         ghalf=0.5d0*ggg1(ll)
5980 cd        ghalf=0.0d0
5981         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5982         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5983         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5984         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5985 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5986         ghalf=0.5d0*ggg2(ll)
5987 cd        ghalf=0.0d0
5988         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5989         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5990         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5991         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5992       enddo
5993 cd      goto 1112
5994       do m=i+1,j-1
5995         do ll=1,3
5996 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5997           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5998         enddo
5999       enddo
6000       do m=k+1,l-1
6001         do ll=1,3
6002 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6003           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6004         enddo
6005       enddo
6006 1112  continue
6007       do m=i+2,j2
6008         do ll=1,3
6009           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6010         enddo
6011       enddo
6012       do m=k+2,l2
6013         do ll=1,3
6014           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6015         enddo
6016       enddo
6017 cd      do iii=1,nres-3
6018 cd        write (2,*) iii,gcorr_loc(iii)
6019 cd      enddo
6020       endif
6021       eello4=ekont*eel4
6022 cd      write (2,*) 'ekont',ekont
6023 cd      write (iout,*) 'eello4',ekont*eel4
6024       return
6025       end
6026 C---------------------------------------------------------------------------
6027       double precision function eello5(i,j,k,l,jj,kk)
6028       implicit real*8 (a-h,o-z)
6029       include 'DIMENSIONS'
6030       include 'DIMENSIONS.ZSCOPT'
6031       include 'COMMON.IOUNITS'
6032       include 'COMMON.CHAIN'
6033       include 'COMMON.DERIV'
6034       include 'COMMON.INTERACT'
6035       include 'COMMON.CONTACTS'
6036       include 'COMMON.TORSION'
6037       include 'COMMON.VAR'
6038       include 'COMMON.GEO'
6039       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6040       double precision ggg1(3),ggg2(3)
6041 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6042 C                                                                              C
6043 C                            Parallel chains                                   C
6044 C                                                                              C
6045 C          o             o                   o             o                   C
6046 C         /l\           / \             \   / \           / \   /              C
6047 C        /   \         /   \             \ /   \         /   \ /               C
6048 C       j| o |l1       | o |              o| o |         | o |o                C
6049 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6050 C      \i/   \         /   \ /             /   \         /   \                 C
6051 C       o    k1             o                                                  C
6052 C         (I)          (II)                (III)          (IV)                 C
6053 C                                                                              C
6054 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6055 C                                                                              C
6056 C                            Antiparallel chains                               C
6057 C                                                                              C
6058 C          o             o                   o             o                   C
6059 C         /j\           / \             \   / \           / \   /              C
6060 C        /   \         /   \             \ /   \         /   \ /               C
6061 C      j1| o |l        | o |              o| o |         | o |o                C
6062 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6063 C      \i/   \         /   \ /             /   \         /   \                 C
6064 C       o     k1            o                                                  C
6065 C         (I)          (II)                (III)          (IV)                 C
6066 C                                                                              C
6067 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6068 C                                                                              C
6069 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6070 C                                                                              C
6071 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6072 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6073 cd        eello5=0.0d0
6074 cd        return
6075 cd      endif
6076 cd      write (iout,*)
6077 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6078 cd     &   ' and',k,l
6079       itk=itortyp(itype(k))
6080       itl=itortyp(itype(l))
6081       itj=itortyp(itype(j))
6082       eello5_1=0.0d0
6083       eello5_2=0.0d0
6084       eello5_3=0.0d0
6085       eello5_4=0.0d0
6086 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6087 cd     &   eel5_3_num,eel5_4_num)
6088       do iii=1,2
6089         do kkk=1,5
6090           do lll=1,3
6091             derx(lll,kkk,iii)=0.0d0
6092           enddo
6093         enddo
6094       enddo
6095 cd      eij=facont_hb(jj,i)
6096 cd      ekl=facont_hb(kk,k)
6097 cd      ekont=eij*ekl
6098 cd      write (iout,*)'Contacts have occurred for peptide groups',
6099 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6100 cd      goto 1111
6101 C Contribution from the graph I.
6102 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6103 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6104       call transpose2(EUg(1,1,k),auxmat(1,1))
6105       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6106       vv(1)=pizda(1,1)-pizda(2,2)
6107       vv(2)=pizda(1,2)+pizda(2,1)
6108       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6109      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6110       if (calc_grad) then
6111 C Explicit gradient in virtual-dihedral angles.
6112       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6113      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6114      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6115       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6116       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6117       vv(1)=pizda(1,1)-pizda(2,2)
6118       vv(2)=pizda(1,2)+pizda(2,1)
6119       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6120      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6121      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6122       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6123       vv(1)=pizda(1,1)-pizda(2,2)
6124       vv(2)=pizda(1,2)+pizda(2,1)
6125       if (l.eq.j+1) then
6126         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6127      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6128      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6129       else
6130         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6131      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6132      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6133       endif
6134 C Cartesian gradient
6135       do iii=1,2
6136         do kkk=1,5
6137           do lll=1,3
6138             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6139      &        pizda(1,1))
6140             vv(1)=pizda(1,1)-pizda(2,2)
6141             vv(2)=pizda(1,2)+pizda(2,1)
6142             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6143      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6144      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6145           enddo
6146         enddo
6147       enddo
6148 c      goto 1112
6149       endif
6150 c1111  continue
6151 C Contribution from graph II
6152       call transpose2(EE(1,1,itk),auxmat(1,1))
6153       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6154       vv(1)=pizda(1,1)+pizda(2,2)
6155       vv(2)=pizda(2,1)-pizda(1,2)
6156       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6157      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6158       if (calc_grad) then
6159 C Explicit gradient in virtual-dihedral angles.
6160       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6161      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6162       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6163       vv(1)=pizda(1,1)+pizda(2,2)
6164       vv(2)=pizda(2,1)-pizda(1,2)
6165       if (l.eq.j+1) then
6166         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6167      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6168      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6169       else
6170         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6171      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6172      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6173       endif
6174 C Cartesian gradient
6175       do iii=1,2
6176         do kkk=1,5
6177           do lll=1,3
6178             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6179      &        pizda(1,1))
6180             vv(1)=pizda(1,1)+pizda(2,2)
6181             vv(2)=pizda(2,1)-pizda(1,2)
6182             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6183      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6184      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6185           enddo
6186         enddo
6187       enddo
6188 cd      goto 1112
6189       endif
6190 cd1111  continue
6191       if (l.eq.j+1) then
6192 cd        goto 1110
6193 C Parallel orientation
6194 C Contribution from graph III
6195         call transpose2(EUg(1,1,l),auxmat(1,1))
6196         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6197         vv(1)=pizda(1,1)-pizda(2,2)
6198         vv(2)=pizda(1,2)+pizda(2,1)
6199         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6200      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6201         if (calc_grad) then
6202 C Explicit gradient in virtual-dihedral angles.
6203         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6204      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6205      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6206         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6207         vv(1)=pizda(1,1)-pizda(2,2)
6208         vv(2)=pizda(1,2)+pizda(2,1)
6209         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6210      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6211      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6212         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6213         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6214         vv(1)=pizda(1,1)-pizda(2,2)
6215         vv(2)=pizda(1,2)+pizda(2,1)
6216         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6217      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6218      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6219 C Cartesian gradient
6220         do iii=1,2
6221           do kkk=1,5
6222             do lll=1,3
6223               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6224      &          pizda(1,1))
6225               vv(1)=pizda(1,1)-pizda(2,2)
6226               vv(2)=pizda(1,2)+pizda(2,1)
6227               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6228      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6229      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6230             enddo
6231           enddo
6232         enddo
6233 cd        goto 1112
6234         endif
6235 C Contribution from graph IV
6236 cd1110    continue
6237         call transpose2(EE(1,1,itl),auxmat(1,1))
6238         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6239         vv(1)=pizda(1,1)+pizda(2,2)
6240         vv(2)=pizda(2,1)-pizda(1,2)
6241         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6242      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6243         if (calc_grad) then
6244 C Explicit gradient in virtual-dihedral angles.
6245         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6246      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6247         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6248         vv(1)=pizda(1,1)+pizda(2,2)
6249         vv(2)=pizda(2,1)-pizda(1,2)
6250         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6251      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6252      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6253 C Cartesian gradient
6254         do iii=1,2
6255           do kkk=1,5
6256             do lll=1,3
6257               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6258      &          pizda(1,1))
6259               vv(1)=pizda(1,1)+pizda(2,2)
6260               vv(2)=pizda(2,1)-pizda(1,2)
6261               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6262      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6263      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6264             enddo
6265           enddo
6266         enddo
6267         endif
6268       else
6269 C Antiparallel orientation
6270 C Contribution from graph III
6271 c        goto 1110
6272         call transpose2(EUg(1,1,j),auxmat(1,1))
6273         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6274         vv(1)=pizda(1,1)-pizda(2,2)
6275         vv(2)=pizda(1,2)+pizda(2,1)
6276         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6277      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6278         if (calc_grad) then
6279 C Explicit gradient in virtual-dihedral angles.
6280         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6281      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6282      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6283         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6284         vv(1)=pizda(1,1)-pizda(2,2)
6285         vv(2)=pizda(1,2)+pizda(2,1)
6286         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6287      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6288      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6289         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6290         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6291         vv(1)=pizda(1,1)-pizda(2,2)
6292         vv(2)=pizda(1,2)+pizda(2,1)
6293         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6294      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6295      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6296 C Cartesian gradient
6297         do iii=1,2
6298           do kkk=1,5
6299             do lll=1,3
6300               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6301      &          pizda(1,1))
6302               vv(1)=pizda(1,1)-pizda(2,2)
6303               vv(2)=pizda(1,2)+pizda(2,1)
6304               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6305      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6306      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6307             enddo
6308           enddo
6309         enddo
6310 cd        goto 1112
6311         endif
6312 C Contribution from graph IV
6313 1110    continue
6314         call transpose2(EE(1,1,itj),auxmat(1,1))
6315         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6316         vv(1)=pizda(1,1)+pizda(2,2)
6317         vv(2)=pizda(2,1)-pizda(1,2)
6318         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6319      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6320         if (calc_grad) then
6321 C Explicit gradient in virtual-dihedral angles.
6322         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6323      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6324         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6325         vv(1)=pizda(1,1)+pizda(2,2)
6326         vv(2)=pizda(2,1)-pizda(1,2)
6327         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6328      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6329      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6330 C Cartesian gradient
6331         do iii=1,2
6332           do kkk=1,5
6333             do lll=1,3
6334               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6335      &          pizda(1,1))
6336               vv(1)=pizda(1,1)+pizda(2,2)
6337               vv(2)=pizda(2,1)-pizda(1,2)
6338               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6339      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6340      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6341             enddo
6342           enddo
6343         enddo
6344       endif
6345       endif
6346 1112  continue
6347       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6348 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6349 cd        write (2,*) 'ijkl',i,j,k,l
6350 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6351 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6352 cd      endif
6353 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6354 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6355 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6356 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6357       if (calc_grad) then
6358       if (j.lt.nres-1) then
6359         j1=j+1
6360         j2=j-1
6361       else
6362         j1=j-1
6363         j2=j-2
6364       endif
6365       if (l.lt.nres-1) then
6366         l1=l+1
6367         l2=l-1
6368       else
6369         l1=l-1
6370         l2=l-2
6371       endif
6372 cd      eij=1.0d0
6373 cd      ekl=1.0d0
6374 cd      ekont=1.0d0
6375 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6376       do ll=1,3
6377         ggg1(ll)=eel5*g_contij(ll,1)
6378         ggg2(ll)=eel5*g_contij(ll,2)
6379 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6380         ghalf=0.5d0*ggg1(ll)
6381 cd        ghalf=0.0d0
6382         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6383         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6384         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6385         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6386 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6387         ghalf=0.5d0*ggg2(ll)
6388 cd        ghalf=0.0d0
6389         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6390         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6391         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6392         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6393       enddo
6394 cd      goto 1112
6395       do m=i+1,j-1
6396         do ll=1,3
6397 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6398           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6399         enddo
6400       enddo
6401       do m=k+1,l-1
6402         do ll=1,3
6403 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6404           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6405         enddo
6406       enddo
6407 c1112  continue
6408       do m=i+2,j2
6409         do ll=1,3
6410           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6411         enddo
6412       enddo
6413       do m=k+2,l2
6414         do ll=1,3
6415           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6416         enddo
6417       enddo
6418 cd      do iii=1,nres-3
6419 cd        write (2,*) iii,g_corr5_loc(iii)
6420 cd      enddo
6421       endif
6422       eello5=ekont*eel5
6423 cd      write (2,*) 'ekont',ekont
6424 cd      write (iout,*) 'eello5',ekont*eel5
6425       return
6426       end
6427 c--------------------------------------------------------------------------
6428       double precision function eello6(i,j,k,l,jj,kk)
6429       implicit real*8 (a-h,o-z)
6430       include 'DIMENSIONS'
6431       include 'DIMENSIONS.ZSCOPT'
6432       include 'COMMON.IOUNITS'
6433       include 'COMMON.CHAIN'
6434       include 'COMMON.DERIV'
6435       include 'COMMON.INTERACT'
6436       include 'COMMON.CONTACTS'
6437       include 'COMMON.TORSION'
6438       include 'COMMON.VAR'
6439       include 'COMMON.GEO'
6440       include 'COMMON.FFIELD'
6441       double precision ggg1(3),ggg2(3)
6442 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6443 cd        eello6=0.0d0
6444 cd        return
6445 cd      endif
6446 cd      write (iout,*)
6447 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6448 cd     &   ' and',k,l
6449       eello6_1=0.0d0
6450       eello6_2=0.0d0
6451       eello6_3=0.0d0
6452       eello6_4=0.0d0
6453       eello6_5=0.0d0
6454       eello6_6=0.0d0
6455 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6456 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6457       do iii=1,2
6458         do kkk=1,5
6459           do lll=1,3
6460             derx(lll,kkk,iii)=0.0d0
6461           enddo
6462         enddo
6463       enddo
6464 cd      eij=facont_hb(jj,i)
6465 cd      ekl=facont_hb(kk,k)
6466 cd      ekont=eij*ekl
6467 cd      eij=1.0d0
6468 cd      ekl=1.0d0
6469 cd      ekont=1.0d0
6470       if (l.eq.j+1) then
6471         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6472         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6473         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6474         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6475         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6476         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6477       else
6478         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6479         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6480         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6481         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6482         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6483           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6484         else
6485           eello6_5=0.0d0
6486         endif
6487         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6488       endif
6489 C If turn contributions are considered, they will be handled separately.
6490       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6491 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6492 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6493 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6494 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6495 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6496 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6497 cd      goto 1112
6498       if (calc_grad) then
6499       if (j.lt.nres-1) then
6500         j1=j+1
6501         j2=j-1
6502       else
6503         j1=j-1
6504         j2=j-2
6505       endif
6506       if (l.lt.nres-1) then
6507         l1=l+1
6508         l2=l-1
6509       else
6510         l1=l-1
6511         l2=l-2
6512       endif
6513       do ll=1,3
6514         ggg1(ll)=eel6*g_contij(ll,1)
6515         ggg2(ll)=eel6*g_contij(ll,2)
6516 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6517         ghalf=0.5d0*ggg1(ll)
6518 cd        ghalf=0.0d0
6519         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6520         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6521         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6522         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6523         ghalf=0.5d0*ggg2(ll)
6524 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6525 cd        ghalf=0.0d0
6526         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6527         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6528         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6529         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6530       enddo
6531 cd      goto 1112
6532       do m=i+1,j-1
6533         do ll=1,3
6534 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6535           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6536         enddo
6537       enddo
6538       do m=k+1,l-1
6539         do ll=1,3
6540 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6541           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6542         enddo
6543       enddo
6544 1112  continue
6545       do m=i+2,j2
6546         do ll=1,3
6547           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6548         enddo
6549       enddo
6550       do m=k+2,l2
6551         do ll=1,3
6552           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6553         enddo
6554       enddo
6555 cd      do iii=1,nres-3
6556 cd        write (2,*) iii,g_corr6_loc(iii)
6557 cd      enddo
6558       endif
6559       eello6=ekont*eel6
6560 cd      write (2,*) 'ekont',ekont
6561 cd      write (iout,*) 'eello6',ekont*eel6
6562       return
6563       end
6564 c--------------------------------------------------------------------------
6565       double precision function eello6_graph1(i,j,k,l,imat,swap)
6566       implicit real*8 (a-h,o-z)
6567       include 'DIMENSIONS'
6568       include 'DIMENSIONS.ZSCOPT'
6569       include 'COMMON.IOUNITS'
6570       include 'COMMON.CHAIN'
6571       include 'COMMON.DERIV'
6572       include 'COMMON.INTERACT'
6573       include 'COMMON.CONTACTS'
6574       include 'COMMON.TORSION'
6575       include 'COMMON.VAR'
6576       include 'COMMON.GEO'
6577       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6578       logical swap
6579       logical lprn
6580       common /kutas/ lprn
6581 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6582 C                                                                              C
6583 C      Parallel       Antiparallel                                             C
6584 C                                                                              C
6585 C          o             o                                                     C
6586 C         /l\           /j\                                                    C
6587 C        /   \         /   \                                                   C
6588 C       /| o |         | o |\                                                  C
6589 C     \ j|/k\|  /   \  |/k\|l /                                                C
6590 C      \ /   \ /     \ /   \ /                                                 C
6591 C       o     o       o     o                                                  C
6592 C       i             i                                                        C
6593 C                                                                              C
6594 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6595       itk=itortyp(itype(k))
6596       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6597       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6598       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6599       call transpose2(EUgC(1,1,k),auxmat(1,1))
6600       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6601       vv1(1)=pizda1(1,1)-pizda1(2,2)
6602       vv1(2)=pizda1(1,2)+pizda1(2,1)
6603       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6604       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6605       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6606       s5=scalar2(vv(1),Dtobr2(1,i))
6607 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6608       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6609       if (.not. calc_grad) return
6610       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6611      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6612      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6613      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6614      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6615      & +scalar2(vv(1),Dtobr2der(1,i)))
6616       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6617       vv1(1)=pizda1(1,1)-pizda1(2,2)
6618       vv1(2)=pizda1(1,2)+pizda1(2,1)
6619       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6620       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6621       if (l.eq.j+1) then
6622         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6623      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6624      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6625      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6626      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6627       else
6628         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6629      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6630      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6631      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6632      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6633       endif
6634       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6635       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6636       vv1(1)=pizda1(1,1)-pizda1(2,2)
6637       vv1(2)=pizda1(1,2)+pizda1(2,1)
6638       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6639      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6640      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6641      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6642       do iii=1,2
6643         if (swap) then
6644           ind=3-iii
6645         else
6646           ind=iii
6647         endif
6648         do kkk=1,5
6649           do lll=1,3
6650             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6651             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6652             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6653             call transpose2(EUgC(1,1,k),auxmat(1,1))
6654             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6655      &        pizda1(1,1))
6656             vv1(1)=pizda1(1,1)-pizda1(2,2)
6657             vv1(2)=pizda1(1,2)+pizda1(2,1)
6658             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6659             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6660      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6661             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6662      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6663             s5=scalar2(vv(1),Dtobr2(1,i))
6664             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6665           enddo
6666         enddo
6667       enddo
6668       return
6669       end
6670 c----------------------------------------------------------------------------
6671       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6672       implicit real*8 (a-h,o-z)
6673       include 'DIMENSIONS'
6674       include 'DIMENSIONS.ZSCOPT'
6675       include 'COMMON.IOUNITS'
6676       include 'COMMON.CHAIN'
6677       include 'COMMON.DERIV'
6678       include 'COMMON.INTERACT'
6679       include 'COMMON.CONTACTS'
6680       include 'COMMON.TORSION'
6681       include 'COMMON.VAR'
6682       include 'COMMON.GEO'
6683       logical swap
6684       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6685      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6686       logical lprn
6687       common /kutas/ lprn
6688 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6689 C                                                                              C
6690 C      Parallel       Antiparallel                                             C
6691 C                                                                              C
6692 C          o             o                                                     C
6693 C     \   /l\           /j\   /                                                C
6694 C      \ /   \         /   \ /                                                 C
6695 C       o| o |         | o |o                                                  C
6696 C     \ j|/k\|      \  |/k\|l                                                  C
6697 C      \ /   \       \ /   \                                                   C
6698 C       o             o                                                        C
6699 C       i             i                                                        C
6700 C                                                                              C
6701 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6702 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6703 C AL 7/4/01 s1 would occur in the sixth-order moment,
6704 C           but not in a cluster cumulant
6705 #ifdef MOMENT
6706       s1=dip(1,jj,i)*dip(1,kk,k)
6707 #endif
6708       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6709       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6710       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6711       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6712       call transpose2(EUg(1,1,k),auxmat(1,1))
6713       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6714       vv(1)=pizda(1,1)-pizda(2,2)
6715       vv(2)=pizda(1,2)+pizda(2,1)
6716       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6717 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6718 #ifdef MOMENT
6719       eello6_graph2=-(s1+s2+s3+s4)
6720 #else
6721       eello6_graph2=-(s2+s3+s4)
6722 #endif
6723 c      eello6_graph2=-s3
6724       if (.not. calc_grad) return
6725 C Derivatives in gamma(i-1)
6726       if (i.gt.1) then
6727 #ifdef MOMENT
6728         s1=dipderg(1,jj,i)*dip(1,kk,k)
6729 #endif
6730         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6731         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6732         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6733         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6734 #ifdef MOMENT
6735         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6736 #else
6737         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6738 #endif
6739 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6740       endif
6741 C Derivatives in gamma(k-1)
6742 #ifdef MOMENT
6743       s1=dip(1,jj,i)*dipderg(1,kk,k)
6744 #endif
6745       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6746       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6747       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6748       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6749       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6750       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6751       vv(1)=pizda(1,1)-pizda(2,2)
6752       vv(2)=pizda(1,2)+pizda(2,1)
6753       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6754 #ifdef MOMENT
6755       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6756 #else
6757       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6758 #endif
6759 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6760 C Derivatives in gamma(j-1) or gamma(l-1)
6761       if (j.gt.1) then
6762 #ifdef MOMENT
6763         s1=dipderg(3,jj,i)*dip(1,kk,k)
6764 #endif
6765         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6766         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6767         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6768         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6769         vv(1)=pizda(1,1)-pizda(2,2)
6770         vv(2)=pizda(1,2)+pizda(2,1)
6771         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6772 #ifdef MOMENT
6773         if (swap) then
6774           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6775         else
6776           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6777         endif
6778 #endif
6779         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6780 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6781       endif
6782 C Derivatives in gamma(l-1) or gamma(j-1)
6783       if (l.gt.1) then
6784 #ifdef MOMENT
6785         s1=dip(1,jj,i)*dipderg(3,kk,k)
6786 #endif
6787         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6788         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6789         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6790         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6791         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6792         vv(1)=pizda(1,1)-pizda(2,2)
6793         vv(2)=pizda(1,2)+pizda(2,1)
6794         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6795 #ifdef MOMENT
6796         if (swap) then
6797           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6798         else
6799           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6800         endif
6801 #endif
6802         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6803 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6804       endif
6805 C Cartesian derivatives.
6806       if (lprn) then
6807         write (2,*) 'In eello6_graph2'
6808         do iii=1,2
6809           write (2,*) 'iii=',iii
6810           do kkk=1,5
6811             write (2,*) 'kkk=',kkk
6812             do jjj=1,2
6813               write (2,'(3(2f10.5),5x)')
6814      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6815             enddo
6816           enddo
6817         enddo
6818       endif
6819       do iii=1,2
6820         do kkk=1,5
6821           do lll=1,3
6822 #ifdef MOMENT
6823             if (iii.eq.1) then
6824               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6825             else
6826               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6827             endif
6828 #endif
6829             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6830      &        auxvec(1))
6831             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6832             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6833      &        auxvec(1))
6834             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6835             call transpose2(EUg(1,1,k),auxmat(1,1))
6836             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6837      &        pizda(1,1))
6838             vv(1)=pizda(1,1)-pizda(2,2)
6839             vv(2)=pizda(1,2)+pizda(2,1)
6840             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6841 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6842 #ifdef MOMENT
6843             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6844 #else
6845             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6846 #endif
6847             if (swap) then
6848               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6849             else
6850               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6851             endif
6852           enddo
6853         enddo
6854       enddo
6855       return
6856       end
6857 c----------------------------------------------------------------------------
6858       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6859       implicit real*8 (a-h,o-z)
6860       include 'DIMENSIONS'
6861       include 'DIMENSIONS.ZSCOPT'
6862       include 'COMMON.IOUNITS'
6863       include 'COMMON.CHAIN'
6864       include 'COMMON.DERIV'
6865       include 'COMMON.INTERACT'
6866       include 'COMMON.CONTACTS'
6867       include 'COMMON.TORSION'
6868       include 'COMMON.VAR'
6869       include 'COMMON.GEO'
6870       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6871       logical swap
6872 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6873 C                                                                              C
6874 C      Parallel       Antiparallel                                             C
6875 C                                                                              C
6876 C          o             o                                                     C
6877 C         /l\   /   \   /j\                                                    C
6878 C        /   \ /     \ /   \                                                   C
6879 C       /| o |o       o| o |\                                                  C
6880 C       j|/k\|  /      |/k\|l /                                                C
6881 C        /   \ /       /   \ /                                                 C
6882 C       /     o       /     o                                                  C
6883 C       i             i                                                        C
6884 C                                                                              C
6885 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6886 C
6887 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6888 C           energy moment and not to the cluster cumulant.
6889       iti=itortyp(itype(i))
6890       if (j.lt.nres-1) then
6891         itj1=itortyp(itype(j+1))
6892       else
6893         itj1=ntortyp+1
6894       endif
6895       itk=itortyp(itype(k))
6896       itk1=itortyp(itype(k+1))
6897       if (l.lt.nres-1) then
6898         itl1=itortyp(itype(l+1))
6899       else
6900         itl1=ntortyp+1
6901       endif
6902 #ifdef MOMENT
6903       s1=dip(4,jj,i)*dip(4,kk,k)
6904 #endif
6905       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6906       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6907       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6908       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6909       call transpose2(EE(1,1,itk),auxmat(1,1))
6910       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6911       vv(1)=pizda(1,1)+pizda(2,2)
6912       vv(2)=pizda(2,1)-pizda(1,2)
6913       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6914 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6915 #ifdef MOMENT
6916       eello6_graph3=-(s1+s2+s3+s4)
6917 #else
6918       eello6_graph3=-(s2+s3+s4)
6919 #endif
6920 c      eello6_graph3=-s4
6921       if (.not. calc_grad) return
6922 C Derivatives in gamma(k-1)
6923       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6924       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6925       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6926       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6927 C Derivatives in gamma(l-1)
6928       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6929       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6930       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6931       vv(1)=pizda(1,1)+pizda(2,2)
6932       vv(2)=pizda(2,1)-pizda(1,2)
6933       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6934       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6935 C Cartesian derivatives.
6936       do iii=1,2
6937         do kkk=1,5
6938           do lll=1,3
6939 #ifdef MOMENT
6940             if (iii.eq.1) then
6941               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6942             else
6943               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6944             endif
6945 #endif
6946             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6947      &        auxvec(1))
6948             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6949             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6950      &        auxvec(1))
6951             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6952             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6953      &        pizda(1,1))
6954             vv(1)=pizda(1,1)+pizda(2,2)
6955             vv(2)=pizda(2,1)-pizda(1,2)
6956             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6957 #ifdef MOMENT
6958             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6959 #else
6960             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6961 #endif
6962             if (swap) then
6963               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6964             else
6965               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6966             endif
6967 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6968           enddo
6969         enddo
6970       enddo
6971       return
6972       end
6973 c----------------------------------------------------------------------------
6974       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6975       implicit real*8 (a-h,o-z)
6976       include 'DIMENSIONS'
6977       include 'DIMENSIONS.ZSCOPT'
6978       include 'COMMON.IOUNITS'
6979       include 'COMMON.CHAIN'
6980       include 'COMMON.DERIV'
6981       include 'COMMON.INTERACT'
6982       include 'COMMON.CONTACTS'
6983       include 'COMMON.TORSION'
6984       include 'COMMON.VAR'
6985       include 'COMMON.GEO'
6986       include 'COMMON.FFIELD'
6987       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6988      & auxvec1(2),auxmat1(2,2)
6989       logical swap
6990 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6991 C                                                                              C
6992 C      Parallel       Antiparallel                                             C
6993 C                                                                              C
6994 C          o             o                                                     C
6995 C         /l\   /   \   /j\                                                    C
6996 C        /   \ /     \ /   \                                                   C
6997 C       /| o |o       o| o |\                                                  C
6998 C     \ j|/k\|      \  |/k\|l                                                  C
6999 C      \ /   \       \ /   \                                                   C
7000 C       o     \       o     \                                                  C
7001 C       i             i                                                        C
7002 C                                                                              C
7003 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7004 C
7005 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7006 C           energy moment and not to the cluster cumulant.
7007 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7008       iti=itortyp(itype(i))
7009       itj=itortyp(itype(j))
7010       if (j.lt.nres-1) then
7011         itj1=itortyp(itype(j+1))
7012       else
7013         itj1=ntortyp+1
7014       endif
7015       itk=itortyp(itype(k))
7016       if (k.lt.nres-1) then
7017         itk1=itortyp(itype(k+1))
7018       else
7019         itk1=ntortyp+1
7020       endif
7021       itl=itortyp(itype(l))
7022       if (l.lt.nres-1) then
7023         itl1=itortyp(itype(l+1))
7024       else
7025         itl1=ntortyp+1
7026       endif
7027 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7028 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7029 cd     & ' itl',itl,' itl1',itl1
7030 #ifdef MOMENT
7031       if (imat.eq.1) then
7032         s1=dip(3,jj,i)*dip(3,kk,k)
7033       else
7034         s1=dip(2,jj,j)*dip(2,kk,l)
7035       endif
7036 #endif
7037       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7038       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7039       if (j.eq.l+1) then
7040         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7041         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7042       else
7043         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7044         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7045       endif
7046       call transpose2(EUg(1,1,k),auxmat(1,1))
7047       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7048       vv(1)=pizda(1,1)-pizda(2,2)
7049       vv(2)=pizda(2,1)+pizda(1,2)
7050       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7051 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7052 #ifdef MOMENT
7053       eello6_graph4=-(s1+s2+s3+s4)
7054 #else
7055       eello6_graph4=-(s2+s3+s4)
7056 #endif
7057       if (.not. calc_grad) return
7058 C Derivatives in gamma(i-1)
7059       if (i.gt.1) then
7060 #ifdef MOMENT
7061         if (imat.eq.1) then
7062           s1=dipderg(2,jj,i)*dip(3,kk,k)
7063         else
7064           s1=dipderg(4,jj,j)*dip(2,kk,l)
7065         endif
7066 #endif
7067         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7068         if (j.eq.l+1) then
7069           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7070           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7071         else
7072           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7073           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7074         endif
7075         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7076         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7077 cd          write (2,*) 'turn6 derivatives'
7078 #ifdef MOMENT
7079           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7080 #else
7081           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7082 #endif
7083         else
7084 #ifdef MOMENT
7085           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7086 #else
7087           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7088 #endif
7089         endif
7090       endif
7091 C Derivatives in gamma(k-1)
7092 #ifdef MOMENT
7093       if (imat.eq.1) then
7094         s1=dip(3,jj,i)*dipderg(2,kk,k)
7095       else
7096         s1=dip(2,jj,j)*dipderg(4,kk,l)
7097       endif
7098 #endif
7099       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7100       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7101       if (j.eq.l+1) then
7102         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7103         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7104       else
7105         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7106         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7107       endif
7108       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7109       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7110       vv(1)=pizda(1,1)-pizda(2,2)
7111       vv(2)=pizda(2,1)+pizda(1,2)
7112       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7113       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7114 #ifdef MOMENT
7115         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7116 #else
7117         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7118 #endif
7119       else
7120 #ifdef MOMENT
7121         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7122 #else
7123         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7124 #endif
7125       endif
7126 C Derivatives in gamma(j-1) or gamma(l-1)
7127       if (l.eq.j+1 .and. l.gt.1) then
7128         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7129         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7130         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7131         vv(1)=pizda(1,1)-pizda(2,2)
7132         vv(2)=pizda(2,1)+pizda(1,2)
7133         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7134         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7135       else if (j.gt.1) then
7136         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7137         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7138         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7139         vv(1)=pizda(1,1)-pizda(2,2)
7140         vv(2)=pizda(2,1)+pizda(1,2)
7141         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7142         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7143           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7144         else
7145           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7146         endif
7147       endif
7148 C Cartesian derivatives.
7149       do iii=1,2
7150         do kkk=1,5
7151           do lll=1,3
7152 #ifdef MOMENT
7153             if (iii.eq.1) then
7154               if (imat.eq.1) then
7155                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7156               else
7157                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7158               endif
7159             else
7160               if (imat.eq.1) then
7161                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7162               else
7163                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7164               endif
7165             endif
7166 #endif
7167             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7168      &        auxvec(1))
7169             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7170             if (j.eq.l+1) then
7171               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7172      &          b1(1,itj1),auxvec(1))
7173               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7174             else
7175               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7176      &          b1(1,itl1),auxvec(1))
7177               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7178             endif
7179             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7180      &        pizda(1,1))
7181             vv(1)=pizda(1,1)-pizda(2,2)
7182             vv(2)=pizda(2,1)+pizda(1,2)
7183             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7184             if (swap) then
7185               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7186 #ifdef MOMENT
7187                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7188      &             -(s1+s2+s4)
7189 #else
7190                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7191      &             -(s2+s4)
7192 #endif
7193                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7194               else
7195 #ifdef MOMENT
7196                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7197 #else
7198                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7199 #endif
7200                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7201               endif
7202             else
7203 #ifdef MOMENT
7204               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7205 #else
7206               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7207 #endif
7208               if (l.eq.j+1) then
7209                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7210               else
7211                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7212               endif
7213             endif
7214           enddo
7215         enddo
7216       enddo
7217       return
7218       end
7219 c----------------------------------------------------------------------------
7220       double precision function eello_turn6(i,jj,kk)
7221       implicit real*8 (a-h,o-z)
7222       include 'DIMENSIONS'
7223       include 'DIMENSIONS.ZSCOPT'
7224       include 'COMMON.IOUNITS'
7225       include 'COMMON.CHAIN'
7226       include 'COMMON.DERIV'
7227       include 'COMMON.INTERACT'
7228       include 'COMMON.CONTACTS'
7229       include 'COMMON.TORSION'
7230       include 'COMMON.VAR'
7231       include 'COMMON.GEO'
7232       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7233      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7234      &  ggg1(3),ggg2(3)
7235       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7236      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7237 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7238 C           the respective energy moment and not to the cluster cumulant.
7239       eello_turn6=0.0d0
7240       j=i+4
7241       k=i+1
7242       l=i+3
7243       iti=itortyp(itype(i))
7244       itk=itortyp(itype(k))
7245       itk1=itortyp(itype(k+1))
7246       itl=itortyp(itype(l))
7247       itj=itortyp(itype(j))
7248 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7249 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7250 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7251 cd        eello6=0.0d0
7252 cd        return
7253 cd      endif
7254 cd      write (iout,*)
7255 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7256 cd     &   ' and',k,l
7257 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7258       do iii=1,2
7259         do kkk=1,5
7260           do lll=1,3
7261             derx_turn(lll,kkk,iii)=0.0d0
7262           enddo
7263         enddo
7264       enddo
7265 cd      eij=1.0d0
7266 cd      ekl=1.0d0
7267 cd      ekont=1.0d0
7268       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7269 cd      eello6_5=0.0d0
7270 cd      write (2,*) 'eello6_5',eello6_5
7271 #ifdef MOMENT
7272       call transpose2(AEA(1,1,1),auxmat(1,1))
7273       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7274       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7275       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7276 #else
7277       s1 = 0.0d0
7278 #endif
7279       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7280       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7281       s2 = scalar2(b1(1,itk),vtemp1(1))
7282 #ifdef MOMENT
7283       call transpose2(AEA(1,1,2),atemp(1,1))
7284       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7285       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7286       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7287 #else
7288       s8=0.0d0
7289 #endif
7290       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7291       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7292       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7293 #ifdef MOMENT
7294       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7295       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7296       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7297       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7298       ss13 = scalar2(b1(1,itk),vtemp4(1))
7299       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7300 #else
7301       s13=0.0d0
7302 #endif
7303 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7304 c      s1=0.0d0
7305 c      s2=0.0d0
7306 c      s8=0.0d0
7307 c      s12=0.0d0
7308 c      s13=0.0d0
7309       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7310       if (calc_grad) then
7311 C Derivatives in gamma(i+2)
7312 #ifdef MOMENT
7313       call transpose2(AEA(1,1,1),auxmatd(1,1))
7314       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7315       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7316       call transpose2(AEAderg(1,1,2),atempd(1,1))
7317       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7318       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7319 #else
7320       s8d=0.0d0
7321 #endif
7322       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7323       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7324       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7325 c      s1d=0.0d0
7326 c      s2d=0.0d0
7327 c      s8d=0.0d0
7328 c      s12d=0.0d0
7329 c      s13d=0.0d0
7330       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7331 C Derivatives in gamma(i+3)
7332 #ifdef MOMENT
7333       call transpose2(AEA(1,1,1),auxmatd(1,1))
7334       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7335       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7336       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7337 #else
7338       s1d=0.0d0
7339 #endif
7340       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7341       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7342       s2d = scalar2(b1(1,itk),vtemp1d(1))
7343 #ifdef MOMENT
7344       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7345       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7346 #endif
7347       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7348 #ifdef MOMENT
7349       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7350       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7351       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7352 #else
7353       s13d=0.0d0
7354 #endif
7355 c      s1d=0.0d0
7356 c      s2d=0.0d0
7357 c      s8d=0.0d0
7358 c      s12d=0.0d0
7359 c      s13d=0.0d0
7360 #ifdef MOMENT
7361       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7362      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7363 #else
7364       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7365      &               -0.5d0*ekont*(s2d+s12d)
7366 #endif
7367 C Derivatives in gamma(i+4)
7368       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7369       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7370       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7371 #ifdef MOMENT
7372       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7373       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7374       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7375 #else
7376       s13d = 0.0d0
7377 #endif
7378 c      s1d=0.0d0
7379 c      s2d=0.0d0
7380 c      s8d=0.0d0
7381 C      s12d=0.0d0
7382 c      s13d=0.0d0
7383 #ifdef MOMENT
7384       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7385 #else
7386       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7387 #endif
7388 C Derivatives in gamma(i+5)
7389 #ifdef MOMENT
7390       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7391       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7392       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7393 #else
7394       s1d = 0.0d0
7395 #endif
7396       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7397       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7398       s2d = scalar2(b1(1,itk),vtemp1d(1))
7399 #ifdef MOMENT
7400       call transpose2(AEA(1,1,2),atempd(1,1))
7401       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7402       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7403 #else
7404       s8d = 0.0d0
7405 #endif
7406       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7407       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7408 #ifdef MOMENT
7409       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7410       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7411       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7412 #else
7413       s13d = 0.0d0
7414 #endif
7415 c      s1d=0.0d0
7416 c      s2d=0.0d0
7417 c      s8d=0.0d0
7418 c      s12d=0.0d0
7419 c      s13d=0.0d0
7420 #ifdef MOMENT
7421       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7422      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7423 #else
7424       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7425      &               -0.5d0*ekont*(s2d+s12d)
7426 #endif
7427 C Cartesian derivatives
7428       do iii=1,2
7429         do kkk=1,5
7430           do lll=1,3
7431 #ifdef MOMENT
7432             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7433             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7434             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7435 #else
7436             s1d = 0.0d0
7437 #endif
7438             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7439             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7440      &          vtemp1d(1))
7441             s2d = scalar2(b1(1,itk),vtemp1d(1))
7442 #ifdef MOMENT
7443             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7444             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7445             s8d = -(atempd(1,1)+atempd(2,2))*
7446      &           scalar2(cc(1,1,itl),vtemp2(1))
7447 #else
7448             s8d = 0.0d0
7449 #endif
7450             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7451      &           auxmatd(1,1))
7452             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7453             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7454 c      s1d=0.0d0
7455 c      s2d=0.0d0
7456 c      s8d=0.0d0
7457 c      s12d=0.0d0
7458 c      s13d=0.0d0
7459 #ifdef MOMENT
7460             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7461      &        - 0.5d0*(s1d+s2d)
7462 #else
7463             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7464      &        - 0.5d0*s2d
7465 #endif
7466 #ifdef MOMENT
7467             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7468      &        - 0.5d0*(s8d+s12d)
7469 #else
7470             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7471      &        - 0.5d0*s12d
7472 #endif
7473           enddo
7474         enddo
7475       enddo
7476 #ifdef MOMENT
7477       do kkk=1,5
7478         do lll=1,3
7479           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7480      &      achuj_tempd(1,1))
7481           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7482           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7483           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7484           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7485           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7486      &      vtemp4d(1))
7487           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7488           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7489           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7490         enddo
7491       enddo
7492 #endif
7493 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7494 cd     &  16*eel_turn6_num
7495 cd      goto 1112
7496       if (j.lt.nres-1) then
7497         j1=j+1
7498         j2=j-1
7499       else
7500         j1=j-1
7501         j2=j-2
7502       endif
7503       if (l.lt.nres-1) then
7504         l1=l+1
7505         l2=l-1
7506       else
7507         l1=l-1
7508         l2=l-2
7509       endif
7510       do ll=1,3
7511         ggg1(ll)=eel_turn6*g_contij(ll,1)
7512         ggg2(ll)=eel_turn6*g_contij(ll,2)
7513         ghalf=0.5d0*ggg1(ll)
7514 cd        ghalf=0.0d0
7515         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7516      &    +ekont*derx_turn(ll,2,1)
7517         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7518         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7519      &    +ekont*derx_turn(ll,4,1)
7520         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7521         ghalf=0.5d0*ggg2(ll)
7522 cd        ghalf=0.0d0
7523         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7524      &    +ekont*derx_turn(ll,2,2)
7525         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7526         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7527      &    +ekont*derx_turn(ll,4,2)
7528         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7529       enddo
7530 cd      goto 1112
7531       do m=i+1,j-1
7532         do ll=1,3
7533           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7534         enddo
7535       enddo
7536       do m=k+1,l-1
7537         do ll=1,3
7538           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7539         enddo
7540       enddo
7541 1112  continue
7542       do m=i+2,j2
7543         do ll=1,3
7544           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7545         enddo
7546       enddo
7547       do m=k+2,l2
7548         do ll=1,3
7549           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7550         enddo
7551       enddo
7552 cd      do iii=1,nres-3
7553 cd        write (2,*) iii,g_corr6_loc(iii)
7554 cd      enddo
7555       endif
7556       eello_turn6=ekont*eel_turn6
7557 cd      write (2,*) 'ekont',ekont
7558 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7559       return
7560       end
7561 crc-------------------------------------------------
7562       SUBROUTINE MATVEC2(A1,V1,V2)
7563       implicit real*8 (a-h,o-z)
7564       include 'DIMENSIONS'
7565       DIMENSION A1(2,2),V1(2),V2(2)
7566 c      DO 1 I=1,2
7567 c        VI=0.0
7568 c        DO 3 K=1,2
7569 c    3     VI=VI+A1(I,K)*V1(K)
7570 c        Vaux(I)=VI
7571 c    1 CONTINUE
7572
7573       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7574       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7575
7576       v2(1)=vaux1
7577       v2(2)=vaux2
7578       END
7579 C---------------------------------------
7580       SUBROUTINE MATMAT2(A1,A2,A3)
7581       implicit real*8 (a-h,o-z)
7582       include 'DIMENSIONS'
7583       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7584 c      DIMENSION AI3(2,2)
7585 c        DO  J=1,2
7586 c          A3IJ=0.0
7587 c          DO K=1,2
7588 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7589 c          enddo
7590 c          A3(I,J)=A3IJ
7591 c       enddo
7592 c      enddo
7593
7594       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7595       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7596       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7597       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7598
7599       A3(1,1)=AI3_11
7600       A3(2,1)=AI3_21
7601       A3(1,2)=AI3_12
7602       A3(2,2)=AI3_22
7603       END
7604
7605 c-------------------------------------------------------------------------
7606       double precision function scalar2(u,v)
7607       implicit none
7608       double precision u(2),v(2)
7609       double precision sc
7610       integer i
7611       scalar2=u(1)*v(1)+u(2)*v(2)
7612       return
7613       end
7614
7615 C-----------------------------------------------------------------------------
7616
7617       subroutine transpose2(a,at)
7618       implicit none
7619       double precision a(2,2),at(2,2)
7620       at(1,1)=a(1,1)
7621       at(1,2)=a(2,1)
7622       at(2,1)=a(1,2)
7623       at(2,2)=a(2,2)
7624       return
7625       end
7626 c--------------------------------------------------------------------------
7627       subroutine transpose(n,a,at)
7628       implicit none
7629       integer n,i,j
7630       double precision a(n,n),at(n,n)
7631       do i=1,n
7632         do j=1,n
7633           at(j,i)=a(i,j)
7634         enddo
7635       enddo
7636       return
7637       end
7638 C---------------------------------------------------------------------------
7639       subroutine prodmat3(a1,a2,kk,transp,prod)
7640       implicit none
7641       integer i,j
7642       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7643       logical transp
7644 crc      double precision auxmat(2,2),prod_(2,2)
7645
7646       if (transp) then
7647 crc        call transpose2(kk(1,1),auxmat(1,1))
7648 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7649 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7650
7651            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7652      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7653            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7654      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7655            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7656      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7657            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7658      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7659
7660       else
7661 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7662 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7663
7664            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7665      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7666            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7667      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7668            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7669      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7670            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7671      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7672
7673       endif
7674 c      call transpose2(a2(1,1),a2t(1,1))
7675
7676 crc      print *,transp
7677 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7678 crc      print *,((prod(i,j),i=1,2),j=1,2)
7679
7680       return
7681       end
7682 C-----------------------------------------------------------------------------
7683       double precision function scalar(u,v)
7684       implicit none
7685       double precision u(3),v(3)
7686       double precision sc
7687       integer i
7688       sc=0.0d0
7689       do i=1,3
7690         sc=sc+u(i)*v(i)
7691       enddo
7692       scalar=sc
7693       return
7694       end
7695