source/cluster/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   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       double precision fact(6)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe,ethetacnstr)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor)
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 106 #ifdef SPLITELE
 107       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 108      & +wvdwpp*evdw1
 109      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 110      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 111      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 112      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 113      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 114      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 115 #else
 116       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 117      & +welec*fact(1)*(ees+evdw1)
 118      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 119      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 120      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 121      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 122      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 123      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 124 #endif
 125       energia(0)=etot
 126       energia(1)=evdw
 127 #ifdef SCP14
 128       energia(2)=evdw2-evdw2_14
 129       energia(17)=evdw2_14
 130 #else
 131       energia(2)=evdw2
 132       energia(17)=0.0d0
 133 #endif
 134 #ifdef SPLITELE
 135       energia(3)=ees
 136       energia(16)=evdw1
 137 #else
 138       energia(3)=ees+evdw1
 139       energia(16)=0.0d0
 140 #endif
 141       energia(4)=ecorr
 142       energia(5)=ecorr5
 143       energia(6)=ecorr6
 144       energia(7)=eel_loc
 145       energia(8)=eello_turn3
 146       energia(9)=eello_turn4
 147       energia(10)=eturn6
 148       energia(11)=ebe
 149       energia(12)=escloc
 150       energia(13)=etors
 151       energia(14)=etors_d
 152       energia(15)=ehpb
 153       energia(18)=estr
 154       energia(19)=esccor
 155       energia(20)=edihcnstr
 156       energia(21)=evdw_t
 157       energia(24)=ethetacnstr
 158 c detecting NaNQ
 159 #ifdef ISNAN
 160 #ifdef AIX
 161       if (isnan(etot).ne.0) energia(0)=1.0d+99
 162 #else
 163       if (isnan(etot)) energia(0)=1.0d+99
 164 #endif
 165 #else
 166       i=0
 167 #ifdef WINPGI
 168       idumm=proc_proc(etot,i)
 169 #else
 170       call proc_proc(etot,i)
 171 #endif
 172       if(i.eq.1)energia(0)=1.0d+99
 173 #endif
 174 #ifdef MPL
 175 c     endif
 176 #endif
 177       if (calc_grad) then
 178 C
 179 C Sum up the components of the Cartesian gradient.
 180 C
 181 #ifdef SPLITELE
 182       do i=1,nct
 183         do j=1,3
 184           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 185      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 186      &                wbond*gradb(j,i)+
 187      &                wstrain*ghpbc(j,i)+
 188      &                wcorr*fact(3)*gradcorr(j,i)+
 189      &                wel_loc*fact(2)*gel_loc(j,i)+
 190      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 191      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 192      &                wcorr5*fact(4)*gradcorr5(j,i)+
 193      &                wcorr6*fact(5)*gradcorr6(j,i)+
 194      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 195      &                wsccor*fact(2)*gsccorc(j,i)
 196           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 197      &                  wbond*gradbx(j,i)+
 198      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 199      &                  wsccor*fact(2)*gsccorx(j,i)
 200         enddo
 201 #else
 202       do i=1,nct
 203         do j=1,3
 204           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 205      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 206      &                wbond*gradb(j,i)+
 207      &                wcorr*fact(3)*gradcorr(j,i)+
 208      &                wel_loc*fact(2)*gel_loc(j,i)+
 209      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 210      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 211      &                wcorr5*fact(4)*gradcorr5(j,i)+
 212      &                wcorr6*fact(5)*gradcorr6(j,i)+
 213      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 214      &                wsccor*fact(2)*gsccorc(j,i)
 215           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 216      &                  wbond*gradbx(j,i)+
 217      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 218      &                  wsccor*fact(1)*gsccorx(j,i)
 219         enddo
 220 #endif
 221       enddo
 222
 223
 224       do i=1,nres-3
 225         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 226      &   +wcorr5*fact(4)*g_corr5_loc(i)
 227      &   +wcorr6*fact(5)*g_corr6_loc(i)
 228      &   +wturn4*fact(3)*gel_loc_turn4(i)
 229      &   +wturn3*fact(2)*gel_loc_turn3(i)
 230      &   +wturn6*fact(5)*gel_loc_turn6(i)
 231      &   +wel_loc*fact(2)*gel_loc_loc(i)
 232 c     &   +wsccor*fact(1)*gsccor_loc(i)
 233 c ROZNICA Z WHAMem
 234       enddo
 235       endif
 236       if (dyn_ss) call dyn_set_nss
 237       return
 238       end
 239 C------------------------------------------------------------------------
 240       subroutine enerprint(energia,fact)
 241       implicit real*8 (a-h,o-z)
 242       include 'DIMENSIONS'
 243       include 'sizesclu.dat'
 244       include 'COMMON.IOUNITS'
 245       include 'COMMON.FFIELD'
 246       include 'COMMON.SBRIDGE'
 247       double precision energia(0:max_ene),fact(6)
 248       etot=energia(0)
 249       evdw=energia(1)+fact(6)*energia(21)
 250 #ifdef SCP14
 251       evdw2=energia(2)+energia(17)
 252 #else
 253       evdw2=energia(2)
 254 #endif
 255       ees=energia(3)
 256 #ifdef SPLITELE
 257       evdw1=energia(16)
 258 #endif
 259       ecorr=energia(4)
 260       ecorr5=energia(5)
 261       ecorr6=energia(6)
 262       eel_loc=energia(7)
 263       eello_turn3=energia(8)
 264       eello_turn4=energia(9)
 265       eello_turn6=energia(10)
 266       ebe=energia(11)
 267       escloc=energia(12)
 268       etors=energia(13)
 269       etors_d=energia(14)
 270       ehpb=energia(15)
 271       esccor=energia(19)
 272       edihcnstr=energia(20)
 273       estr=energia(18)
 274       ethetacnstr=energia(24)
 275 #ifdef SPLITELE
 276       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 277      &  wvdwpp,
 278      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 279      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 280      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 281      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 282      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 283      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot
 284    10 format (/'Virtual-chain energies:'//
 285      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 286      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 287      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 288      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 289      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 290      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 291      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 292      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 293      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 294      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 295      & ' (SS bridges & dist. cnstr.)'/
 296      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 297      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 298      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 299      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 300      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 301      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 302      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 303      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 304      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 305      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 306      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 307      & 'ETOT=  ',1pE16.6,' (total)')
 308 #else
 309       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 310      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 311      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 312      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 313      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 314      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 315      &  edihcnstr,ethetacnstr,ebr*nss,etot
 316    10 format (/'Virtual-chain energies:'//
 317      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 318      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 319      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 320      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 321      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 322      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 323      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 324      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 325      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 326      & ' (SS bridges & dist. cnstr.)'/
 327      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 328      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 329      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 330      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 331      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 332      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 333      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 334      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 335      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 336      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 337      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 338      & 'ETOT=  ',1pE16.6,' (total)')
 339 #endif
 340       return
 341       end
 342 C-----------------------------------------------------------------------
 343       subroutine elj(evdw,evdw_t)
 344 C
 345 C This subroutine calculates the interaction energy of nonbonded side chains
 346 C assuming the LJ potential of interaction.
 347 C
 348       implicit real*8 (a-h,o-z)
 349       include 'DIMENSIONS'
 350       include 'sizesclu.dat'
 351       include "DIMENSIONS.COMPAR"
 352       parameter (accur=1.0d-10)
 353       include 'COMMON.GEO'
 354       include 'COMMON.VAR'
 355       include 'COMMON.LOCAL'
 356       include 'COMMON.CHAIN'
 357       include 'COMMON.DERIV'
 358       include 'COMMON.INTERACT'
 359       include 'COMMON.TORSION'
 360       include 'COMMON.SBRIDGE'
 361       include 'COMMON.NAMES'
 362       include 'COMMON.IOUNITS'
 363       include 'COMMON.CONTACTS'
 364       dimension gg(3)
 365       integer icant
 366       external icant
 367 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 368 c ROZNICA DODANE Z WHAM
 369 c      do i=1,210
 370 c        do j=1,2
 371 c          eneps_temp(j,i)=0.0d0
 372 c        enddo
 373 c      enddo
 374 cROZNICA
 375
 376       evdw=0.0D0
 377       evdw_t=0.0d0
 378       do i=iatsc_s,iatsc_e
 379         itypi=iabs(itype(i))
 380         if (itypi.eq.ntyp1) cycle
 381         itypi1=iabs(itype(i+1))
 382         xi=c(1,nres+i)
 383         yi=c(2,nres+i)
 384         zi=c(3,nres+i)
 385 C Change 12/1/95
 386         num_conti=0
 387 C
 388 C Calculate SC interaction energy.
 389 C
 390         do iint=1,nint_gr(i)
 391 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 392 cd   &                  'iend=',iend(i,iint)
 393           do j=istart(i,iint),iend(i,iint)
 394             itypj=iabs(itype(j))
 395             if (itypj.eq.ntyp1) cycle
 396             xj=c(1,nres+j)-xi
 397             yj=c(2,nres+j)-yi
 398             zj=c(3,nres+j)-zi
 399 C Change 12/1/95 to calculate four-body interactions
 400             rij=xj*xj+yj*yj+zj*zj
 401             rrij=1.0D0/rij
 402 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 403             eps0ij=eps(itypi,itypj)
 404             fac=rrij**expon2
 405             e1=fac*fac*aa(itypi,itypj)
 406             e2=fac*bb(itypi,itypj)
 407             evdwij=e1+e2
 408             ij=icant(itypi,itypj)
 409 c ROZNICA z WHAM
 410 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 411 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 412 c
 413
 414 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 415 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 416 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 417 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 418 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 419 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 420             if (bb(itypi,itypj).gt.0.0d0) then
 421               evdw=evdw+evdwij
 422             else
 423               evdw_t=evdw_t+evdwij
 424             endif
 425             if (calc_grad) then
 426 C
 427 C Calculate the components of the gradient in DC and X
 428 C
 429             fac=-rrij*(e1+evdwij)
 430             gg(1)=xj*fac
 431             gg(2)=yj*fac
 432             gg(3)=zj*fac
 433             do k=1,3
 434               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 435               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 436             enddo
 437             do k=i,j-1
 438               do l=1,3
 439                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 440               enddo
 441             enddo
 442             endif
 443 C
 444 C 12/1/95, revised on 5/20/97
 445 C
 446 C Calculate the contact function. The ith column of the array JCONT will
 447 C contain the numbers of atoms that make contacts with the atom I (of numbers
 448 C greater than I). The arrays FACONT and GACONT will contain the values of
 449 C the contact function and its derivative.
 450 C
 451 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 452 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 453 C Uncomment next line, if the correlation interactions are contact function only
 454             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 455               rij=dsqrt(rij)
 456               sigij=sigma(itypi,itypj)
 457               r0ij=rs0(itypi,itypj)
 458 C
 459 C Check whether the SC's are not too far to make a contact.
 460 C
 461               rcut=1.5d0*r0ij
 462               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 463 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 464 C
 465               if (fcont.gt.0.0D0) then
 466 C If the SC-SC distance if close to sigma, apply spline.
 467 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 468 cAdam &             fcont1,fprimcont1)
 469 cAdam           fcont1=1.0d0-fcont1
 470 cAdam           if (fcont1.gt.0.0d0) then
 471 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 472 cAdam             fcont=fcont*fcont1
 473 cAdam           endif
 474 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 475 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 476 cga             do k=1,3
 477 cga               gg(k)=gg(k)*eps0ij
 478 cga             enddo
 479 cga             eps0ij=-evdwij*eps0ij
 480 C Uncomment for AL's type of SC correlation interactions.
 481 cadam           eps0ij=-evdwij
 482                 num_conti=num_conti+1
 483                 jcont(num_conti,i)=j
 484                 facont(num_conti,i)=fcont*eps0ij
 485                 fprimcont=eps0ij*fprimcont/rij
 486                 fcont=expon*fcont
 487 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 488 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 489 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 490 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 491                 gacont(1,num_conti,i)=-fprimcont*xj
 492                 gacont(2,num_conti,i)=-fprimcont*yj
 493                 gacont(3,num_conti,i)=-fprimcont*zj
 494 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 495 cd              write (iout,'(2i3,3f10.5)')
 496 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 497               endif
 498             endif
 499           enddo      ! j
 500         enddo        ! iint
 501 C Change 12/1/95
 502         num_cont(i)=num_conti
 503       enddo          ! i
 504       if (calc_grad) then
 505       do i=1,nct
 506         do j=1,3
 507           gvdwc(j,i)=expon*gvdwc(j,i)
 508           gvdwx(j,i)=expon*gvdwx(j,i)
 509         enddo
 510       enddo
 511       endif
 512 C******************************************************************************
 513 C
 514 C                              N O T E !!!
 515 C
 516 C To save time, the factor of EXPON has been extracted from ALL components
 517 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 518 C use!
 519 C
 520 C******************************************************************************
 521       return
 522       end
 523 C-----------------------------------------------------------------------------
 524       subroutine eljk(evdw,evdw_t)
 525 C
 526 C This subroutine calculates the interaction energy of nonbonded side chains
 527 C assuming the LJK potential of interaction.
 528 C
 529       implicit real*8 (a-h,o-z)
 530       include 'DIMENSIONS'
 531       include 'sizesclu.dat'
 532       include "DIMENSIONS.COMPAR"
 533       include 'COMMON.GEO'
 534       include 'COMMON.VAR'
 535       include 'COMMON.LOCAL'
 536       include 'COMMON.CHAIN'
 537       include 'COMMON.DERIV'
 538       include 'COMMON.INTERACT'
 539       include 'COMMON.IOUNITS'
 540       include 'COMMON.NAMES'
 541       dimension gg(3)
 542       logical scheck
 543       integer icant
 544       external icant
 545 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 546       evdw=0.0D0
 547       evdw_t=0.0d0
 548       do i=iatsc_s,iatsc_e
 549         itypi=iabs(itype(i))
 550         if (itypi.eq.ntyp1) cycle
 551         itypi1=iabs(itype(i+1))
 552         xi=c(1,nres+i)
 553         yi=c(2,nres+i)
 554         zi=c(3,nres+i)
 555 C
 556 C Calculate SC interaction energy.
 557 C
 558         do iint=1,nint_gr(i)
 559           do j=istart(i,iint),iend(i,iint)
 560             itypj=iabs(itype(j))
 561             if (itypj.eq.ntyp1) cycle
 562             xj=c(1,nres+j)-xi
 563             yj=c(2,nres+j)-yi
 564             zj=c(3,nres+j)-zi
 565             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 566             fac_augm=rrij**expon
 567             e_augm=augm(itypi,itypj)*fac_augm
 568             r_inv_ij=dsqrt(rrij)
 569             rij=1.0D0/r_inv_ij
 570             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 571             fac=r_shift_inv**expon
 572             e1=fac*fac*aa(itypi,itypj)
 573             e2=fac*bb(itypi,itypj)
 574             evdwij=e_augm+e1+e2
 575             ij=icant(itypi,itypj)
 576 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 577 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 578 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 579 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 580 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 581 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 582 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 583             if (bb(itypi,itypj).gt.0.0d0) then
 584               evdw=evdw+evdwij
 585             else
 586               evdw_t=evdw_t+evdwij
 587             endif
 588             if (calc_grad) then
 589 C
 590 C Calculate the components of the gradient in DC and X
 591 C
 592             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 593             gg(1)=xj*fac
 594             gg(2)=yj*fac
 595             gg(3)=zj*fac
 596             do k=1,3
 597               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 598               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 599             enddo
 600             do k=i,j-1
 601               do l=1,3
 602                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 603               enddo
 604             enddo
 605             endif
 606           enddo      ! j
 607         enddo        ! iint
 608       enddo          ! i
 609       if (calc_grad) then
 610       do i=1,nct
 611         do j=1,3
 612           gvdwc(j,i)=expon*gvdwc(j,i)
 613           gvdwx(j,i)=expon*gvdwx(j,i)
 614         enddo
 615       enddo
 616       endif
 617       return
 618       end
 619 C-----------------------------------------------------------------------------
 620       subroutine ebp(evdw,evdw_t)
 621 C
 622 C This subroutine calculates the interaction energy of nonbonded side chains
 623 C assuming the Berne-Pechukas potential of interaction.
 624 C
 625       implicit real*8 (a-h,o-z)
 626       include 'DIMENSIONS'
 627       include 'sizesclu.dat'
 628       include "DIMENSIONS.COMPAR"
 629       include 'COMMON.GEO'
 630       include 'COMMON.VAR'
 631       include 'COMMON.LOCAL'
 632       include 'COMMON.CHAIN'
 633       include 'COMMON.DERIV'
 634       include 'COMMON.NAMES'
 635       include 'COMMON.INTERACT'
 636       include 'COMMON.IOUNITS'
 637       include 'COMMON.CALC'
 638       common /srutu/ icall
 639 c     double precision rrsave(maxdim)
 640       logical lprn
 641       integer icant
 642       external icant
 643       evdw=0.0D0
 644       evdw_t=0.0d0
 645 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 646 c     if (icall.eq.0) then
 647 c       lprn=.true.
 648 c     else
 649         lprn=.false.
 650 c     endif
 651       ind=0
 652       do i=iatsc_s,iatsc_e
 653         itypi=iabs(itype(i))
 654         if (itypi.eq.ntyp1) cycle
 655         itypi1=iabs(itype(i+1))
 656         xi=c(1,nres+i)
 657         yi=c(2,nres+i)
 658         zi=c(3,nres+i)
 659         dxi=dc_norm(1,nres+i)
 660         dyi=dc_norm(2,nres+i)
 661         dzi=dc_norm(3,nres+i)
 662         dsci_inv=vbld_inv(i+nres)
 663 C
 664 C Calculate SC interaction energy.
 665 C
 666         do iint=1,nint_gr(i)
 667           do j=istart(i,iint),iend(i,iint)
 668             ind=ind+1
 669             itypj=iabs(itype(j))
 670             if (itypj.eq.ntyp1) cycle
 671             dscj_inv=vbld_inv(j+nres)
 672             chi1=chi(itypi,itypj)
 673             chi2=chi(itypj,itypi)
 674             chi12=chi1*chi2
 675             chip1=chip(itypi)
 676             chip2=chip(itypj)
 677             chip12=chip1*chip2
 678             alf1=alp(itypi)
 679             alf2=alp(itypj)
 680             alf12=0.5D0*(alf1+alf2)
 681 C For diagnostics only!!!
 682 c           chi1=0.0D0
 683 c           chi2=0.0D0
 684 c           chi12=0.0D0
 685 c           chip1=0.0D0
 686 c           chip2=0.0D0
 687 c           chip12=0.0D0
 688 c           alf1=0.0D0
 689 c           alf2=0.0D0
 690 c           alf12=0.0D0
 691             xj=c(1,nres+j)-xi
 692             yj=c(2,nres+j)-yi
 693             zj=c(3,nres+j)-zi
 694             dxj=dc_norm(1,nres+j)
 695             dyj=dc_norm(2,nres+j)
 696             dzj=dc_norm(3,nres+j)
 697             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 698 cd          if (icall.eq.0) then
 699 cd            rrsave(ind)=rrij
 700 cd          else
 701 cd            rrij=rrsave(ind)
 702 cd          endif
 703             rij=dsqrt(rrij)
 704 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 705             call sc_angular
 706 C Calculate whole angle-dependent part of epsilon and contributions
 707 C to its derivatives
 708             fac=(rrij*sigsq)**expon2
 709             e1=fac*fac*aa(itypi,itypj)
 710             e2=fac*bb(itypi,itypj)
 711             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 712             eps2der=evdwij*eps3rt
 713             eps3der=evdwij*eps2rt
 714             evdwij=evdwij*eps2rt*eps3rt
 715             ij=icant(itypi,itypj)
 716             aux=eps1*eps2rt**2*eps3rt**2
 717             if (bb(itypi,itypj).gt.0.0d0) then
 718               evdw=evdw+evdwij
 719             else
 720               evdw_t=evdw_t+evdwij
 721             endif
 722             if (calc_grad) then
 723             if (lprn) then
 724             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 725             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 726 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 727 cd     &        restyp(itypi),i,restyp(itypj),j,
 728 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 729 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 730 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 731 cd     &        evdwij
 732             endif
 733 C Calculate gradient components.
 734             e1=e1*eps1*eps2rt**2*eps3rt**2
 735             fac=-expon*(e1+evdwij)
 736             sigder=fac/sigsq
 737             fac=rrij*fac
 738 C Calculate radial part of the gradient
 739             gg(1)=xj*fac
 740             gg(2)=yj*fac
 741             gg(3)=zj*fac
 742 C Calculate the angular part of the gradient and sum add the contributions
 743 C to the appropriate components of the Cartesian gradient.
 744             call sc_grad
 745             endif
 746           enddo      ! j
 747         enddo        ! iint
 748       enddo          ! i
 749 c     stop
 750       return
 751       end
 752 C-----------------------------------------------------------------------------
 753       subroutine egb(evdw,evdw_t)
 754 C
 755 C This subroutine calculates the interaction energy of nonbonded side chains
 756 C assuming the Gay-Berne potential of interaction.
 757 C
 758       implicit real*8 (a-h,o-z)
 759       include 'DIMENSIONS'
 760       include 'sizesclu.dat'
 761       include "DIMENSIONS.COMPAR"
 762       include 'COMMON.GEO'
 763       include 'COMMON.VAR'
 764       include 'COMMON.LOCAL'
 765       include 'COMMON.CHAIN'
 766       include 'COMMON.DERIV'
 767       include 'COMMON.NAMES'
 768       include 'COMMON.INTERACT'
 769       include 'COMMON.IOUNITS'
 770       include 'COMMON.CALC'
 771       include 'COMMON.SBRIDGE'
 772       logical lprn
 773       common /srutu/icall
 774       integer icant
 775       external icant
 776       integer xshift,yshift,zshift
 777       logical energy_dec /.false./
 778 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 779       evdw=0.0D0
 780       evdw_t=0.0d0
 781       lprn=.false.
 782 c      if (icall.gt.0) lprn=.true.
 783       ind=0
 784       do i=iatsc_s,iatsc_e
 785         itypi=iabs(itype(i))
 786         if (itypi.eq.ntyp1) cycle
 787         itypi1=iabs(itype(i+1))
 788         xi=c(1,nres+i)
 789         yi=c(2,nres+i)
 790         zi=c(3,nres+i)
 791           xi=mod(xi,boxxsize)
 792           if (xi.lt.0) xi=xi+boxxsize
 793           yi=mod(yi,boxysize)
 794           if (yi.lt.0) yi=yi+boxysize
 795           zi=mod(zi,boxzsize)
 796           if (zi.lt.0) zi=zi+boxzsize
 797         dxi=dc_norm(1,nres+i)
 798         dyi=dc_norm(2,nres+i)
 799         dzi=dc_norm(3,nres+i)
 800         dsci_inv=vbld_inv(i+nres)
 801 C
 802 C Calculate SC interaction energy.
 803 C
 804         do iint=1,nint_gr(i)
 805           do j=istart(i,iint),iend(i,iint)
 806             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 807
 808 c              write(iout,*) "PRZED ZWYKLE", evdwij
 809               call dyn_ssbond_ene(i,j,evdwij)
 810 c              write(iout,*) "PO ZWYKLE", evdwij
 811
 812               evdw=evdw+evdwij
 813               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 814      &                        'evdw',i,j,evdwij,' ss'
 815 C triple bond artifac removal
 816              do k=j+1,iend(i,iint)
 817 C search over all next residues
 818               if (dyn_ss_mask(k)) then
 819 C check if they are cysteins
 820 C              write(iout,*) 'k=',k
 821
 822 c              write(iout,*) "PRZED TRI", evdwij
 823                evdwij_przed_tri=evdwij
 824               call triple_ssbond_ene(i,j,k,evdwij)
 825 c               if(evdwij_przed_tri.ne.evdwij) then
 826 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 827 c               endif
 828
 829 c              write(iout,*) "PO TRI", evdwij
 830 C call the energy function that removes the artifical triple disulfide
 831 C bond the soubroutine is located in ssMD.F
 832               evdw=evdw+evdwij
 833               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 834      &                        'evdw',i,j,evdwij,'tss'
 835               endif!dyn_ss_mask(k)
 836              enddo! k
 837             ELSE
 838             ind=ind+1
 839             itypj=iabs(itype(j))
 840             if (itypj.eq.ntyp1) cycle
 841             dscj_inv=vbld_inv(j+nres)
 842             sig0ij=sigma(itypi,itypj)
 843             chi1=chi(itypi,itypj)
 844             chi2=chi(itypj,itypi)
 845             chi12=chi1*chi2
 846             chip1=chip(itypi)
 847             chip2=chip(itypj)
 848             chip12=chip1*chip2
 849             alf1=alp(itypi)
 850             alf2=alp(itypj)
 851             alf12=0.5D0*(alf1+alf2)
 852 C For diagnostics only!!!
 853 c           chi1=0.0D0
 854 c           chi2=0.0D0
 855 c           chi12=0.0D0
 856 c           chip1=0.0D0
 857 c           chip2=0.0D0
 858 c           chip12=0.0D0
 859 c           alf1=0.0D0
 860 c           alf2=0.0D0
 861 c           alf12=0.0D0
 862             xj=c(1,nres+j)
 863             yj=c(2,nres+j)
 864             zj=c(3,nres+j)
 865           xj=mod(xj,boxxsize)
 866           if (xj.lt.0) xj=xj+boxxsize
 867           yj=mod(yj,boxysize)
 868           if (yj.lt.0) yj=yj+boxysize
 869           zj=mod(zj,boxzsize)
 870           if (zj.lt.0) zj=zj+boxzsize
 871       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 872       xj_safe=xj
 873       yj_safe=yj
 874       zj_safe=zj
 875       subchap=0
 876       do xshift=-1,1
 877       do yshift=-1,1
 878       do zshift=-1,1
 879           xj=xj_safe+xshift*boxxsize
 880           yj=yj_safe+yshift*boxysize
 881           zj=zj_safe+zshift*boxzsize
 882           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 883           if(dist_temp.lt.dist_init) then
 884             dist_init=dist_temp
 885             xj_temp=xj
 886             yj_temp=yj
 887             zj_temp=zj
 888             subchap=1
 889           endif
 890        enddo
 891        enddo
 892        enddo
 893        if (subchap.eq.1) then
 894           xj=xj_temp-xi
 895           yj=yj_temp-yi
 896           zj=zj_temp-zi
 897        else
 898           xj=xj_safe-xi
 899           yj=yj_safe-yi
 900           zj=zj_safe-zi
 901        endif
 902             dxj=dc_norm(1,nres+j)
 903             dyj=dc_norm(2,nres+j)
 904             dzj=dc_norm(3,nres+j)
 905 c            write (iout,*) i,j,xj,yj,zj
 906             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 907             rij=dsqrt(rrij)
 908             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
 909             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
 910             if (sss.le.0.0d0) cycle
 911 C Calculate angle-dependent terms of energy and contributions to their
 912 C derivatives.
 913             call sc_angular
 914             sigsq=1.0D0/sigsq
 915             sig=sig0ij*dsqrt(sigsq)
 916             rij_shift=1.0D0/rij-sig+sig0ij
 917 C I hate to put IF's in the loops, but here don't have another choice!!!!
 918             if (rij_shift.le.0.0D0) then
 919               evdw=1.0D20
 920               return
 921             endif
 922             sigder=-sig*sigsq
 923 c---------------------------------------------------------------
 924             rij_shift=1.0D0/rij_shift
 925             fac=rij_shift**expon
 926             e1=fac*fac*aa(itypi,itypj)
 927             e2=fac*bb(itypi,itypj)
 928             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 929             eps2der=evdwij*eps3rt
 930             eps3der=evdwij*eps2rt
 931             evdwij=evdwij*eps2rt*eps3rt
 932             if (bb(itypi,itypj).gt.0) then
 933               evdw=evdw+evdwij*sss
 934             else
 935               evdw_t=evdw_t+evdwij*sss
 936             endif
 937             ij=icant(itypi,itypj)
 938             aux=eps1*eps2rt**2*eps3rt**2
 939 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 940 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 941 c     &         aux*e2/eps(itypi,itypj)
 942 c            if (lprn) then
 943             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 944             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 945 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 946 c     &        restyp(itypi),i,restyp(itypj),j,
 947 c     &        epsi,sigm,chi1,chi2,chip1,chip2,
 948 c     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 949 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 950 c     &        evdwij
 951 c             write (iout,*) "pratial sum", evdw,evdw_t
 952 c            endif
 953             if (calc_grad) then
 954 C Calculate gradient components.
 955             e1=e1*eps1*eps2rt**2*eps3rt**2
 956             fac=-expon*(e1+evdwij)*rij_shift
 957             sigder=fac*sigder
 958             fac=rij*fac
 959             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
 960 C Calculate the radial part of the gradient
 961             gg(1)=xj*fac
 962             gg(2)=yj*fac
 963             gg(3)=zj*fac
 964 C Calculate angular part of the gradient.
 965             call sc_grad
 966             endif
 967             ENDIF    ! dyn_ss
 968           enddo      ! j
 969         enddo        ! iint
 970       enddo          ! i
 971       return
 972       end
 973 C-----------------------------------------------------------------------------
 974       subroutine egbv(evdw,evdw_t)
 975 C
 976 C This subroutine calculates the interaction energy of nonbonded side chains
 977 C assuming the Gay-Berne-Vorobjev potential of interaction.
 978 C
 979       implicit real*8 (a-h,o-z)
 980       include 'DIMENSIONS'
 981       include 'sizesclu.dat'
 982       include "DIMENSIONS.COMPAR"
 983       include 'COMMON.GEO'
 984       include 'COMMON.VAR'
 985       include 'COMMON.LOCAL'
 986       include 'COMMON.CHAIN'
 987       include 'COMMON.DERIV'
 988       include 'COMMON.NAMES'
 989       include 'COMMON.INTERACT'
 990       include 'COMMON.IOUNITS'
 991       include 'COMMON.CALC'
 992       common /srutu/ icall
 993       logical lprn
 994       integer icant
 995       external icant
 996       evdw=0.0D0
 997       evdw_t=0.0d0
 998 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 999       evdw=0.0D0
1000       lprn=.false.
1001 c      if (icall.gt.0) lprn=.true.
1002       ind=0
1003       do i=iatsc_s,iatsc_e
1004         itypi=iabs(itype(i))
1005         if (itypi.eq.ntyp1) cycle
1006         itypi1=iabs(itype(i+1))
1007         xi=c(1,nres+i)
1008         yi=c(2,nres+i)
1009         zi=c(3,nres+i)
1010         dxi=dc_norm(1,nres+i)
1011         dyi=dc_norm(2,nres+i)
1012         dzi=dc_norm(3,nres+i)
1013         dsci_inv=vbld_inv(i+nres)
1014 C
1015 C Calculate SC interaction energy.
1016 C
1017         do iint=1,nint_gr(i)
1018           do j=istart(i,iint),iend(i,iint)
1019             ind=ind+1
1020             itypj=iabs(itype(j))
1021             if (itypj.eq.ntyp1) cycle
1022             dscj_inv=vbld_inv(j+nres)
1023             sig0ij=sigma(itypi,itypj)
1024             r0ij=r0(itypi,itypj)
1025             chi1=chi(itypi,itypj)
1026             chi2=chi(itypj,itypi)
1027             chi12=chi1*chi2
1028             chip1=chip(itypi)
1029             chip2=chip(itypj)
1030             chip12=chip1*chip2
1031             alf1=alp(itypi)
1032             alf2=alp(itypj)
1033             alf12=0.5D0*(alf1+alf2)
1034 C For diagnostics only!!!
1035 c           chi1=0.0D0
1036 c           chi2=0.0D0
1037 c           chi12=0.0D0
1038 c           chip1=0.0D0
1039 c           chip2=0.0D0
1040 c           chip12=0.0D0
1041 c           alf1=0.0D0
1042 c           alf2=0.0D0
1043 c           alf12=0.0D0
1044             xj=c(1,nres+j)-xi
1045             yj=c(2,nres+j)-yi
1046             zj=c(3,nres+j)-zi
1047             dxj=dc_norm(1,nres+j)
1048             dyj=dc_norm(2,nres+j)
1049             dzj=dc_norm(3,nres+j)
1050             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1051             rij=dsqrt(rrij)
1052 C Calculate angle-dependent terms of energy and contributions to their
1053 C derivatives.
1054             call sc_angular
1055             sigsq=1.0D0/sigsq
1056             sig=sig0ij*dsqrt(sigsq)
1057             rij_shift=1.0D0/rij-sig+r0ij
1058 C I hate to put IF's in the loops, but here don't have another choice!!!!
1059             if (rij_shift.le.0.0D0) then
1060               evdw=1.0D20
1061               return
1062             endif
1063             sigder=-sig*sigsq
1064 c---------------------------------------------------------------
1065             rij_shift=1.0D0/rij_shift
1066             fac=rij_shift**expon
1067             e1=fac*fac*aa(itypi,itypj)
1068             e2=fac*bb(itypi,itypj)
1069             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1070             eps2der=evdwij*eps3rt
1071             eps3der=evdwij*eps2rt
1072             fac_augm=rrij**expon
1073             e_augm=augm(itypi,itypj)*fac_augm
1074             evdwij=evdwij*eps2rt*eps3rt
1075             if (bb(itypi,itypj).gt.0.0d0) then
1076               evdw=evdw+evdwij+e_augm
1077             else
1078               evdw_t=evdw_t+evdwij+e_augm
1079             endif
1080             ij=icant(itypi,itypj)
1081             aux=eps1*eps2rt**2*eps3rt**2
1082 c            if (lprn) then
1083 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1084 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1085 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1086 c     &        restyp(itypi),i,restyp(itypj),j,
1087 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1088 c     &        chi1,chi2,chip1,chip2,
1089 c     &        eps1,eps2rt**2,eps3rt**2,
1090 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1091 c     &        evdwij+e_augm
1092 c            endif
1093             if (calc_grad) then
1094 C Calculate gradient components.
1095             e1=e1*eps1*eps2rt**2*eps3rt**2
1096             fac=-expon*(e1+evdwij)*rij_shift
1097             sigder=fac*sigder
1098             fac=rij*fac-2*expon*rrij*e_augm
1099 C Calculate the radial part of the gradient
1100             gg(1)=xj*fac
1101             gg(2)=yj*fac
1102             gg(3)=zj*fac
1103 C Calculate angular part of the gradient.
1104             call sc_grad
1105             endif
1106           enddo      ! j
1107         enddo        ! iint
1108       enddo          ! i
1109       return
1110       end
1111 C-----------------------------------------------------------------------------
1112       subroutine sc_angular
1113 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1114 C om12. Called by ebp, egb, and egbv.
1115       implicit none
1116       include 'COMMON.CALC'
1117       erij(1)=xj*rij
1118       erij(2)=yj*rij
1119       erij(3)=zj*rij
1120       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1121       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1122       om12=dxi*dxj+dyi*dyj+dzi*dzj
1123       chiom12=chi12*om12
1124 C Calculate eps1(om12) and its derivative in om12
1125       faceps1=1.0D0-om12*chiom12
1126       faceps1_inv=1.0D0/faceps1
1127       eps1=dsqrt(faceps1_inv)
1128 C Following variable is eps1*deps1/dom12
1129       eps1_om12=faceps1_inv*chiom12
1130 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1131 C and om12.
1132       om1om2=om1*om2
1133       chiom1=chi1*om1
1134       chiom2=chi2*om2
1135       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1136       sigsq=1.0D0-facsig*faceps1_inv
1137       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1138       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1139       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1140 C Calculate eps2 and its derivatives in om1, om2, and om12.
1141       chipom1=chip1*om1
1142       chipom2=chip2*om2
1143       chipom12=chip12*om12
1144       facp=1.0D0-om12*chipom12
1145       facp_inv=1.0D0/facp
1146       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1147 C Following variable is the square root of eps2
1148       eps2rt=1.0D0-facp1*facp_inv
1149 C Following three variables are the derivatives of the square root of eps
1150 C in om1, om2, and om12.
1151       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1152       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1153       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1154 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1155       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1156 C Calculate whole angle-dependent part of epsilon and contributions
1157 C to its derivatives
1158       return
1159       end
1160 C----------------------------------------------------------------------------
1161       subroutine sc_grad
1162       implicit real*8 (a-h,o-z)
1163       include 'DIMENSIONS'
1164       include 'sizesclu.dat'
1165       include 'COMMON.CHAIN'
1166       include 'COMMON.DERIV'
1167       include 'COMMON.CALC'
1168       double precision dcosom1(3),dcosom2(3)
1169       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1170       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1171       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1172      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1173       do k=1,3
1174         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1175         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1176       enddo
1177       do k=1,3
1178         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1179       enddo
1180       do k=1,3
1181         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1182      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1183      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1184         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1185      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1186      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1187       enddo
1188 C
1189 C Calculate the components of the gradient in DC and X
1190 C
1191       do k=i,j-1
1192         do l=1,3
1193           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1194         enddo
1195       enddo
1196       return
1197       end
1198 c------------------------------------------------------------------------------
1199       subroutine vec_and_deriv
1200       implicit real*8 (a-h,o-z)
1201       include 'DIMENSIONS'
1202       include 'sizesclu.dat'
1203       include 'COMMON.IOUNITS'
1204       include 'COMMON.GEO'
1205       include 'COMMON.VAR'
1206       include 'COMMON.LOCAL'
1207       include 'COMMON.CHAIN'
1208       include 'COMMON.VECTORS'
1209       include 'COMMON.DERIV'
1210       include 'COMMON.INTERACT'
1211       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1212 C Compute the local reference systems. For reference system (i), the
1213 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1214 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1215       do i=1,nres-1
1216 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1217           if (i.eq.nres-1) then
1218 C Case of the last full residue
1219 C Compute the Z-axis
1220             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1221             costh=dcos(pi-theta(nres))
1222             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1223             do k=1,3
1224               uz(k,i)=fac*uz(k,i)
1225             enddo
1226             if (calc_grad) then
1227 C Compute the derivatives of uz
1228             uzder(1,1,1)= 0.0d0
1229             uzder(2,1,1)=-dc_norm(3,i-1)
1230             uzder(3,1,1)= dc_norm(2,i-1)
1231             uzder(1,2,1)= dc_norm(3,i-1)
1232             uzder(2,2,1)= 0.0d0
1233             uzder(3,2,1)=-dc_norm(1,i-1)
1234             uzder(1,3,1)=-dc_norm(2,i-1)
1235             uzder(2,3,1)= dc_norm(1,i-1)
1236             uzder(3,3,1)= 0.0d0
1237             uzder(1,1,2)= 0.0d0
1238             uzder(2,1,2)= dc_norm(3,i)
1239             uzder(3,1,2)=-dc_norm(2,i)
1240             uzder(1,2,2)=-dc_norm(3,i)
1241             uzder(2,2,2)= 0.0d0
1242             uzder(3,2,2)= dc_norm(1,i)
1243             uzder(1,3,2)= dc_norm(2,i)
1244             uzder(2,3,2)=-dc_norm(1,i)
1245             uzder(3,3,2)= 0.0d0
1246             endif
1247 C Compute the Y-axis
1248             facy=fac
1249             do k=1,3
1250               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1251             enddo
1252             if (calc_grad) then
1253 C Compute the derivatives of uy
1254             do j=1,3
1255               do k=1,3
1256                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1257      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1258                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1259               enddo
1260               uyder(j,j,1)=uyder(j,j,1)-costh
1261               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1262             enddo
1263             do j=1,2
1264               do k=1,3
1265                 do l=1,3
1266                   uygrad(l,k,j,i)=uyder(l,k,j)
1267                   uzgrad(l,k,j,i)=uzder(l,k,j)
1268                 enddo
1269               enddo
1270             enddo
1271             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1272             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1273             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1274             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1275             endif
1276           else
1277 C Other residues
1278 C Compute the Z-axis
1279             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1280             costh=dcos(pi-theta(i+2))
1281             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1282             do k=1,3
1283               uz(k,i)=fac*uz(k,i)
1284             enddo
1285             if (calc_grad) then
1286 C Compute the derivatives of uz
1287             uzder(1,1,1)= 0.0d0
1288             uzder(2,1,1)=-dc_norm(3,i+1)
1289             uzder(3,1,1)= dc_norm(2,i+1)
1290             uzder(1,2,1)= dc_norm(3,i+1)
1291             uzder(2,2,1)= 0.0d0
1292             uzder(3,2,1)=-dc_norm(1,i+1)
1293             uzder(1,3,1)=-dc_norm(2,i+1)
1294             uzder(2,3,1)= dc_norm(1,i+1)
1295             uzder(3,3,1)= 0.0d0
1296             uzder(1,1,2)= 0.0d0
1297             uzder(2,1,2)= dc_norm(3,i)
1298             uzder(3,1,2)=-dc_norm(2,i)
1299             uzder(1,2,2)=-dc_norm(3,i)
1300             uzder(2,2,2)= 0.0d0
1301             uzder(3,2,2)= dc_norm(1,i)
1302             uzder(1,3,2)= dc_norm(2,i)
1303             uzder(2,3,2)=-dc_norm(1,i)
1304             uzder(3,3,2)= 0.0d0
1305             endif
1306 C Compute the Y-axis
1307             facy=fac
1308             do k=1,3
1309               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1310             enddo
1311             if (calc_grad) then
1312 C Compute the derivatives of uy
1313             do j=1,3
1314               do k=1,3
1315                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1316      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1317                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1318               enddo
1319               uyder(j,j,1)=uyder(j,j,1)-costh
1320               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1321             enddo
1322             do j=1,2
1323               do k=1,3
1324                 do l=1,3
1325                   uygrad(l,k,j,i)=uyder(l,k,j)
1326                   uzgrad(l,k,j,i)=uzder(l,k,j)
1327                 enddo
1328               enddo
1329             enddo
1330             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1331             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1332             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1333             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1334           endif
1335           endif
1336       enddo
1337       if (calc_grad) then
1338       do i=1,nres-1
1339         vbld_inv_temp(1)=vbld_inv(i+1)
1340         if (i.lt.nres-1) then
1341           vbld_inv_temp(2)=vbld_inv(i+2)
1342         else
1343           vbld_inv_temp(2)=vbld_inv(i)
1344         endif
1345         do j=1,2
1346           do k=1,3
1347             do l=1,3
1348               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1349               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1350             enddo
1351           enddo
1352         enddo
1353       enddo
1354       endif
1355       return
1356       end
1357 C-----------------------------------------------------------------------------
1358       subroutine vec_and_deriv_test
1359       implicit real*8 (a-h,o-z)
1360       include 'DIMENSIONS'
1361       include 'sizesclu.dat'
1362       include 'COMMON.IOUNITS'
1363       include 'COMMON.GEO'
1364       include 'COMMON.VAR'
1365       include 'COMMON.LOCAL'
1366       include 'COMMON.CHAIN'
1367       include 'COMMON.VECTORS'
1368       dimension uyder(3,3,2),uzder(3,3,2)
1369 C Compute the local reference systems. For reference system (i), the
1370 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1371 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1372       do i=1,nres-1
1373           if (i.eq.nres-1) then
1374 C Case of the last full residue
1375 C Compute the Z-axis
1376             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1377             costh=dcos(pi-theta(nres))
1378             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1379 c            write (iout,*) 'fac',fac,
1380 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1381             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1382             do k=1,3
1383               uz(k,i)=fac*uz(k,i)
1384             enddo
1385 C Compute the derivatives of uz
1386             uzder(1,1,1)= 0.0d0
1387             uzder(2,1,1)=-dc_norm(3,i-1)
1388             uzder(3,1,1)= dc_norm(2,i-1)
1389             uzder(1,2,1)= dc_norm(3,i-1)
1390             uzder(2,2,1)= 0.0d0
1391             uzder(3,2,1)=-dc_norm(1,i-1)
1392             uzder(1,3,1)=-dc_norm(2,i-1)
1393             uzder(2,3,1)= dc_norm(1,i-1)
1394             uzder(3,3,1)= 0.0d0
1395             uzder(1,1,2)= 0.0d0
1396             uzder(2,1,2)= dc_norm(3,i)
1397             uzder(3,1,2)=-dc_norm(2,i)
1398             uzder(1,2,2)=-dc_norm(3,i)
1399             uzder(2,2,2)= 0.0d0
1400             uzder(3,2,2)= dc_norm(1,i)
1401             uzder(1,3,2)= dc_norm(2,i)
1402             uzder(2,3,2)=-dc_norm(1,i)
1403             uzder(3,3,2)= 0.0d0
1404 C Compute the Y-axis
1405             do k=1,3
1406               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1407             enddo
1408             facy=fac
1409             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1410      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1411      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1412             do k=1,3
1413 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1414               uy(k,i)=
1415 c     &        facy*(
1416      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1417      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1418 c     &        )
1419             enddo
1420 c            write (iout,*) 'facy',facy,
1421 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1422             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1423             do k=1,3
1424               uy(k,i)=facy*uy(k,i)
1425             enddo
1426 C Compute the derivatives of uy
1427             do j=1,3
1428               do k=1,3
1429                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1430      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1431                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1432               enddo
1433 c              uyder(j,j,1)=uyder(j,j,1)-costh
1434 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1435               uyder(j,j,1)=uyder(j,j,1)
1436      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1437               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1438      &          +uyder(j,j,2)
1439             enddo
1440             do j=1,2
1441               do k=1,3
1442                 do l=1,3
1443                   uygrad(l,k,j,i)=uyder(l,k,j)
1444                   uzgrad(l,k,j,i)=uzder(l,k,j)
1445                 enddo
1446               enddo
1447             enddo
1448             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1449             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1450             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1451             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1452           else
1453 C Other residues
1454 C Compute the Z-axis
1455             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1456             costh=dcos(pi-theta(i+2))
1457             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1458             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1459             do k=1,3
1460               uz(k,i)=fac*uz(k,i)
1461             enddo
1462 C Compute the derivatives of uz
1463             uzder(1,1,1)= 0.0d0
1464             uzder(2,1,1)=-dc_norm(3,i+1)
1465             uzder(3,1,1)= dc_norm(2,i+1)
1466             uzder(1,2,1)= dc_norm(3,i+1)
1467             uzder(2,2,1)= 0.0d0
1468             uzder(3,2,1)=-dc_norm(1,i+1)
1469             uzder(1,3,1)=-dc_norm(2,i+1)
1470             uzder(2,3,1)= dc_norm(1,i+1)
1471             uzder(3,3,1)= 0.0d0
1472             uzder(1,1,2)= 0.0d0
1473             uzder(2,1,2)= dc_norm(3,i)
1474             uzder(3,1,2)=-dc_norm(2,i)
1475             uzder(1,2,2)=-dc_norm(3,i)
1476             uzder(2,2,2)= 0.0d0
1477             uzder(3,2,2)= dc_norm(1,i)
1478             uzder(1,3,2)= dc_norm(2,i)
1479             uzder(2,3,2)=-dc_norm(1,i)
1480             uzder(3,3,2)= 0.0d0
1481 C Compute the Y-axis
1482             facy=fac
1483             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1484      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1485      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1486             do k=1,3
1487 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1488               uy(k,i)=
1489 c     &        facy*(
1490      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1491      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1492 c     &        )
1493             enddo
1494 c            write (iout,*) 'facy',facy,
1495 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1496             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1497             do k=1,3
1498               uy(k,i)=facy*uy(k,i)
1499             enddo
1500 C Compute the derivatives of uy
1501             do j=1,3
1502               do k=1,3
1503                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1504      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1505                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1506               enddo
1507 c              uyder(j,j,1)=uyder(j,j,1)-costh
1508 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1509               uyder(j,j,1)=uyder(j,j,1)
1510      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1511               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1512      &          +uyder(j,j,2)
1513             enddo
1514             do j=1,2
1515               do k=1,3
1516                 do l=1,3
1517                   uygrad(l,k,j,i)=uyder(l,k,j)
1518                   uzgrad(l,k,j,i)=uzder(l,k,j)
1519                 enddo
1520               enddo
1521             enddo
1522             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1523             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1524             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1525             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1526           endif
1527       enddo
1528       do i=1,nres-1
1529         do j=1,2
1530           do k=1,3
1531             do l=1,3
1532               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1533               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1534             enddo
1535           enddo
1536         enddo
1537       enddo
1538       return
1539       end
1540 C-----------------------------------------------------------------------------
1541       subroutine check_vecgrad
1542       implicit real*8 (a-h,o-z)
1543       include 'DIMENSIONS'
1544       include 'sizesclu.dat'
1545       include 'COMMON.IOUNITS'
1546       include 'COMMON.GEO'
1547       include 'COMMON.VAR'
1548       include 'COMMON.LOCAL'
1549       include 'COMMON.CHAIN'
1550       include 'COMMON.VECTORS'
1551       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1552       dimension uyt(3,maxres),uzt(3,maxres)
1553       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1554       double precision delta /1.0d-7/
1555       call vec_and_deriv
1556 cd      do i=1,nres
1557 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1558 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1559 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1560 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1561 cd     &     (dc_norm(if90,i),if90=1,3)
1562 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1563 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1564 cd          write(iout,'(a)')
1565 cd      enddo
1566       do i=1,nres
1567         do j=1,2
1568           do k=1,3
1569             do l=1,3
1570               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1571               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1572             enddo
1573           enddo
1574         enddo
1575       enddo
1576       call vec_and_deriv
1577       do i=1,nres
1578         do j=1,3
1579           uyt(j,i)=uy(j,i)
1580           uzt(j,i)=uz(j,i)
1581         enddo
1582       enddo
1583       do i=1,nres
1584 cd        write (iout,*) 'i=',i
1585         do k=1,3
1586           erij(k)=dc_norm(k,i)
1587         enddo
1588         do j=1,3
1589           do k=1,3
1590             dc_norm(k,i)=erij(k)
1591           enddo
1592           dc_norm(j,i)=dc_norm(j,i)+delta
1593 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1594 c          do k=1,3
1595 c            dc_norm(k,i)=dc_norm(k,i)/fac
1596 c          enddo
1597 c          write (iout,*) (dc_norm(k,i),k=1,3)
1598 c          write (iout,*) (erij(k),k=1,3)
1599           call vec_and_deriv
1600           do k=1,3
1601             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1602             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1603             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1604             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1605           enddo
1606 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1607 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1608 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1609         enddo
1610         do k=1,3
1611           dc_norm(k,i)=erij(k)
1612         enddo
1613 cd        do k=1,3
1614 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1615 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1616 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1617 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1618 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1619 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1620 cd          write (iout,'(a)')
1621 cd        enddo
1622       enddo
1623       return
1624       end
1625 C--------------------------------------------------------------------------
1626       subroutine set_matrices
1627       implicit real*8 (a-h,o-z)
1628       include 'DIMENSIONS'
1629       include 'sizesclu.dat'
1630       include 'COMMON.IOUNITS'
1631       include 'COMMON.GEO'
1632       include 'COMMON.VAR'
1633       include 'COMMON.LOCAL'
1634       include 'COMMON.CHAIN'
1635       include 'COMMON.DERIV'
1636       include 'COMMON.INTERACT'
1637       include 'COMMON.CONTACTS'
1638       include 'COMMON.TORSION'
1639       include 'COMMON.VECTORS'
1640       include 'COMMON.FFIELD'
1641       double precision auxvec(2),auxmat(2,2)
1642 C
1643 C Compute the virtual-bond-torsional-angle dependent quantities needed
1644 C to calculate the el-loc multibody terms of various order.
1645 C
1646       do i=3,nres+1
1647         if (i .lt. nres+1) then
1648           sin1=dsin(phi(i))
1649           cos1=dcos(phi(i))
1650           sintab(i-2)=sin1
1651           costab(i-2)=cos1
1652           obrot(1,i-2)=cos1
1653           obrot(2,i-2)=sin1
1654           sin2=dsin(2*phi(i))
1655           cos2=dcos(2*phi(i))
1656           sintab2(i-2)=sin2
1657           costab2(i-2)=cos2
1658           obrot2(1,i-2)=cos2
1659           obrot2(2,i-2)=sin2
1660           Ug(1,1,i-2)=-cos1
1661           Ug(1,2,i-2)=-sin1
1662           Ug(2,1,i-2)=-sin1
1663           Ug(2,2,i-2)= cos1
1664           Ug2(1,1,i-2)=-cos2
1665           Ug2(1,2,i-2)=-sin2
1666           Ug2(2,1,i-2)=-sin2
1667           Ug2(2,2,i-2)= cos2
1668         else
1669           costab(i-2)=1.0d0
1670           sintab(i-2)=0.0d0
1671           obrot(1,i-2)=1.0d0
1672           obrot(2,i-2)=0.0d0
1673           obrot2(1,i-2)=0.0d0
1674           obrot2(2,i-2)=0.0d0
1675           Ug(1,1,i-2)=1.0d0
1676           Ug(1,2,i-2)=0.0d0
1677           Ug(2,1,i-2)=0.0d0
1678           Ug(2,2,i-2)=1.0d0
1679           Ug2(1,1,i-2)=0.0d0
1680           Ug2(1,2,i-2)=0.0d0
1681           Ug2(2,1,i-2)=0.0d0
1682           Ug2(2,2,i-2)=0.0d0
1683         endif
1684         if (i .gt. 3 .and. i .lt. nres+1) then
1685           obrot_der(1,i-2)=-sin1
1686           obrot_der(2,i-2)= cos1
1687           Ugder(1,1,i-2)= sin1
1688           Ugder(1,2,i-2)=-cos1
1689           Ugder(2,1,i-2)=-cos1
1690           Ugder(2,2,i-2)=-sin1
1691           dwacos2=cos2+cos2
1692           dwasin2=sin2+sin2
1693           obrot2_der(1,i-2)=-dwasin2
1694           obrot2_der(2,i-2)= dwacos2
1695           Ug2der(1,1,i-2)= dwasin2
1696           Ug2der(1,2,i-2)=-dwacos2
1697           Ug2der(2,1,i-2)=-dwacos2
1698           Ug2der(2,2,i-2)=-dwasin2
1699         else
1700           obrot_der(1,i-2)=0.0d0
1701           obrot_der(2,i-2)=0.0d0
1702           Ugder(1,1,i-2)=0.0d0
1703           Ugder(1,2,i-2)=0.0d0
1704           Ugder(2,1,i-2)=0.0d0
1705           Ugder(2,2,i-2)=0.0d0
1706           obrot2_der(1,i-2)=0.0d0
1707           obrot2_der(2,i-2)=0.0d0
1708           Ug2der(1,1,i-2)=0.0d0
1709           Ug2der(1,2,i-2)=0.0d0
1710           Ug2der(2,1,i-2)=0.0d0
1711           Ug2der(2,2,i-2)=0.0d0
1712         endif
1713         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1714           if (itype(i-2).le.ntyp) then
1715             iti = itortyp(itype(i-2))
1716           else
1717             iti=ntortyp+1
1718           endif
1719         else
1720           iti=ntortyp+1
1721         endif
1722         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1723           if (itype(i-1).le.ntyp) then
1724             iti1 = itortyp(itype(i-1))
1725           else
1726             iti1=ntortyp+1
1727           endif
1728         else
1729           iti1=ntortyp+1
1730         endif
1731 cd        write (iout,*) '*******i',i,' iti1',iti
1732 cd        write (iout,*) 'b1',b1(:,iti)
1733 cd        write (iout,*) 'b2',b2(:,iti)
1734 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1735 c        print *,"itilde1 i iti iti1",i,iti,iti1
1736         if (i .gt. iatel_s+2) then
1737           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1738           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1739           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1740           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1741           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1742           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1743           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1744         else
1745           do k=1,2
1746             Ub2(k,i-2)=0.0d0
1747             Ctobr(k,i-2)=0.0d0
1748             Dtobr2(k,i-2)=0.0d0
1749             do l=1,2
1750               EUg(l,k,i-2)=0.0d0
1751               CUg(l,k,i-2)=0.0d0
1752               DUg(l,k,i-2)=0.0d0
1753               DtUg2(l,k,i-2)=0.0d0
1754             enddo
1755           enddo
1756         endif
1757 c        print *,"itilde2 i iti iti1",i,iti,iti1
1758         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1759         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1760         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1761         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1762         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1763         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1764         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1765 c        print *,"itilde3 i iti iti1",i,iti,iti1
1766         do k=1,2
1767           muder(k,i-2)=Ub2der(k,i-2)
1768         enddo
1769         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1770           if (itype(i-1).le.ntyp) then
1771             iti1 = itortyp(itype(i-1))
1772           else
1773             iti1=ntortyp+1
1774           endif
1775         else
1776           iti1=ntortyp+1
1777         endif
1778         do k=1,2
1779           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1780         enddo
1781 C Vectors and matrices dependent on a single virtual-bond dihedral.
1782         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1783         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1784         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1785         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1786         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1787         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1788         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1789         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1790         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1791 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1792 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1793       enddo
1794 C Matrices dependent on two consecutive virtual-bond dihedrals.
1795 C The order of matrices is from left to right.
1796       do i=2,nres-1
1797         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1798         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1799         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1800         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1801         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1802         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1803         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1804         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1805       enddo
1806 cd      do i=1,nres
1807 cd        iti = itortyp(itype(i))
1808 cd        write (iout,*) i
1809 cd        do j=1,2
1810 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1811 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1812 cd        enddo
1813 cd      enddo
1814       return
1815       end
1816 C--------------------------------------------------------------------------
1817       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1818 C
1819 C This subroutine calculates the average interaction energy and its gradient
1820 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1821 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1822 C The potential depends both on the distance of peptide-group centers and on
1823 C the orientation of the CA-CA virtual bonds.
1824 C
1825       implicit real*8 (a-h,o-z)
1826       include 'DIMENSIONS'
1827       include 'sizesclu.dat'
1828       include 'COMMON.CONTROL'
1829       include 'COMMON.IOUNITS'
1830       include 'COMMON.GEO'
1831       include 'COMMON.VAR'
1832       include 'COMMON.LOCAL'
1833       include 'COMMON.CHAIN'
1834       include 'COMMON.DERIV'
1835       include 'COMMON.INTERACT'
1836       include 'COMMON.CONTACTS'
1837       include 'COMMON.TORSION'
1838       include 'COMMON.VECTORS'
1839       include 'COMMON.FFIELD'
1840       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1841      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1842       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1843      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1844       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1845 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1846       double precision scal_el /0.5d0/
1847 C 12/13/98
1848 C 13-go grudnia roku pamietnego...
1849       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1850      &                   0.0d0,1.0d0,0.0d0,
1851      &                   0.0d0,0.0d0,1.0d0/
1852 cd      write(iout,*) 'In EELEC'
1853 cd      do i=1,nloctyp
1854 cd        write(iout,*) 'Type',i
1855 cd        write(iout,*) 'B1',B1(:,i)
1856 cd        write(iout,*) 'B2',B2(:,i)
1857 cd        write(iout,*) 'CC',CC(:,:,i)
1858 cd        write(iout,*) 'DD',DD(:,:,i)
1859 cd        write(iout,*) 'EE',EE(:,:,i)
1860 cd      enddo
1861 cd      call check_vecgrad
1862 cd      stop
1863       if (icheckgrad.eq.1) then
1864         do i=1,nres-1
1865           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1866           do k=1,3
1867             dc_norm(k,i)=dc(k,i)*fac
1868           enddo
1869 c          write (iout,*) 'i',i,' fac',fac
1870         enddo
1871       endif
1872       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1873      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1874      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1875 cd      if (wel_loc.gt.0.0d0) then
1876         if (icheckgrad.eq.1) then
1877         call vec_and_deriv_test
1878         else
1879         call vec_and_deriv
1880         endif
1881         call set_matrices
1882       endif
1883 cd      do i=1,nres-1
1884 cd        write (iout,*) 'i=',i
1885 cd        do k=1,3
1886 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1887 cd        enddo
1888 cd        do k=1,3
1889 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1890 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1891 cd        enddo
1892 cd      enddo
1893       num_conti_hb=0
1894       ees=0.0D0
1895       evdw1=0.0D0
1896       eel_loc=0.0d0
1897       eello_turn3=0.0d0
1898       eello_turn4=0.0d0
1899       ind=0
1900       do i=1,nres
1901         num_cont_hb(i)=0
1902       enddo
1903 cd      print '(a)','Enter EELEC'
1904 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1905       do i=1,nres
1906         gel_loc_loc(i)=0.0d0
1907         gcorr_loc(i)=0.0d0
1908       enddo
1909       do i=iatel_s,iatel_e
1910           if (i.eq.1) then
1911            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
1912      &  .or. itype(i+2).eq.ntyp1) cycle
1913           else
1914         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
1915      &  .or. itype(i+2).eq.ntyp1
1916      &  .or. itype(i-1).eq.ntyp1
1917      &) cycle
1918          endif
1919         if (itel(i).eq.0) goto 1215
1920         dxi=dc(1,i)
1921         dyi=dc(2,i)
1922         dzi=dc(3,i)
1923         dx_normi=dc_norm(1,i)
1924         dy_normi=dc_norm(2,i)
1925         dz_normi=dc_norm(3,i)
1926         xmedi=c(1,i)+0.5d0*dxi
1927         ymedi=c(2,i)+0.5d0*dyi
1928         zmedi=c(3,i)+0.5d0*dzi
1929           xmedi=mod(xmedi,boxxsize)
1930           if (xmedi.lt.0) xmedi=xmedi+boxxsize
1931           ymedi=mod(ymedi,boxysize)
1932           if (ymedi.lt.0) ymedi=ymedi+boxysize
1933           zmedi=mod(zmedi,boxzsize)
1934           if (zmedi.lt.0) zmedi=zmedi+boxzsize
1935         num_conti=0
1936 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1937         do j=ielstart(i),ielend(i)
1938           if (j.eq.1) then
1939            if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
1940      & .or.itype(j+2).eq.ntyp1
1941      &) cycle
1942           else
1943           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
1944      & .or.itype(j+2).eq.ntyp1
1945      & .or.itype(j-1).eq.ntyp1
1946      &) cycle
1947          endif
1948           if (itel(j).eq.0) goto 1216
1949           ind=ind+1
1950           iteli=itel(i)
1951           itelj=itel(j)
1952           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1953           aaa=app(iteli,itelj)
1954           bbb=bpp(iteli,itelj)
1955 C Diagnostics only!!!
1956 c         aaa=0.0D0
1957 c         bbb=0.0D0
1958 c         ael6i=0.0D0
1959 c         ael3i=0.0D0
1960 C End diagnostics
1961           ael6i=ael6(iteli,itelj)
1962           ael3i=ael3(iteli,itelj)
1963           dxj=dc(1,j)
1964           dyj=dc(2,j)
1965           dzj=dc(3,j)
1966           dx_normj=dc_norm(1,j)
1967           dy_normj=dc_norm(2,j)
1968           dz_normj=dc_norm(3,j)
1969           xj=c(1,j)+0.5D0*dxj
1970           yj=c(2,j)+0.5D0*dyj
1971           zj=c(3,j)+0.5D0*dzj
1972          xj=mod(xj,boxxsize)
1973           if (xj.lt.0) xj=xj+boxxsize
1974           yj=mod(yj,boxysize)
1975           if (yj.lt.0) yj=yj+boxysize
1976           zj=mod(zj,boxzsize)
1977           if (zj.lt.0) zj=zj+boxzsize
1978       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1979       xj_safe=xj
1980       yj_safe=yj
1981       zj_safe=zj
1982       isubchap=0
1983       do xshift=-1,1
1984       do yshift=-1,1
1985       do zshift=-1,1
1986           xj=xj_safe+xshift*boxxsize
1987           yj=yj_safe+yshift*boxysize
1988           zj=zj_safe+zshift*boxzsize
1989           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1990           if(dist_temp.lt.dist_init) then
1991             dist_init=dist_temp
1992             xj_temp=xj
1993             yj_temp=yj
1994             zj_temp=zj
1995             isubchap=1
1996           endif
1997        enddo
1998        enddo
1999        enddo
2000        if (isubchap.eq.1) then
2001           xj=xj_temp-xmedi
2002           yj=yj_temp-ymedi
2003           zj=zj_temp-zmedi
2004        else
2005           xj=xj_safe-xmedi
2006           yj=yj_safe-ymedi
2007           zj=zj_safe-zmedi
2008        endif
2009
2010           rij=xj*xj+yj*yj+zj*zj
2011             sss=sscale(sqrt(rij))
2012             sssgrad=sscagrad(sqrt(rij))
2013           rrmij=1.0D0/rij
2014           rij=dsqrt(rij)
2015           rmij=1.0D0/rij
2016           r3ij=rrmij*rmij
2017           r6ij=r3ij*r3ij
2018           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2019           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2020           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2021           fac=cosa-3.0D0*cosb*cosg
2022           ev1=aaa*r6ij*r6ij
2023 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2024           if (j.eq.i+2) ev1=scal_el*ev1
2025           ev2=bbb*r6ij
2026           fac3=ael6i*r6ij
2027           fac4=ael3i*r3ij
2028           evdwij=ev1+ev2
2029           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2030           el2=fac4*fac
2031           eesij=el1+el2
2032 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2033 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2034           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2035           ees=ees+eesij
2036           evdw1=evdw1+evdwij*sss
2037 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2038 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2039 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2040 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2041 C
2042 C Calculate contributions to the Cartesian gradient.
2043 C
2044 #ifdef SPLITELE
2045           facvdw=-6*rrmij*(ev1+evdwij)*sss
2046           facel=-3*rrmij*(el1+eesij)
2047           fac1=fac
2048           erij(1)=xj*rmij
2049           erij(2)=yj*rmij
2050           erij(3)=zj*rmij
2051           if (calc_grad) then
2052 *
2053 * Radial derivatives. First process both termini of the fragment (i,j)
2054 *
2055           ggg(1)=facel*xj
2056           ggg(2)=facel*yj
2057           ggg(3)=facel*zj
2058           do k=1,3
2059             ghalf=0.5D0*ggg(k)
2060             gelc(k,i)=gelc(k,i)+ghalf
2061             gelc(k,j)=gelc(k,j)+ghalf
2062           enddo
2063 *
2064 * Loop over residues i+1 thru j-1.
2065 *
2066           do k=i+1,j-1
2067             do l=1,3
2068               gelc(l,k)=gelc(l,k)+ggg(l)
2069             enddo
2070           enddo
2071 C          ggg(1)=facvdw*xj
2072 C          ggg(2)=facvdw*yj
2073 C          ggg(3)=facvdw*zj
2074           if (sss.gt.0.0) then
2075           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2076           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2077           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2078           else
2079           ggg(1)=0.0
2080           ggg(2)=0.0
2081           ggg(3)=0.0
2082           endif
2083           do k=1,3
2084             ghalf=0.5D0*ggg(k)
2085             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2086             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2087           enddo
2088 *
2089 * Loop over residues i+1 thru j-1.
2090 *
2091           do k=i+1,j-1
2092             do l=1,3
2093               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2094             enddo
2095           enddo
2096 #else
2097           facvdw=(ev1+evdwij)*sss
2098           facel=el1+eesij
2099           fac1=fac
2100           fac=-3*rrmij*(facvdw+facvdw+facel)
2101           erij(1)=xj*rmij
2102           erij(2)=yj*rmij
2103           erij(3)=zj*rmij
2104           if (calc_grad) then
2105 *
2106 * Radial derivatives. First process both termini of the fragment (i,j)
2107 *
2108           ggg(1)=fac*xj
2109           ggg(2)=fac*yj
2110           ggg(3)=fac*zj
2111           do k=1,3
2112             ghalf=0.5D0*ggg(k)
2113             gelc(k,i)=gelc(k,i)+ghalf
2114             gelc(k,j)=gelc(k,j)+ghalf
2115           enddo
2116 *
2117 * Loop over residues i+1 thru j-1.
2118 *
2119           do k=i+1,j-1
2120             do l=1,3
2121               gelc(l,k)=gelc(l,k)+ggg(l)
2122             enddo
2123           enddo
2124 #endif
2125 *
2126 * Angular part
2127 *
2128           ecosa=2.0D0*fac3*fac1+fac4
2129           fac4=-3.0D0*fac4
2130           fac3=-6.0D0*fac3
2131           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2132           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2133           do k=1,3
2134             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2135             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2136           enddo
2137 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2138 cd   &          (dcosg(k),k=1,3)
2139           do k=1,3
2140             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2141           enddo
2142           do k=1,3
2143             ghalf=0.5D0*ggg(k)
2144             gelc(k,i)=gelc(k,i)+ghalf
2145      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2146      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2147             gelc(k,j)=gelc(k,j)+ghalf
2148      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2149      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2150           enddo
2151           do k=i+1,j-1
2152             do l=1,3
2153               gelc(l,k)=gelc(l,k)+ggg(l)
2154             enddo
2155           enddo
2156           endif
2157
2158           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2159      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2160      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2161 C
2162 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2163 C   energy of a peptide unit is assumed in the form of a second-order
2164 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2165 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2166 C   are computed for EVERY pair of non-contiguous peptide groups.
2167 C
2168           if (j.lt.nres-1) then
2169             j1=j+1
2170             j2=j-1
2171           else
2172             j1=j-1
2173             j2=j-2
2174           endif
2175           kkk=0
2176           do k=1,2
2177             do l=1,2
2178               kkk=kkk+1
2179               muij(kkk)=mu(k,i)*mu(l,j)
2180             enddo
2181           enddo
2182 cd         write (iout,*) 'EELEC: i',i,' j',j
2183 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2184 cd          write(iout,*) 'muij',muij
2185           ury=scalar(uy(1,i),erij)
2186           urz=scalar(uz(1,i),erij)
2187           vry=scalar(uy(1,j),erij)
2188           vrz=scalar(uz(1,j),erij)
2189           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2190           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2191           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2192           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2193 C For diagnostics only
2194 cd          a22=1.0d0
2195 cd          a23=1.0d0
2196 cd          a32=1.0d0
2197 cd          a33=1.0d0
2198           fac=dsqrt(-ael6i)*r3ij
2199 cd          write (2,*) 'fac=',fac
2200 C For diagnostics only
2201 cd          fac=1.0d0
2202           a22=a22*fac
2203           a23=a23*fac
2204           a32=a32*fac
2205           a33=a33*fac
2206 cd          write (iout,'(4i5,4f10.5)')
2207 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2208 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2209 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2210 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2211 cd          write (iout,'(4f10.5)')
2212 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2213 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2214 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2215 cd           write (iout,'(2i3,9f10.5/)') i,j,
2216 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2217           if (calc_grad) then
2218 C Derivatives of the elements of A in virtual-bond vectors
2219           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2220 cd          do k=1,3
2221 cd            do l=1,3
2222 cd              erder(k,l)=0.0d0
2223 cd            enddo
2224 cd          enddo
2225           do k=1,3
2226             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2227             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2228             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2229             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2230             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2231             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2232             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2233             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2234             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2235             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2236             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2237             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2238           enddo
2239 cd          do k=1,3
2240 cd            do l=1,3
2241 cd              uryg(k,l)=0.0d0
2242 cd              urzg(k,l)=0.0d0
2243 cd              vryg(k,l)=0.0d0
2244 cd              vrzg(k,l)=0.0d0
2245 cd            enddo
2246 cd          enddo
2247 C Compute radial contributions to the gradient
2248           facr=-3.0d0*rrmij
2249           a22der=a22*facr
2250           a23der=a23*facr
2251           a32der=a32*facr
2252           a33der=a33*facr
2253 cd          a22der=0.0d0
2254 cd          a23der=0.0d0
2255 cd          a32der=0.0d0
2256 cd          a33der=0.0d0
2257           agg(1,1)=a22der*xj
2258           agg(2,1)=a22der*yj
2259           agg(3,1)=a22der*zj
2260           agg(1,2)=a23der*xj
2261           agg(2,2)=a23der*yj
2262           agg(3,2)=a23der*zj
2263           agg(1,3)=a32der*xj
2264           agg(2,3)=a32der*yj
2265           agg(3,3)=a32der*zj
2266           agg(1,4)=a33der*xj
2267           agg(2,4)=a33der*yj
2268           agg(3,4)=a33der*zj
2269 C Add the contributions coming from er
2270           fac3=-3.0d0*fac
2271           do k=1,3
2272             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2273             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2274             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2275             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2276           enddo
2277           do k=1,3
2278 C Derivatives in DC(i)
2279             ghalf1=0.5d0*agg(k,1)
2280             ghalf2=0.5d0*agg(k,2)
2281             ghalf3=0.5d0*agg(k,3)
2282             ghalf4=0.5d0*agg(k,4)
2283             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2284      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2285             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2286      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2287             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2288      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2289             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2290      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2291 C Derivatives in DC(i+1)
2292             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2293      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2294             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2295      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2296             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2297      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2298             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2299      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2300 C Derivatives in DC(j)
2301             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2302      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2303             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2304      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2305             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2306      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2307             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2308      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2309 C Derivatives in DC(j+1) or DC(nres-1)
2310             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2311      &      -3.0d0*vryg(k,3)*ury)
2312             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2313      &      -3.0d0*vrzg(k,3)*ury)
2314             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2315      &      -3.0d0*vryg(k,3)*urz)
2316             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2317      &      -3.0d0*vrzg(k,3)*urz)
2318 cd            aggi(k,1)=ghalf1
2319 cd            aggi(k,2)=ghalf2
2320 cd            aggi(k,3)=ghalf3
2321 cd            aggi(k,4)=ghalf4
2322 C Derivatives in DC(i+1)
2323 cd            aggi1(k,1)=agg(k,1)
2324 cd            aggi1(k,2)=agg(k,2)
2325 cd            aggi1(k,3)=agg(k,3)
2326 cd            aggi1(k,4)=agg(k,4)
2327 C Derivatives in DC(j)
2328 cd            aggj(k,1)=ghalf1
2329 cd            aggj(k,2)=ghalf2
2330 cd            aggj(k,3)=ghalf3
2331 cd            aggj(k,4)=ghalf4
2332 C Derivatives in DC(j+1)
2333 cd            aggj1(k,1)=0.0d0
2334 cd            aggj1(k,2)=0.0d0
2335 cd            aggj1(k,3)=0.0d0
2336 cd            aggj1(k,4)=0.0d0
2337             if (j.eq.nres-1 .and. i.lt.j-2) then
2338               do l=1,4
2339                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2340 cd                aggj1(k,l)=agg(k,l)
2341               enddo
2342             endif
2343           enddo
2344           endif
2345 c          goto 11111
2346 C Check the loc-el terms by numerical integration
2347           acipa(1,1)=a22
2348           acipa(1,2)=a23
2349           acipa(2,1)=a32
2350           acipa(2,2)=a33
2351           a22=-a22
2352           a23=-a23
2353           do l=1,2
2354             do k=1,3
2355               agg(k,l)=-agg(k,l)
2356               aggi(k,l)=-aggi(k,l)
2357               aggi1(k,l)=-aggi1(k,l)
2358               aggj(k,l)=-aggj(k,l)
2359               aggj1(k,l)=-aggj1(k,l)
2360             enddo
2361           enddo
2362           if (j.lt.nres-1) then
2363             a22=-a22
2364             a32=-a32
2365             do l=1,3,2
2366               do k=1,3
2367                 agg(k,l)=-agg(k,l)
2368                 aggi(k,l)=-aggi(k,l)
2369                 aggi1(k,l)=-aggi1(k,l)
2370                 aggj(k,l)=-aggj(k,l)
2371                 aggj1(k,l)=-aggj1(k,l)
2372               enddo
2373             enddo
2374           else
2375             a22=-a22
2376             a23=-a23
2377             a32=-a32
2378             a33=-a33
2379             do l=1,4
2380               do k=1,3
2381                 agg(k,l)=-agg(k,l)
2382                 aggi(k,l)=-aggi(k,l)
2383                 aggi1(k,l)=-aggi1(k,l)
2384                 aggj(k,l)=-aggj(k,l)
2385                 aggj1(k,l)=-aggj1(k,l)
2386               enddo
2387             enddo
2388           endif
2389           ENDIF ! WCORR
2390 11111     continue
2391           IF (wel_loc.gt.0.0d0) THEN
2392 C Contribution to the local-electrostatic energy coming from the i-j pair
2393           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2394      &     +a33*muij(4)
2395 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2396 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2397           eel_loc=eel_loc+eel_loc_ij
2398 C Partial derivatives in virtual-bond dihedral angles gamma
2399           if (calc_grad) then
2400           if (i.gt.1)
2401      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2402      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2403      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2404           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2405      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2406      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2407 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2408 cd          write(iout,*) 'agg  ',agg
2409 cd          write(iout,*) 'aggi ',aggi
2410 cd          write(iout,*) 'aggi1',aggi1
2411 cd          write(iout,*) 'aggj ',aggj
2412 cd          write(iout,*) 'aggj1',aggj1
2413
2414 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2415           do l=1,3
2416             ggg(l)=agg(l,1)*muij(1)+
2417      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2418           enddo
2419           do k=i+2,j2
2420             do l=1,3
2421               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2422             enddo
2423           enddo
2424 C Remaining derivatives of eello
2425           do l=1,3
2426             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2427      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2428             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2429      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2430             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2431      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2432             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2433      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2434           enddo
2435           endif
2436           ENDIF
2437           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2438 C Contributions from turns
2439             a_temp(1,1)=a22
2440             a_temp(1,2)=a23
2441             a_temp(2,1)=a32
2442             a_temp(2,2)=a33
2443             call eturn34(i,j,eello_turn3,eello_turn4)
2444           endif
2445 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2446           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2447 C
2448 C Calculate the contact function. The ith column of the array JCONT will
2449 C contain the numbers of atoms that make contacts with the atom I (of numbers
2450 C greater than I). The arrays FACONT and GACONT will contain the values of
2451 C the contact function and its derivative.
2452 c           r0ij=1.02D0*rpp(iteli,itelj)
2453 c           r0ij=1.11D0*rpp(iteli,itelj)
2454             r0ij=2.20D0*rpp(iteli,itelj)
2455 c           r0ij=1.55D0*rpp(iteli,itelj)
2456             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2457             if (fcont.gt.0.0D0) then
2458               num_conti=num_conti+1
2459               if (num_conti.gt.maxconts) then
2460                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2461      &                         ' will skip next contacts for this conf.'
2462               else
2463                 jcont_hb(num_conti,i)=j
2464                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2465      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2466 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2467 C  terms.
2468                 d_cont(num_conti,i)=rij
2469 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2470 C     --- Electrostatic-interaction matrix ---
2471                 a_chuj(1,1,num_conti,i)=a22
2472                 a_chuj(1,2,num_conti,i)=a23
2473                 a_chuj(2,1,num_conti,i)=a32
2474                 a_chuj(2,2,num_conti,i)=a33
2475 C     --- Gradient of rij
2476                 do kkk=1,3
2477                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2478                 enddo
2479 c             if (i.eq.1) then
2480 c                a_chuj(1,1,num_conti,i)=-0.61d0
2481 c                a_chuj(1,2,num_conti,i)= 0.4d0
2482 c                a_chuj(2,1,num_conti,i)= 0.65d0
2483 c                a_chuj(2,2,num_conti,i)= 0.50d0
2484 c             else if (i.eq.2) then
2485 c                a_chuj(1,1,num_conti,i)= 0.0d0
2486 c                a_chuj(1,2,num_conti,i)= 0.0d0
2487 c                a_chuj(2,1,num_conti,i)= 0.0d0
2488 c                a_chuj(2,2,num_conti,i)= 0.0d0
2489 c             endif
2490 C     --- and its gradients
2491 cd                write (iout,*) 'i',i,' j',j
2492 cd                do kkk=1,3
2493 cd                write (iout,*) 'iii 1 kkk',kkk
2494 cd                write (iout,*) agg(kkk,:)
2495 cd                enddo
2496 cd                do kkk=1,3
2497 cd                write (iout,*) 'iii 2 kkk',kkk
2498 cd                write (iout,*) aggi(kkk,:)
2499 cd                enddo
2500 cd                do kkk=1,3
2501 cd                write (iout,*) 'iii 3 kkk',kkk
2502 cd                write (iout,*) aggi1(kkk,:)
2503 cd                enddo
2504 cd                do kkk=1,3
2505 cd                write (iout,*) 'iii 4 kkk',kkk
2506 cd                write (iout,*) aggj(kkk,:)
2507 cd                enddo
2508 cd                do kkk=1,3
2509 cd                write (iout,*) 'iii 5 kkk',kkk
2510 cd                write (iout,*) aggj1(kkk,:)
2511 cd                enddo
2512                 kkll=0
2513                 do k=1,2
2514                   do l=1,2
2515                     kkll=kkll+1
2516                     do m=1,3
2517                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2518                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2519                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2520                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2521                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2522 c                      do mm=1,5
2523 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2524 c                      enddo
2525                     enddo
2526                   enddo
2527                 enddo
2528                 ENDIF
2529                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2530 C Calculate contact energies
2531                 cosa4=4.0D0*cosa
2532                 wij=cosa-3.0D0*cosb*cosg
2533                 cosbg1=cosb+cosg
2534                 cosbg2=cosb-cosg
2535 c               fac3=dsqrt(-ael6i)/r0ij**3
2536                 fac3=dsqrt(-ael6i)*r3ij
2537                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2538                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2539 c               ees0mij=0.0D0
2540                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2541                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2542 C Diagnostics. Comment out or remove after debugging!
2543 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2544 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2545 c               ees0m(num_conti,i)=0.0D0
2546 C End diagnostics.
2547 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2548 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2549                 facont_hb(num_conti,i)=fcont
2550                 if (calc_grad) then
2551 C Angular derivatives of the contact function
2552                 ees0pij1=fac3/ees0pij
2553                 ees0mij1=fac3/ees0mij
2554                 fac3p=-3.0D0*fac3*rrmij
2555                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2556                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2557 c               ees0mij1=0.0D0
2558                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2559                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2560                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2561                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2562                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2563                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2564                 ecosap=ecosa1+ecosa2
2565                 ecosbp=ecosb1+ecosb2
2566                 ecosgp=ecosg1+ecosg2
2567                 ecosam=ecosa1-ecosa2
2568                 ecosbm=ecosb1-ecosb2
2569                 ecosgm=ecosg1-ecosg2
2570 C Diagnostics
2571 c               ecosap=ecosa1
2572 c               ecosbp=ecosb1
2573 c               ecosgp=ecosg1
2574 c               ecosam=0.0D0
2575 c               ecosbm=0.0D0
2576 c               ecosgm=0.0D0
2577 C End diagnostics
2578                 fprimcont=fprimcont/rij
2579 cd              facont_hb(num_conti,i)=1.0D0
2580 C Following line is for diagnostics.
2581 cd              fprimcont=0.0D0
2582                 do k=1,3
2583                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2584                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2585                 enddo
2586                 do k=1,3
2587                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2588                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2589                 enddo
2590                 gggp(1)=gggp(1)+ees0pijp*xj
2591                 gggp(2)=gggp(2)+ees0pijp*yj
2592                 gggp(3)=gggp(3)+ees0pijp*zj
2593                 gggm(1)=gggm(1)+ees0mijp*xj
2594                 gggm(2)=gggm(2)+ees0mijp*yj
2595                 gggm(3)=gggm(3)+ees0mijp*zj
2596 C Derivatives due to the contact function
2597                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2598                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2599                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2600                 do k=1,3
2601                   ghalfp=0.5D0*gggp(k)
2602                   ghalfm=0.5D0*gggm(k)
2603                   gacontp_hb1(k,num_conti,i)=ghalfp
2604      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2605      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2606                   gacontp_hb2(k,num_conti,i)=ghalfp
2607      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2608      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2609                   gacontp_hb3(k,num_conti,i)=gggp(k)
2610                   gacontm_hb1(k,num_conti,i)=ghalfm
2611      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2612      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2613                   gacontm_hb2(k,num_conti,i)=ghalfm
2614      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2615      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2616                   gacontm_hb3(k,num_conti,i)=gggm(k)
2617                 enddo
2618                 endif
2619 C Diagnostics. Comment out or remove after debugging!
2620 cdiag           do k=1,3
2621 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2622 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2623 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2624 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2625 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2626 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2627 cdiag           enddo
2628               ENDIF ! wcorr
2629               endif  ! num_conti.le.maxconts
2630             endif  ! fcont.gt.0
2631           endif    ! j.gt.i+1
2632  1216     continue
2633         enddo ! j
2634         num_cont_hb(i)=num_conti
2635  1215   continue
2636       enddo   ! i
2637 cd      do i=1,nres
2638 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2639 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2640 cd      enddo
2641 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2642 ccc      eel_loc=eel_loc+eello_turn3
2643       return
2644       end
2645 C-----------------------------------------------------------------------------
2646       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2647 C Third- and fourth-order contributions from turns
2648       implicit real*8 (a-h,o-z)
2649       include 'DIMENSIONS'
2650       include 'sizesclu.dat'
2651       include 'COMMON.IOUNITS'
2652       include 'COMMON.GEO'
2653       include 'COMMON.VAR'
2654       include 'COMMON.LOCAL'
2655       include 'COMMON.CHAIN'
2656       include 'COMMON.DERIV'
2657       include 'COMMON.INTERACT'
2658       include 'COMMON.CONTACTS'
2659       include 'COMMON.TORSION'
2660       include 'COMMON.VECTORS'
2661       include 'COMMON.FFIELD'
2662       dimension ggg(3)
2663       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2664      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2665      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2666       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2667      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2668       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2669       if (j.eq.i+2) then
2670 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2671 C
2672 C               Third-order contributions
2673 C
2674 C                 (i+2)o----(i+3)
2675 C                      | |
2676 C                      | |
2677 C                 (i+1)o----i
2678 C
2679 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2680 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2681         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2682         call transpose2(auxmat(1,1),auxmat1(1,1))
2683         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2684         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2685 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2686 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2687 cd     &    ' eello_turn3_num',4*eello_turn3_num
2688         if (calc_grad) then
2689 C Derivatives in gamma(i)
2690         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2691         call transpose2(auxmat2(1,1),pizda(1,1))
2692         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2693         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2694 C Derivatives in gamma(i+1)
2695         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2696         call transpose2(auxmat2(1,1),pizda(1,1))
2697         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2698         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2699      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2700 C Cartesian derivatives
2701         do l=1,3
2702           a_temp(1,1)=aggi(l,1)
2703           a_temp(1,2)=aggi(l,2)
2704           a_temp(2,1)=aggi(l,3)
2705           a_temp(2,2)=aggi(l,4)
2706           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2707           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2708      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2709           a_temp(1,1)=aggi1(l,1)
2710           a_temp(1,2)=aggi1(l,2)
2711           a_temp(2,1)=aggi1(l,3)
2712           a_temp(2,2)=aggi1(l,4)
2713           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2714           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2715      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2716           a_temp(1,1)=aggj(l,1)
2717           a_temp(1,2)=aggj(l,2)
2718           a_temp(2,1)=aggj(l,3)
2719           a_temp(2,2)=aggj(l,4)
2720           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2721           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2722      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2723           a_temp(1,1)=aggj1(l,1)
2724           a_temp(1,2)=aggj1(l,2)
2725           a_temp(2,1)=aggj1(l,3)
2726           a_temp(2,2)=aggj1(l,4)
2727           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2728           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2729      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2730         enddo
2731         endif
2732       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2733 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2734 C
2735 C               Fourth-order contributions
2736 C
2737 C                 (i+3)o----(i+4)
2738 C                     /  |
2739 C               (i+2)o   |
2740 C                     \  |
2741 C                 (i+1)o----i
2742 C
2743 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2744 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2745         iti1=itortyp(itype(i+1))
2746         iti2=itortyp(itype(i+2))
2747         iti3=itortyp(itype(i+3))
2748         call transpose2(EUg(1,1,i+1),e1t(1,1))
2749         call transpose2(Eug(1,1,i+2),e2t(1,1))
2750         call transpose2(Eug(1,1,i+3),e3t(1,1))
2751         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2752         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2753         s1=scalar2(b1(1,iti2),auxvec(1))
2754         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2755         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2756         s2=scalar2(b1(1,iti1),auxvec(1))
2757         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2758         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2759         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2760         eello_turn4=eello_turn4-(s1+s2+s3)
2761 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2762 cd     &    ' eello_turn4_num',8*eello_turn4_num
2763 C Derivatives in gamma(i)
2764         if (calc_grad) then
2765         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2766         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2767         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2768         s1=scalar2(b1(1,iti2),auxvec(1))
2769         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2770         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2771         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2772 C Derivatives in gamma(i+1)
2773         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2774         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2775         s2=scalar2(b1(1,iti1),auxvec(1))
2776         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2777         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2778         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2779         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2780 C Derivatives in gamma(i+2)
2781         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2782         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2783         s1=scalar2(b1(1,iti2),auxvec(1))
2784         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2785         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2786         s2=scalar2(b1(1,iti1),auxvec(1))
2787         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2788         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2789         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2790         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2791 C Cartesian derivatives
2792 C Derivatives of this turn contributions in DC(i+2)
2793         if (j.lt.nres-1) then
2794           do l=1,3
2795             a_temp(1,1)=agg(l,1)
2796             a_temp(1,2)=agg(l,2)
2797             a_temp(2,1)=agg(l,3)
2798             a_temp(2,2)=agg(l,4)
2799             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2800             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2801             s1=scalar2(b1(1,iti2),auxvec(1))
2802             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2803             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2804             s2=scalar2(b1(1,iti1),auxvec(1))
2805             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2806             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2807             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2808             ggg(l)=-(s1+s2+s3)
2809             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2810           enddo
2811         endif
2812 C Remaining derivatives of this turn contribution
2813         do l=1,3
2814           a_temp(1,1)=aggi(l,1)
2815           a_temp(1,2)=aggi(l,2)
2816           a_temp(2,1)=aggi(l,3)
2817           a_temp(2,2)=aggi(l,4)
2818           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2819           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2820           s1=scalar2(b1(1,iti2),auxvec(1))
2821           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2822           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2823           s2=scalar2(b1(1,iti1),auxvec(1))
2824           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2825           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2826           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2827           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2828           a_temp(1,1)=aggi1(l,1)
2829           a_temp(1,2)=aggi1(l,2)
2830           a_temp(2,1)=aggi1(l,3)
2831           a_temp(2,2)=aggi1(l,4)
2832           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2833           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2834           s1=scalar2(b1(1,iti2),auxvec(1))
2835           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2836           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2837           s2=scalar2(b1(1,iti1),auxvec(1))
2838           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2839           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2840           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2841           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2842           a_temp(1,1)=aggj(l,1)
2843           a_temp(1,2)=aggj(l,2)
2844           a_temp(2,1)=aggj(l,3)
2845           a_temp(2,2)=aggj(l,4)
2846           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2847           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2848           s1=scalar2(b1(1,iti2),auxvec(1))
2849           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2850           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2851           s2=scalar2(b1(1,iti1),auxvec(1))
2852           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2853           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2854           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2855           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2856           a_temp(1,1)=aggj1(l,1)
2857           a_temp(1,2)=aggj1(l,2)
2858           a_temp(2,1)=aggj1(l,3)
2859           a_temp(2,2)=aggj1(l,4)
2860           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2861           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2862           s1=scalar2(b1(1,iti2),auxvec(1))
2863           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2864           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2865           s2=scalar2(b1(1,iti1),auxvec(1))
2866           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2867           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2868           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2869           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2870         enddo
2871         endif
2872       endif
2873       return
2874       end
2875 C-----------------------------------------------------------------------------
2876       subroutine vecpr(u,v,w)
2877       implicit real*8(a-h,o-z)
2878       dimension u(3),v(3),w(3)
2879       w(1)=u(2)*v(3)-u(3)*v(2)
2880       w(2)=-u(1)*v(3)+u(3)*v(1)
2881       w(3)=u(1)*v(2)-u(2)*v(1)
2882       return
2883       end
2884 C-----------------------------------------------------------------------------
2885       subroutine unormderiv(u,ugrad,unorm,ungrad)
2886 C This subroutine computes the derivatives of a normalized vector u, given
2887 C the derivatives computed without normalization conditions, ugrad. Returns
2888 C ungrad.
2889       implicit none
2890       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2891       double precision vec(3)
2892       double precision scalar
2893       integer i,j
2894 c      write (2,*) 'ugrad',ugrad
2895 c      write (2,*) 'u',u
2896       do i=1,3
2897         vec(i)=scalar(ugrad(1,i),u(1))
2898       enddo
2899 c      write (2,*) 'vec',vec
2900       do i=1,3
2901         do j=1,3
2902           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2903         enddo
2904       enddo
2905 c      write (2,*) 'ungrad',ungrad
2906       return
2907       end
2908 C-----------------------------------------------------------------------------
2909       subroutine escp(evdw2,evdw2_14)
2910 C
2911 C This subroutine calculates the excluded-volume interaction energy between
2912 C peptide-group centers and side chains and its gradient in virtual-bond and
2913 C side-chain vectors.
2914 C
2915       implicit real*8 (a-h,o-z)
2916       include 'DIMENSIONS'
2917       include 'sizesclu.dat'
2918       include 'COMMON.GEO'
2919       include 'COMMON.VAR'
2920       include 'COMMON.LOCAL'
2921       include 'COMMON.CHAIN'
2922       include 'COMMON.DERIV'
2923       include 'COMMON.INTERACT'
2924       include 'COMMON.FFIELD'
2925       include 'COMMON.IOUNITS'
2926       dimension ggg(3)
2927       evdw2=0.0D0
2928       evdw2_14=0.0d0
2929 cd    print '(a)','Enter ESCP'
2930 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2931 c     &  ' scal14',scal14
2932       do i=iatscp_s,iatscp_e
2933         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2934         iteli=itel(i)
2935 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2936 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2937         if (iteli.eq.0) goto 1225
2938         xi=0.5D0*(c(1,i)+c(1,i+1))
2939         yi=0.5D0*(c(2,i)+c(2,i+1))
2940         zi=0.5D0*(c(3,i)+c(3,i+1))
2941 C    Returning the ith atom to box
2942           xi=mod(xi,boxxsize)
2943           if (xi.lt.0) xi=xi+boxxsize
2944           yi=mod(yi,boxysize)
2945           if (yi.lt.0) yi=yi+boxysize
2946           zi=mod(zi,boxzsize)
2947           if (zi.lt.0) zi=zi+boxzsize
2948
2949         do iint=1,nscp_gr(i)
2950
2951         do j=iscpstart(i,iint),iscpend(i,iint)
2952           itypj=iabs(itype(j))
2953           if (itypj.eq.ntyp1) cycle
2954 C Uncomment following three lines for SC-p interactions
2955 c         xj=c(1,nres+j)-xi
2956 c         yj=c(2,nres+j)-yi
2957 c         zj=c(3,nres+j)-zi
2958 C Uncomment following three lines for Ca-p interactions
2959           xj=c(1,j)
2960           yj=c(2,j)
2961           zj=c(3,j)
2962 C returning the jth atom to box
2963           xj=mod(xj,boxxsize)
2964           if (xj.lt.0) xj=xj+boxxsize
2965           yj=mod(yj,boxysize)
2966           if (yj.lt.0) yj=yj+boxysize
2967           zj=mod(zj,boxzsize)
2968           if (zj.lt.0) zj=zj+boxzsize
2969       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2970       xj_safe=xj
2971       yj_safe=yj
2972       zj_safe=zj
2973       subchap=0
2974 C Finding the closest jth atom
2975       do xshift=-1,1
2976       do yshift=-1,1
2977       do zshift=-1,1
2978           xj=xj_safe+xshift*boxxsize
2979           yj=yj_safe+yshift*boxysize
2980           zj=zj_safe+zshift*boxzsize
2981           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2982           if(dist_temp.lt.dist_init) then
2983             dist_init=dist_temp
2984             xj_temp=xj
2985             yj_temp=yj
2986             zj_temp=zj
2987             subchap=1
2988           endif
2989        enddo
2990        enddo
2991        enddo
2992        if (subchap.eq.1) then
2993           xj=xj_temp-xi
2994           yj=yj_temp-yi
2995           zj=zj_temp-zi
2996        else
2997           xj=xj_safe-xi
2998           yj=yj_safe-yi
2999           zj=zj_safe-zi
3000        endif
3001
3002           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3003 C sss is scaling function for smoothing the cutoff gradient otherwise
3004 C the gradient would not be continuouse
3005           sss=sscale(1.0d0/(dsqrt(rrij)))
3006           if (sss.le.0.0d0) cycle
3007           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3008           fac=rrij**expon2
3009           e1=fac*fac*aad(itypj,iteli)
3010           e2=fac*bad(itypj,iteli)
3011           if (iabs(j-i) .le. 2) then
3012             e1=scal14*e1
3013             e2=scal14*e2
3014             evdw2_14=evdw2_14+(e1+e2)*sss
3015           endif
3016           evdwij=e1+e2
3017 c          write (iout,*) i,j,evdwij
3018           evdw2=evdw2+evdwij*sss
3019           if (calc_grad) then
3020 C
3021 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3022 C
3023            fac=-(evdwij+e1)*rrij*sss
3024            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3025           ggg(1)=xj*fac
3026           ggg(2)=yj*fac
3027           ggg(3)=zj*fac
3028           if (j.lt.i) then
3029 cd          write (iout,*) 'j<i'
3030 C Uncomment following three lines for SC-p interactions
3031 c           do k=1,3
3032 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3033 c           enddo
3034           else
3035 cd          write (iout,*) 'j>i'
3036             do k=1,3
3037               ggg(k)=-ggg(k)
3038 C Uncomment following line for SC-p interactions
3039 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3040             enddo
3041           endif
3042           do k=1,3
3043             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3044           enddo
3045           kstart=min0(i+1,j)
3046           kend=max0(i-1,j-1)
3047 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3048 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3049           do k=kstart,kend
3050             do l=1,3
3051               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3052             enddo
3053           enddo
3054           endif
3055         enddo
3056         enddo ! iint
3057  1225   continue
3058       enddo ! i
3059       do i=1,nct
3060         do j=1,3
3061           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3062           gradx_scp(j,i)=expon*gradx_scp(j,i)
3063         enddo
3064       enddo
3065 C******************************************************************************
3066 C
3067 C                              N O T E !!!
3068 C
3069 C To save time the factor EXPON has been extracted from ALL components
3070 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3071 C use!
3072 C
3073 C******************************************************************************
3074       return
3075       end
3076 C--------------------------------------------------------------------------
3077       subroutine edis(ehpb)
3078 C
3079 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3080 C
3081       implicit real*8 (a-h,o-z)
3082       include 'DIMENSIONS'
3083       include 'sizesclu.dat'
3084       include 'COMMON.SBRIDGE'
3085       include 'COMMON.CHAIN'
3086       include 'COMMON.DERIV'
3087       include 'COMMON.VAR'
3088       include 'COMMON.INTERACT'
3089       include 'COMMON.CONTROL'
3090       dimension ggg(3)
3091       ehpb=0.0D0
3092 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3093 cd    print *,'link_start=',link_start,' link_end=',link_end
3094       if (link_end.eq.0) return
3095       do i=link_start,link_end
3096 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3097 C CA-CA distance used in regularization of structure.
3098         ii=ihpb(i)
3099         jj=jhpb(i)
3100 C iii and jjj point to the residues for which the distance is assigned.
3101         if (ii.gt.nres) then
3102           iii=ii-nres
3103           jjj=jj-nres
3104         else
3105           iii=ii
3106           jjj=jj
3107         endif
3108 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3109 C    distance and angle dependent SS bond potential.
3110 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3111 C     &  iabs(itype(jjj)).eq.1) then
3112 C          call ssbond_ene(iii,jjj,eij)
3113 C          ehpb=ehpb+2*eij
3114 C        else
3115        if (.not.dyn_ss .and. i.le.nss) then
3116          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3117      & iabs(itype(jjj)).eq.1) then
3118           call ssbond_ene(iii,jjj,eij)
3119           ehpb=ehpb+2*eij
3120            endif !ii.gt.neres
3121         else if (ii.gt.nres .and. jj.gt.nres) then
3122 c Restraints from contact prediction
3123           dd=dist(ii,jj)
3124           if (constr_dist.eq.11) then
3125 C            ehpb=ehpb+fordepth(i)**4.0d0
3126 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3127             ehpb=ehpb+fordepth(i)**4.0d0
3128      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3129             fac=fordepth(i)**4.0d0
3130      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3131 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3132 C     &    ehpb,fordepth(i),dd
3133 C             print *,"TUTU"
3134 C            write(iout,*) ehpb,"atu?"
3135 C            ehpb,"tu?"
3136 C            fac=fordepth(i)**4.0d0
3137 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3138            else !constr_dist.eq.11
3139           if (dhpb1(i).gt.0.0d0) then
3140             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3141             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3142 c            write (iout,*) "beta nmr",
3143 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3144           else !dhpb(i).gt.0.00
3145
3146 C Calculate the distance between the two points and its difference from the
3147 C target distance.
3148         dd=dist(ii,jj)
3149         rdis=dd-dhpb(i)
3150 C Get the force constant corresponding to this distance.
3151         waga=forcon(i)
3152 C Calculate the contribution to energy.
3153         ehpb=ehpb+waga*rdis*rdis
3154 C
3155 C Evaluate gradient.
3156 C
3157         fac=waga*rdis/dd
3158         endif !dhpb(i).gt.0
3159         endif
3160 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3161 cd   &   ' waga=',waga,' fac=',fac
3162         do j=1,3
3163           ggg(j)=fac*(c(j,jj)-c(j,ii))
3164         enddo
3165 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3166 C If this is a SC-SC distance, we need to calculate the contributions to the
3167 C Cartesian gradient in the SC vectors (ghpbx).
3168         if (iii.lt.ii) then
3169           do j=1,3
3170             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3171             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3172           enddo
3173         endif
3174         else !ii.gt.nres
3175 C          write(iout,*) "before"
3176           dd=dist(ii,jj)
3177 C          write(iout,*) "after",dd
3178           if (constr_dist.eq.11) then
3179             ehpb=ehpb+fordepth(i)**4.0d0
3180      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3181             fac=fordepth(i)**4.0d0
3182      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3183 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3184 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3185 C            print *,ehpb,"tu?"
3186 C            write(iout,*) ehpb,"btu?",
3187 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3188 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3189 C     &    ehpb,fordepth(i),dd
3190            else
3191           if (dhpb1(i).gt.0.0d0) then
3192             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3193             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3194 c            write (iout,*) "alph nmr",
3195 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3196           else
3197             rdis=dd-dhpb(i)
3198 C Get the force constant corresponding to this distance.
3199             waga=forcon(i)
3200 C Calculate the contribution to energy.
3201             ehpb=ehpb+waga*rdis*rdis
3202 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3203 C
3204 C Evaluate gradient.
3205 C
3206             fac=waga*rdis/dd
3207           endif
3208           endif
3209         do j=1,3
3210           ggg(j)=fac*(c(j,jj)-c(j,ii))
3211         enddo
3212 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3213 C If this is a SC-SC distance, we need to calculate the contributions to the
3214 C Cartesian gradient in the SC vectors (ghpbx).
3215         if (iii.lt.ii) then
3216           do j=1,3
3217             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3218             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3219           enddo
3220         endif
3221         do j=iii,jjj-1
3222           do k=1,3
3223             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3224           enddo
3225         enddo
3226         endif
3227       enddo
3228       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3229       return
3230       end
3231 C--------------------------------------------------------------------------
3232       subroutine ssbond_ene(i,j,eij)
3233 C
3234 C Calculate the distance and angle dependent SS-bond potential energy
3235 C using a free-energy function derived based on RHF/6-31G** ab initio
3236 C calculations of diethyl disulfide.
3237 C
3238 C A. Liwo and U. Kozlowska, 11/24/03
3239 C
3240       implicit real*8 (a-h,o-z)
3241       include 'DIMENSIONS'
3242       include 'sizesclu.dat'
3243       include 'COMMON.SBRIDGE'
3244       include 'COMMON.CHAIN'
3245       include 'COMMON.DERIV'
3246       include 'COMMON.LOCAL'
3247       include 'COMMON.INTERACT'
3248       include 'COMMON.VAR'
3249       include 'COMMON.IOUNITS'
3250       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3251       itypi=iabs(itype(i))
3252       xi=c(1,nres+i)
3253       yi=c(2,nres+i)
3254       zi=c(3,nres+i)
3255       dxi=dc_norm(1,nres+i)
3256       dyi=dc_norm(2,nres+i)
3257       dzi=dc_norm(3,nres+i)
3258       dsci_inv=dsc_inv(itypi)
3259       itypj=iabs(itype(j))
3260       dscj_inv=dsc_inv(itypj)
3261       xj=c(1,nres+j)-xi
3262       yj=c(2,nres+j)-yi
3263       zj=c(3,nres+j)-zi
3264       dxj=dc_norm(1,nres+j)
3265       dyj=dc_norm(2,nres+j)
3266       dzj=dc_norm(3,nres+j)
3267       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3268       rij=dsqrt(rrij)
3269       erij(1)=xj*rij
3270       erij(2)=yj*rij
3271       erij(3)=zj*rij
3272       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3273       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3274       om12=dxi*dxj+dyi*dyj+dzi*dzj
3275       do k=1,3
3276         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3277         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3278       enddo
3279       rij=1.0d0/rij
3280       deltad=rij-d0cm
3281       deltat1=1.0d0-om1
3282       deltat2=1.0d0+om2
3283       deltat12=om2-om1+2.0d0
3284       cosphi=om12-om1*om2
3285       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3286      &  +akct*deltad*deltat12
3287      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3288 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3289 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3290 c     &  " deltat12",deltat12," eij",eij
3291       ed=2*akcm*deltad+akct*deltat12
3292       pom1=akct*deltad
3293       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3294       eom1=-2*akth*deltat1-pom1-om2*pom2
3295       eom2= 2*akth*deltat2+pom1-om1*pom2
3296       eom12=pom2
3297       do k=1,3
3298         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3299       enddo
3300       do k=1,3
3301         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3302      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3303         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3304      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3305       enddo
3306 C
3307 C Calculate the components of the gradient in DC and X
3308 C
3309       do k=i,j-1
3310         do l=1,3
3311           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3312         enddo
3313       enddo
3314       return
3315       end
3316 C--------------------------------------------------------------------------
3317       subroutine ebond(estr)
3318 c
3319 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3320 c
3321       implicit real*8 (a-h,o-z)
3322       include 'DIMENSIONS'
3323       include 'sizesclu.dat'
3324       include 'COMMON.LOCAL'
3325       include 'COMMON.GEO'
3326       include 'COMMON.INTERACT'
3327       include 'COMMON.DERIV'
3328       include 'COMMON.VAR'
3329       include 'COMMON.CHAIN'
3330       include 'COMMON.IOUNITS'
3331       include 'COMMON.NAMES'
3332       include 'COMMON.FFIELD'
3333       include 'COMMON.CONTROL'
3334       logical energy_dec /.false./
3335       double precision u(3),ud(3)
3336       estr=0.0d0
3337       estr1=0.0d0
3338       do i=nnt+1,nct
3339         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3340 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3341 C          do j=1,3
3342 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3343 C     &      *dc(j,i-1)/vbld(i)
3344 C          enddo
3345 C          if (energy_dec) write(iout,*)
3346 C     &       "estr1",i,vbld(i),distchainmax,
3347 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3348 C        else
3349          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3350         diff = vbld(i)-vbldpDUM
3351          else
3352           diff = vbld(i)-vbldp0
3353 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3354          endif
3355           estr=estr+diff*diff
3356           do j=1,3
3357             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3358           enddo
3359 C        endif
3360 C        write (iout,'(a7,i5,4f7.3)')
3361 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3362       enddo
3363       estr=0.5d0*AKP*estr+estr1
3364 c
3365 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3366 c
3367       do i=nnt,nct
3368         iti=iabs(itype(i))
3369         if (iti.ne.10 .and. iti.ne.ntyp1) then
3370           nbi=nbondterm(iti)
3371           if (nbi.eq.1) then
3372             diff=vbld(i+nres)-vbldsc0(1,iti)
3373 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3374 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3375             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3376             do j=1,3
3377               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3378             enddo
3379           else
3380             do j=1,nbi
3381               diff=vbld(i+nres)-vbldsc0(j,iti)
3382               ud(j)=aksc(j,iti)*diff
3383               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3384             enddo
3385             uprod=u(1)
3386             do j=2,nbi
3387               uprod=uprod*u(j)
3388             enddo
3389             usum=0.0d0
3390             usumsqder=0.0d0
3391             do j=1,nbi
3392               uprod1=1.0d0
3393               uprod2=1.0d0
3394               do k=1,nbi
3395                 if (k.ne.j) then
3396                   uprod1=uprod1*u(k)
3397                   uprod2=uprod2*u(k)*u(k)
3398                 endif
3399               enddo
3400               usum=usum+uprod1
3401               usumsqder=usumsqder+ud(j)*uprod2
3402             enddo
3403 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3404 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3405             estr=estr+uprod/usum
3406             do j=1,3
3407              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3408             enddo
3409           endif
3410         endif
3411       enddo
3412       return
3413       end
3414 #ifdef CRYST_THETA
3415 C--------------------------------------------------------------------------
3416       subroutine ebend(etheta,ethetacnstr)
3417 C
3418 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3419 C angles gamma and its derivatives in consecutive thetas and gammas.
3420 C
3421       implicit real*8 (a-h,o-z)
3422       include 'DIMENSIONS'
3423       include 'sizesclu.dat'
3424       include 'COMMON.LOCAL'
3425       include 'COMMON.GEO'
3426       include 'COMMON.INTERACT'
3427       include 'COMMON.DERIV'
3428       include 'COMMON.VAR'
3429       include 'COMMON.CHAIN'
3430       include 'COMMON.IOUNITS'
3431       include 'COMMON.NAMES'
3432       include 'COMMON.FFIELD'
3433       include 'COMMON.TORCNSTR'
3434       common /calcthet/ term1,term2,termm,diffak,ratak,
3435      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3436      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3437       double precision y(2),z(2)
3438       delta=0.02d0*pi
3439 c      time11=dexp(-2*time)
3440 c      time12=1.0d0
3441       etheta=0.0D0
3442 c      write (iout,*) "nres",nres
3443 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3444 c      write (iout,*) ithet_start,ithet_end
3445       do i=ithet_start,ithet_end
3446         if (i.le.2) cycle
3447         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3448      &  .or.itype(i).eq.ntyp1) cycle
3449 C Zero the energy function and its derivative at 0 or pi.
3450         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3451         it=itype(i-1)
3452         ichir1=isign(1,itype(i-2))
3453         ichir2=isign(1,itype(i))
3454          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3455          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3456          if (itype(i-1).eq.10) then
3457           itype1=isign(10,itype(i-2))
3458           ichir11=isign(1,itype(i-2))
3459           ichir12=isign(1,itype(i-2))
3460           itype2=isign(10,itype(i))
3461           ichir21=isign(1,itype(i))
3462           ichir22=isign(1,itype(i))
3463          endif
3464          if (i.eq.3) then
3465           y(1)=0.0D0
3466           y(2)=0.0D0
3467           else
3468         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3469 #ifdef OSF
3470           phii=phi(i)
3471 c          icrc=0
3472 c          call proc_proc(phii,icrc)
3473           if (icrc.eq.1) phii=150.0
3474 #else
3475           phii=phi(i)
3476 #endif
3477           y(1)=dcos(phii)
3478           y(2)=dsin(phii)
3479         else
3480           y(1)=0.0D0
3481           y(2)=0.0D0
3482         endif
3483         endif
3484         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3485 #ifdef OSF
3486           phii1=phi(i+1)
3487 c          icrc=0
3488 c          call proc_proc(phii1,icrc)
3489           if (icrc.eq.1) phii1=150.0
3490           phii1=pinorm(phii1)
3491           z(1)=cos(phii1)
3492 #else
3493           phii1=phi(i+1)
3494           z(1)=dcos(phii1)
3495 #endif
3496           z(2)=dsin(phii1)
3497         else
3498           z(1)=0.0D0
3499           z(2)=0.0D0
3500         endif
3501 C Calculate the "mean" value of theta from the part of the distribution
3502 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3503 C In following comments this theta will be referred to as t_c.
3504         thet_pred_mean=0.0d0
3505         do k=1,2
3506             athetk=athet(k,it,ichir1,ichir2)
3507             bthetk=bthet(k,it,ichir1,ichir2)
3508           if (it.eq.10) then
3509              athetk=athet(k,itype1,ichir11,ichir12)
3510              bthetk=bthet(k,itype2,ichir21,ichir22)
3511           endif
3512           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3513         enddo
3514 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3515         dthett=thet_pred_mean*ssd
3516         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3517 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3518 C Derivatives of the "mean" values in gamma1 and gamma2.
3519         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3520      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3521          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3522      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3523          if (it.eq.10) then
3524       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3525      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3526         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3527      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3528          endif
3529         if (theta(i).gt.pi-delta) then
3530           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3531      &         E_tc0)
3532           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3533           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3534           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3535      &        E_theta)
3536           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3537      &        E_tc)
3538         else if (theta(i).lt.delta) then
3539           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3540           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3541           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3542      &        E_theta)
3543           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3544           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3545      &        E_tc)
3546         else
3547           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3548      &        E_theta,E_tc)
3549         endif
3550         etheta=etheta+ethetai
3551 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3552 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3553         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3554         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3555         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3556 c 1215   continue
3557       enddo
3558 C Ufff.... We've done all this!!!
3559 C now constrains
3560       ethetacnstr=0.0d0
3561 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3562       do i=1,ntheta_constr
3563         itheta=itheta_constr(i)
3564         thetiii=theta(itheta)
3565         difi=pinorm(thetiii-theta_constr0(i))
3566         if (difi.gt.theta_drange(i)) then
3567           difi=difi-theta_drange(i)
3568           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3569           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3570      &    +for_thet_constr(i)*difi**3
3571         else if (difi.lt.-drange(i)) then
3572           difi=difi+drange(i)
3573           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3574           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3575      &    +for_thet_constr(i)*difi**3
3576         else
3577           difi=0.0
3578         endif
3579 C       if (energy_dec) then
3580 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3581 C     &    i,itheta,rad2deg*thetiii,
3582 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3583 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3584 C     &    gloc(itheta+nphi-2,icg)
3585 C        endif
3586       enddo
3587       return
3588       end
3589 C---------------------------------------------------------------------------
3590       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3591      &     E_tc)
3592       implicit real*8 (a-h,o-z)
3593       include 'DIMENSIONS'
3594       include 'COMMON.LOCAL'
3595       include 'COMMON.IOUNITS'
3596       common /calcthet/ term1,term2,termm,diffak,ratak,
3597      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3598      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3599 C Calculate the contributions to both Gaussian lobes.
3600 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3601 C The "polynomial part" of the "standard deviation" of this part of
3602 C the distribution.
3603         sig=polthet(3,it)
3604         do j=2,0,-1
3605           sig=sig*thet_pred_mean+polthet(j,it)
3606         enddo
3607 C Derivative of the "interior part" of the "standard deviation of the"
3608 C gamma-dependent Gaussian lobe in t_c.
3609         sigtc=3*polthet(3,it)
3610         do j=2,1,-1
3611           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3612         enddo
3613         sigtc=sig*sigtc
3614 C Set the parameters of both Gaussian lobes of the distribution.
3615 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3616         fac=sig*sig+sigc0(it)
3617         sigcsq=fac+fac
3618         sigc=1.0D0/sigcsq
3619 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3620         sigsqtc=-4.0D0*sigcsq*sigtc
3621 c       print *,i,sig,sigtc,sigsqtc
3622 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3623         sigtc=-sigtc/(fac*fac)
3624 C Following variable is sigma(t_c)**(-2)
3625         sigcsq=sigcsq*sigcsq
3626         sig0i=sig0(it)
3627         sig0inv=1.0D0/sig0i**2
3628         delthec=thetai-thet_pred_mean
3629         delthe0=thetai-theta0i
3630         term1=-0.5D0*sigcsq*delthec*delthec
3631         term2=-0.5D0*sig0inv*delthe0*delthe0
3632 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3633 C NaNs in taking the logarithm. We extract the largest exponent which is added
3634 C to the energy (this being the log of the distribution) at the end of energy
3635 C term evaluation for this virtual-bond angle.
3636         if (term1.gt.term2) then
3637           termm=term1
3638           term2=dexp(term2-termm)
3639           term1=1.0d0
3640         else
3641           termm=term2
3642           term1=dexp(term1-termm)
3643           term2=1.0d0
3644         endif
3645 C The ratio between the gamma-independent and gamma-dependent lobes of
3646 C the distribution is a Gaussian function of thet_pred_mean too.
3647         diffak=gthet(2,it)-thet_pred_mean
3648         ratak=diffak/gthet(3,it)**2
3649         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3650 C Let's differentiate it in thet_pred_mean NOW.
3651         aktc=ak*ratak
3652 C Now put together the distribution terms to make complete distribution.
3653         termexp=term1+ak*term2
3654         termpre=sigc+ak*sig0i
3655 C Contribution of the bending energy from this theta is just the -log of
3656 C the sum of the contributions from the two lobes and the pre-exponential
3657 C factor. Simple enough, isn't it?
3658         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3659 C NOW the derivatives!!!
3660 C 6/6/97 Take into account the deformation.
3661         E_theta=(delthec*sigcsq*term1
3662      &       +ak*delthe0*sig0inv*term2)/termexp
3663         E_tc=((sigtc+aktc*sig0i)/termpre
3664      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3665      &       aktc*term2)/termexp)
3666       return
3667       end
3668 c-----------------------------------------------------------------------------
3669       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3670       implicit real*8 (a-h,o-z)
3671       include 'DIMENSIONS'
3672       include 'COMMON.LOCAL'
3673       include 'COMMON.IOUNITS'
3674       common /calcthet/ term1,term2,termm,diffak,ratak,
3675      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3676      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3677       delthec=thetai-thet_pred_mean
3678       delthe0=thetai-theta0i
3679 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3680       t3 = thetai-thet_pred_mean
3681       t6 = t3**2
3682       t9 = term1
3683       t12 = t3*sigcsq
3684       t14 = t12+t6*sigsqtc
3685       t16 = 1.0d0
3686       t21 = thetai-theta0i
3687       t23 = t21**2
3688       t26 = term2
3689       t27 = t21*t26
3690       t32 = termexp
3691       t40 = t32**2
3692       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3693      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3694      & *(-t12*t9-ak*sig0inv*t27)
3695       return
3696       end
3697 #else
3698 C--------------------------------------------------------------------------
3699       subroutine ebend(etheta,ethetacnstr)
3700 C
3701 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3702 C angles gamma and its derivatives in consecutive thetas and gammas.
3703 C ab initio-derived potentials from
3704 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3705 C
3706       implicit real*8 (a-h,o-z)
3707       include 'DIMENSIONS'
3708       include 'sizesclu.dat'
3709       include 'COMMON.LOCAL'
3710       include 'COMMON.GEO'
3711       include 'COMMON.INTERACT'
3712       include 'COMMON.DERIV'
3713       include 'COMMON.VAR'
3714       include 'COMMON.CHAIN'
3715       include 'COMMON.IOUNITS'
3716       include 'COMMON.NAMES'
3717       include 'COMMON.FFIELD'
3718       include 'COMMON.CONTROL'
3719       include 'COMMON.TORCNSTR'
3720       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3721      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3722      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3723      & sinph1ph2(maxdouble,maxdouble)
3724       logical lprn /.false./, lprn1 /.false./
3725       etheta=0.0D0
3726 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3727       do i=ithet_start,ithet_end
3728         if (i.le.2) cycle
3729         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3730      &  .or.itype(i).eq.ntyp1) cycle
3731 c        if (itype(i-1).eq.ntyp1) cycle
3732         if (iabs(itype(i+1)).eq.20) iblock=2
3733         if (iabs(itype(i+1)).ne.20) iblock=1
3734         dethetai=0.0d0
3735         dephii=0.0d0
3736         dephii1=0.0d0
3737         theti2=0.5d0*theta(i)
3738         ityp2=ithetyp((itype(i-1)))
3739         do k=1,nntheterm
3740           coskt(k)=dcos(k*theti2)
3741           sinkt(k)=dsin(k*theti2)
3742         enddo
3743         if (i.eq.3) then
3744           phii=0.0d0
3745           ityp1=nthetyp+1
3746           do k=1,nsingle
3747             cosph1(k)=0.0d0
3748             sinph1(k)=0.0d0
3749           enddo
3750         else
3751         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3752 #ifdef OSF
3753           phii=phi(i)
3754           if (phii.ne.phii) phii=150.0
3755 #else
3756           phii=phi(i)
3757 #endif
3758           ityp1=ithetyp((itype(i-2)))
3759           do k=1,nsingle
3760             cosph1(k)=dcos(k*phii)
3761             sinph1(k)=dsin(k*phii)
3762           enddo
3763         else
3764           phii=0.0d0
3765 c          ityp1=nthetyp+1
3766           do k=1,nsingle
3767             ityp1=ithetyp((itype(i-2)))
3768             cosph1(k)=0.0d0
3769             sinph1(k)=0.0d0
3770           enddo
3771         endif
3772         endif
3773         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3774 #ifdef OSF
3775           phii1=phi(i+1)
3776           if (phii1.ne.phii1) phii1=150.0
3777           phii1=pinorm(phii1)
3778 #else
3779           phii1=phi(i+1)
3780 #endif
3781           ityp3=ithetyp((itype(i)))
3782           do k=1,nsingle
3783             cosph2(k)=dcos(k*phii1)
3784             sinph2(k)=dsin(k*phii1)
3785           enddo
3786         else
3787           phii1=0.0d0
3788 c          ityp3=nthetyp+1
3789           ityp3=ithetyp((itype(i)))
3790           do k=1,nsingle
3791             cosph2(k)=0.0d0
3792             sinph2(k)=0.0d0
3793           enddo
3794         endif
3795 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3796 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3797 c        call flush(iout)
3798         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
3799         do k=1,ndouble
3800           do l=1,k-1
3801             ccl=cosph1(l)*cosph2(k-l)
3802             ssl=sinph1(l)*sinph2(k-l)
3803             scl=sinph1(l)*cosph2(k-l)
3804             csl=cosph1(l)*sinph2(k-l)
3805             cosph1ph2(l,k)=ccl-ssl
3806             cosph1ph2(k,l)=ccl+ssl
3807             sinph1ph2(l,k)=scl+csl
3808             sinph1ph2(k,l)=scl-csl
3809           enddo
3810         enddo
3811         if (lprn) then
3812         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3813      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3814         write (iout,*) "coskt and sinkt"
3815         do k=1,nntheterm
3816           write (iout,*) k,coskt(k),sinkt(k)
3817         enddo
3818         endif
3819         do k=1,ntheterm
3820           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
3821           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
3822      &      *coskt(k)
3823           if (lprn)
3824      &    write (iout,*) "k",k," aathet",
3825      &    aathet(k,ityp1,ityp2,ityp3,iblock),
3826      &     " ethetai",ethetai
3827         enddo
3828         if (lprn) then
3829         write (iout,*) "cosph and sinph"
3830         do k=1,nsingle
3831           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3832         enddo
3833         write (iout,*) "cosph1ph2 and sinph2ph2"
3834         do k=2,ndouble
3835           do l=1,k-1
3836             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3837      &         sinph1ph2(l,k),sinph1ph2(k,l)
3838           enddo
3839         enddo
3840         write(iout,*) "ethetai",ethetai
3841         endif
3842         do m=1,ntheterm2
3843           do k=1,nsingle
3844             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
3845      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
3846      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
3847      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
3848             ethetai=ethetai+sinkt(m)*aux
3849             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3850             dephii=dephii+k*sinkt(m)*(
3851      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
3852      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
3853             dephii1=dephii1+k*sinkt(m)*(
3854      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
3855      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
3856             if (lprn)
3857      &      write (iout,*) "m",m," k",k," bbthet",
3858      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
3859      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
3860      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
3861      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
3862           enddo
3863         enddo
3864         if (lprn)
3865      &  write(iout,*) "ethetai",ethetai
3866         do m=1,ntheterm3
3867           do k=2,ndouble
3868             do l=1,k-1
3869               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3870      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
3871      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3872      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
3873               ethetai=ethetai+sinkt(m)*aux
3874               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3875               dephii=dephii+l*sinkt(m)*(
3876      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
3877      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3878      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3879      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3880               dephii1=dephii1+(k-l)*sinkt(m)*(
3881      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3882      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3883      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
3884      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3885               if (lprn) then
3886               write (iout,*) "m",m," k",k," l",l," ffthet",
3887      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3888      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
3889      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3890      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
3891      &            " ethetai",ethetai
3892               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3893      &            cosph1ph2(k,l)*sinkt(m),
3894      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3895               endif
3896             enddo
3897           enddo
3898         enddo
3899 10      continue
3900         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3901      &   i,theta(i)*rad2deg,phii*rad2deg,
3902      &   phii1*rad2deg,ethetai
3903         etheta=etheta+ethetai
3904         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3905         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3906 c        gloc(nphi+i-2,icg)=wang*dethetai
3907         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
3908       enddo
3909 C now constrains
3910       ethetacnstr=0.0d0
3911 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3912       do i=1,ntheta_constr
3913         itheta=itheta_constr(i)
3914         thetiii=theta(itheta)
3915         difi=pinorm(thetiii-theta_constr0(i))
3916         if (difi.gt.theta_drange(i)) then
3917           difi=difi-theta_drange(i)
3918           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3919           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3920      &    +for_thet_constr(i)*difi**3
3921         else if (difi.lt.-drange(i)) then
3922           difi=difi+drange(i)
3923           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3924           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3925      &    +for_thet_constr(i)*difi**3
3926         else
3927           difi=0.0
3928         endif
3929 C       if (energy_dec) then
3930 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3931 C     &    i,itheta,rad2deg*thetiii,
3932 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3933 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3934 C     &    gloc(itheta+nphi-2,icg)
3935 C        endif
3936       enddo
3937       return
3938       end
3939 #endif
3940 #ifdef CRYST_SC
3941 c-----------------------------------------------------------------------------
3942       subroutine esc(escloc)
3943 C Calculate the local energy of a side chain and its derivatives in the
3944 C corresponding virtual-bond valence angles THETA and the spherical angles
3945 C ALPHA and OMEGA.
3946       implicit real*8 (a-h,o-z)
3947       include 'DIMENSIONS'
3948       include 'sizesclu.dat'
3949       include 'COMMON.GEO'
3950       include 'COMMON.LOCAL'
3951       include 'COMMON.VAR'
3952       include 'COMMON.INTERACT'
3953       include 'COMMON.DERIV'
3954       include 'COMMON.CHAIN'
3955       include 'COMMON.IOUNITS'
3956       include 'COMMON.NAMES'
3957       include 'COMMON.FFIELD'
3958       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3959      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3960       common /sccalc/ time11,time12,time112,theti,it,nlobit
3961       delta=0.02d0*pi
3962       escloc=0.0D0
3963 c     write (iout,'(a)') 'ESC'
3964       do i=loc_start,loc_end
3965         it=itype(i)
3966         if (it.eq.ntyp1) cycle
3967         if (it.eq.10) goto 1
3968         nlobit=nlob(iabs(it))
3969 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3970 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3971         theti=theta(i+1)-pipol
3972         x(1)=dtan(theti)
3973         x(2)=alph(i)
3974         x(3)=omeg(i)
3975 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3976
3977         if (x(2).gt.pi-delta) then
3978           xtemp(1)=x(1)
3979           xtemp(2)=pi-delta
3980           xtemp(3)=x(3)
3981           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3982           xtemp(2)=pi
3983           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3984           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3985      &        escloci,dersc(2))
3986           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3987      &        ddersc0(1),dersc(1))
3988           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3989      &        ddersc0(3),dersc(3))
3990           xtemp(2)=pi-delta
3991           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3992           xtemp(2)=pi
3993           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3994           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3995      &            dersc0(2),esclocbi,dersc02)
3996           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3997      &            dersc12,dersc01)
3998           call splinthet(x(2),0.5d0*delta,ss,ssd)
3999           dersc0(1)=dersc01
4000           dersc0(2)=dersc02
4001           dersc0(3)=0.0d0
4002           do k=1,3
4003             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4004           enddo
4005           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4006 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4007 c    &             esclocbi,ss,ssd
4008           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4009 c         escloci=esclocbi
4010 c         write (iout,*) escloci
4011         else if (x(2).lt.delta) then
4012           xtemp(1)=x(1)
4013           xtemp(2)=delta
4014           xtemp(3)=x(3)
4015           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4016           xtemp(2)=0.0d0
4017           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4018           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4019      &        escloci,dersc(2))
4020           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4021      &        ddersc0(1),dersc(1))
4022           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4023      &        ddersc0(3),dersc(3))
4024           xtemp(2)=delta
4025           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4026           xtemp(2)=0.0d0
4027           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4028           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4029      &            dersc0(2),esclocbi,dersc02)
4030           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4031      &            dersc12,dersc01)
4032           dersc0(1)=dersc01
4033           dersc0(2)=dersc02
4034           dersc0(3)=0.0d0
4035           call splinthet(x(2),0.5d0*delta,ss,ssd)
4036           do k=1,3
4037             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4038           enddo
4039           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4040 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4041 c    &             esclocbi,ss,ssd
4042           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4043 c         write (iout,*) escloci
4044         else
4045           call enesc(x,escloci,dersc,ddummy,.false.)
4046         endif
4047
4048         escloc=escloc+escloci
4049 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4050
4051         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4052      &   wscloc*dersc(1)
4053         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4054         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4055     1   continue
4056       enddo
4057       return
4058       end
4059 C---------------------------------------------------------------------------
4060       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4061       implicit real*8 (a-h,o-z)
4062       include 'DIMENSIONS'
4063       include 'COMMON.GEO'
4064       include 'COMMON.LOCAL'
4065       include 'COMMON.IOUNITS'
4066       common /sccalc/ time11,time12,time112,theti,it,nlobit
4067       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4068       double precision contr(maxlob,-1:1)
4069       logical mixed
4070 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4071         escloc_i=0.0D0
4072         do j=1,3
4073           dersc(j)=0.0D0
4074           if (mixed) ddersc(j)=0.0d0
4075         enddo
4076         x3=x(3)
4077
4078 C Because of periodicity of the dependence of the SC energy in omega we have
4079 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4080 C To avoid underflows, first compute & store the exponents.
4081
4082         do iii=-1,1
4083
4084           x(3)=x3+iii*dwapi
4085
4086           do j=1,nlobit
4087             do k=1,3
4088               z(k)=x(k)-censc(k,j,it)
4089             enddo
4090             do k=1,3
4091               Axk=0.0D0
4092               do l=1,3
4093                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4094               enddo
4095               Ax(k,j,iii)=Axk
4096             enddo
4097             expfac=0.0D0
4098             do k=1,3
4099               expfac=expfac+Ax(k,j,iii)*z(k)
4100             enddo
4101             contr(j,iii)=expfac
4102           enddo ! j
4103
4104         enddo ! iii
4105
4106         x(3)=x3
4107 C As in the case of ebend, we want to avoid underflows in exponentiation and
4108 C subsequent NaNs and INFs in energy calculation.
4109 C Find the largest exponent
4110         emin=contr(1,-1)
4111         do iii=-1,1
4112           do j=1,nlobit
4113             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4114           enddo
4115         enddo
4116         emin=0.5D0*emin
4117 cd      print *,'it=',it,' emin=',emin
4118
4119 C Compute the contribution to SC energy and derivatives
4120         do iii=-1,1
4121
4122           do j=1,nlobit
4123             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4124 cd          print *,'j=',j,' expfac=',expfac
4125             escloc_i=escloc_i+expfac
4126             do k=1,3
4127               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4128             enddo
4129             if (mixed) then
4130               do k=1,3,2
4131                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4132      &            +gaussc(k,2,j,it))*expfac
4133               enddo
4134             endif
4135           enddo
4136
4137         enddo ! iii
4138
4139         dersc(1)=dersc(1)/cos(theti)**2
4140         ddersc(1)=ddersc(1)/cos(theti)**2
4141         ddersc(3)=ddersc(3)
4142
4143         escloci=-(dlog(escloc_i)-emin)
4144         do j=1,3
4145           dersc(j)=dersc(j)/escloc_i
4146         enddo
4147         if (mixed) then
4148           do j=1,3,2
4149             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4150           enddo
4151         endif
4152       return
4153       end
4154 C------------------------------------------------------------------------------
4155       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4156       implicit real*8 (a-h,o-z)
4157       include 'DIMENSIONS'
4158       include 'COMMON.GEO'
4159       include 'COMMON.LOCAL'
4160       include 'COMMON.IOUNITS'
4161       common /sccalc/ time11,time12,time112,theti,it,nlobit
4162       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4163       double precision contr(maxlob)
4164       logical mixed
4165
4166       escloc_i=0.0D0
4167
4168       do j=1,3
4169         dersc(j)=0.0D0
4170       enddo
4171
4172       do j=1,nlobit
4173         do k=1,2
4174           z(k)=x(k)-censc(k,j,it)
4175         enddo
4176         z(3)=dwapi
4177         do k=1,3
4178           Axk=0.0D0
4179           do l=1,3
4180             Axk=Axk+gaussc(l,k,j,it)*z(l)
4181           enddo
4182           Ax(k,j)=Axk
4183         enddo
4184         expfac=0.0D0
4185         do k=1,3
4186           expfac=expfac+Ax(k,j)*z(k)
4187         enddo
4188         contr(j)=expfac
4189       enddo ! j
4190
4191 C As in the case of ebend, we want to avoid underflows in exponentiation and
4192 C subsequent NaNs and INFs in energy calculation.
4193 C Find the largest exponent
4194       emin=contr(1)
4195       do j=1,nlobit
4196         if (emin.gt.contr(j)) emin=contr(j)
4197       enddo
4198       emin=0.5D0*emin
4199
4200 C Compute the contribution to SC energy and derivatives
4201
4202       dersc12=0.0d0
4203       do j=1,nlobit
4204         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4205         escloc_i=escloc_i+expfac
4206         do k=1,2
4207           dersc(k)=dersc(k)+Ax(k,j)*expfac
4208         enddo
4209         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4210      &            +gaussc(1,2,j,it))*expfac
4211         dersc(3)=0.0d0
4212       enddo
4213
4214       dersc(1)=dersc(1)/cos(theti)**2
4215       dersc12=dersc12/cos(theti)**2
4216       escloci=-(dlog(escloc_i)-emin)
4217       do j=1,2
4218         dersc(j)=dersc(j)/escloc_i
4219       enddo
4220       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4221       return
4222       end
4223 #else
4224 c----------------------------------------------------------------------------------
4225       subroutine esc(escloc)
4226 C Calculate the local energy of a side chain and its derivatives in the
4227 C corresponding virtual-bond valence angles THETA and the spherical angles
4228 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4229 C added by Urszula Kozlowska. 07/11/2007
4230 C
4231       implicit real*8 (a-h,o-z)
4232       include 'DIMENSIONS'
4233       include 'sizesclu.dat'
4234       include 'COMMON.GEO'
4235       include 'COMMON.LOCAL'
4236       include 'COMMON.VAR'
4237       include 'COMMON.SCROT'
4238       include 'COMMON.INTERACT'
4239       include 'COMMON.DERIV'
4240       include 'COMMON.CHAIN'
4241       include 'COMMON.IOUNITS'
4242       include 'COMMON.NAMES'
4243       include 'COMMON.FFIELD'
4244       include 'COMMON.CONTROL'
4245       include 'COMMON.VECTORS'
4246       double precision x_prime(3),y_prime(3),z_prime(3)
4247      &    , sumene,dsc_i,dp2_i,x(65),
4248      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4249      &    de_dxx,de_dyy,de_dzz,de_dt
4250       double precision s1_t,s1_6_t,s2_t,s2_6_t
4251       double precision
4252      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4253      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4254      & dt_dCi(3),dt_dCi1(3)
4255       common /sccalc/ time11,time12,time112,theti,it,nlobit
4256       delta=0.02d0*pi
4257       escloc=0.0D0
4258       do i=loc_start,loc_end
4259         if (itype(i).eq.ntyp1) cycle
4260         costtab(i+1) =dcos(theta(i+1))
4261         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4262         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4263         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4264         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4265         cosfac=dsqrt(cosfac2)
4266         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4267         sinfac=dsqrt(sinfac2)
4268         it=iabs(itype(i))
4269         if (it.eq.10) goto 1
4270 c
4271 C  Compute the axes of tghe local cartesian coordinates system; store in
4272 c   x_prime, y_prime and z_prime
4273 c
4274         do j=1,3
4275           x_prime(j) = 0.00
4276           y_prime(j) = 0.00
4277           z_prime(j) = 0.00
4278         enddo
4279 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4280 C     &   dc_norm(3,i+nres)
4281         do j = 1,3
4282           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4283           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4284         enddo
4285         do j = 1,3
4286           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4287         enddo
4288 c       write (2,*) "i",i
4289 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4290 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4291 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4292 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4293 c      & " xy",scalar(x_prime(1),y_prime(1)),
4294 c      & " xz",scalar(x_prime(1),z_prime(1)),
4295 c      & " yy",scalar(y_prime(1),y_prime(1)),
4296 c      & " yz",scalar(y_prime(1),z_prime(1)),
4297 c      & " zz",scalar(z_prime(1),z_prime(1))
4298 c
4299 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4300 C to local coordinate system. Store in xx, yy, zz.
4301 c
4302         xx=0.0d0
4303         yy=0.0d0
4304         zz=0.0d0
4305         do j = 1,3
4306           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4307           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4308           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4309         enddo
4310
4311         xxtab(i)=xx
4312         yytab(i)=yy
4313         zztab(i)=zz
4314 C
4315 C Compute the energy of the ith side cbain
4316 C
4317 c        write (2,*) "xx",xx," yy",yy," zz",zz
4318         it=iabs(itype(i))
4319         do j = 1,65
4320           x(j) = sc_parmin(j,it)
4321         enddo
4322 #ifdef CHECK_COORD
4323 Cc diagnostics - remove later
4324         xx1 = dcos(alph(2))
4325         yy1 = dsin(alph(2))*dcos(omeg(2))
4326 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4327         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4328         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4329      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4330      &    xx1,yy1,zz1
4331 C,"  --- ", xx_w,yy_w,zz_w
4332 c end diagnostics
4333 #endif
4334         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4335      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4336      &   + x(10)*yy*zz
4337         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4338      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4339      & + x(20)*yy*zz
4340         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4341      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4342      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4343      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4344      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4345      &  +x(40)*xx*yy*zz
4346         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4347      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4348      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4349      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4350      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4351      &  +x(60)*xx*yy*zz
4352         dsc_i   = 0.743d0+x(61)
4353         dp2_i   = 1.9d0+x(62)
4354         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4355      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4356         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4357      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4358         s1=(1+x(63))/(0.1d0 + dscp1)
4359         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4360         s2=(1+x(65))/(0.1d0 + dscp2)
4361         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4362         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4363      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4364 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4365 c     &   sumene4,
4366 c     &   dscp1,dscp2,sumene
4367 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4368         escloc = escloc + sumene
4369 c        write (2,*) "escloc",escloc
4370         if (.not. calc_grad) goto 1
4371 #ifdef DEBUG
4372 C
4373 C This section to check the numerical derivatives of the energy of ith side
4374 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4375 C #define DEBUG in the code to turn it on.
4376 C
4377         write (2,*) "sumene               =",sumene
4378         aincr=1.0d-7
4379         xxsave=xx
4380         xx=xx+aincr
4381         write (2,*) xx,yy,zz
4382         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4383         de_dxx_num=(sumenep-sumene)/aincr
4384         xx=xxsave
4385         write (2,*) "xx+ sumene from enesc=",sumenep
4386         yysave=yy
4387         yy=yy+aincr
4388         write (2,*) xx,yy,zz
4389         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4390         de_dyy_num=(sumenep-sumene)/aincr
4391         yy=yysave
4392         write (2,*) "yy+ sumene from enesc=",sumenep
4393         zzsave=zz
4394         zz=zz+aincr
4395         write (2,*) xx,yy,zz
4396         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4397         de_dzz_num=(sumenep-sumene)/aincr
4398         zz=zzsave
4399         write (2,*) "zz+ sumene from enesc=",sumenep
4400         costsave=cost2tab(i+1)
4401         sintsave=sint2tab(i+1)
4402         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4403         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4404         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4405         de_dt_num=(sumenep-sumene)/aincr
4406         write (2,*) " t+ sumene from enesc=",sumenep
4407         cost2tab(i+1)=costsave
4408         sint2tab(i+1)=sintsave
4409 C End of diagnostics section.
4410 #endif
4411 C
4412 C Compute the gradient of esc
4413 C
4414         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4415         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4416         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4417         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4418         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4419         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4420         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4421         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4422         pom1=(sumene3*sint2tab(i+1)+sumene1)
4423      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4424         pom2=(sumene4*cost2tab(i+1)+sumene2)
4425      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4426         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4427         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4428      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4429      &  +x(40)*yy*zz
4430         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4431         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4432      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4433      &  +x(60)*yy*zz
4434         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4435      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4436      &        +(pom1+pom2)*pom_dx
4437 #ifdef DEBUG
4438         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4439 #endif
4440 C
4441         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4442         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4443      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4444      &  +x(40)*xx*zz
4445         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4446         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4447      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4448      &  +x(59)*zz**2 +x(60)*xx*zz
4449         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4450      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4451      &        +(pom1-pom2)*pom_dy
4452 #ifdef DEBUG
4453         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4454 #endif
4455 C
4456         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4457      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4458      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4459      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4460      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4461      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4462      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4463      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4464 #ifdef DEBUG
4465         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4466 #endif
4467 C
4468         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4469      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4470      &  +pom1*pom_dt1+pom2*pom_dt2
4471 #ifdef DEBUG
4472         write(2,*), "de_dt = ", de_dt,de_dt_num
4473 #endif
4474 c
4475 C
4476        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4477        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4478        cosfac2xx=cosfac2*xx
4479        sinfac2yy=sinfac2*yy
4480        do k = 1,3
4481          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4482      &      vbld_inv(i+1)
4483          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4484      &      vbld_inv(i)
4485          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4486          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4487 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4488 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4489 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4490 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4491          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4492          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4493          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4494          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4495          dZZ_Ci1(k)=0.0d0
4496          dZZ_Ci(k)=0.0d0
4497          do j=1,3
4498            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4499      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4500            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4501      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4502          enddo
4503
4504          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4505          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4506          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4507 c
4508          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4509          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4510        enddo
4511
4512        do k=1,3
4513          dXX_Ctab(k,i)=dXX_Ci(k)
4514          dXX_C1tab(k,i)=dXX_Ci1(k)
4515          dYY_Ctab(k,i)=dYY_Ci(k)
4516          dYY_C1tab(k,i)=dYY_Ci1(k)
4517          dZZ_Ctab(k,i)=dZZ_Ci(k)
4518          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4519          dXX_XYZtab(k,i)=dXX_XYZ(k)
4520          dYY_XYZtab(k,i)=dYY_XYZ(k)
4521          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4522        enddo
4523
4524        do k = 1,3
4525 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4526 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4527 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4528 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4529 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4530 c     &    dt_dci(k)
4531 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4532 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4533          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4534      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4535          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4536      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4537          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4538      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4539        enddo
4540 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4541 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4542
4543 C to check gradient call subroutine check_grad
4544
4545     1 continue
4546       enddo
4547       return
4548       end
4549 #endif
4550 c------------------------------------------------------------------------------
4551       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4552 C
4553 C This procedure calculates two-body contact function g(rij) and its derivative:
4554 C
4555 C           eps0ij                                     !       x < -1
4556 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4557 C            0                                         !       x > 1
4558 C
4559 C where x=(rij-r0ij)/delta
4560 C
4561 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4562 C
4563       implicit none
4564       double precision rij,r0ij,eps0ij,fcont,fprimcont
4565       double precision x,x2,x4,delta
4566 c     delta=0.02D0*r0ij
4567 c      delta=0.2D0*r0ij
4568       x=(rij-r0ij)/delta
4569       if (x.lt.-1.0D0) then
4570         fcont=eps0ij
4571         fprimcont=0.0D0
4572       else if (x.le.1.0D0) then
4573         x2=x*x
4574         x4=x2*x2
4575         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4576         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4577       else
4578         fcont=0.0D0
4579         fprimcont=0.0D0
4580       endif
4581       return
4582       end
4583 c------------------------------------------------------------------------------
4584       subroutine splinthet(theti,delta,ss,ssder)
4585       implicit real*8 (a-h,o-z)
4586       include 'DIMENSIONS'
4587       include 'sizesclu.dat'
4588       include 'COMMON.VAR'
4589       include 'COMMON.GEO'
4590       thetup=pi-delta
4591       thetlow=delta
4592       if (theti.gt.pipol) then
4593         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4594       else
4595         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4596         ssder=-ssder
4597       endif
4598       return
4599       end
4600 c------------------------------------------------------------------------------
4601       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4602       implicit none
4603       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4604       double precision ksi,ksi2,ksi3,a1,a2,a3
4605       a1=fprim0*delta/(f1-f0)
4606       a2=3.0d0-2.0d0*a1
4607       a3=a1-2.0d0
4608       ksi=(x-x0)/delta
4609       ksi2=ksi*ksi
4610       ksi3=ksi2*ksi
4611       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4612       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4613       return
4614       end
4615 c------------------------------------------------------------------------------
4616       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4617       implicit none
4618       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4619       double precision ksi,ksi2,ksi3,a1,a2,a3
4620       ksi=(x-x0)/delta
4621       ksi2=ksi*ksi
4622       ksi3=ksi2*ksi
4623       a1=fprim0x*delta
4624       a2=3*(f1x-f0x)-2*fprim0x*delta
4625       a3=fprim0x*delta-2*(f1x-f0x)
4626       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4627       return
4628       end
4629 C-----------------------------------------------------------------------------
4630 #ifdef CRYST_TOR
4631 C-----------------------------------------------------------------------------
4632       subroutine etor(etors,edihcnstr,fact)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'sizesclu.dat'
4636       include 'COMMON.VAR'
4637       include 'COMMON.GEO'
4638       include 'COMMON.LOCAL'
4639       include 'COMMON.TORSION'
4640       include 'COMMON.INTERACT'
4641       include 'COMMON.DERIV'
4642       include 'COMMON.CHAIN'
4643       include 'COMMON.NAMES'
4644       include 'COMMON.IOUNITS'
4645       include 'COMMON.FFIELD'
4646       include 'COMMON.TORCNSTR'
4647       logical lprn
4648 C Set lprn=.true. for debugging
4649       lprn=.false.
4650 c      lprn=.true.
4651       etors=0.0D0
4652       do i=iphi_start,iphi_end
4653         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4654      &      .or. itype(i).eq.ntyp1) cycle
4655         itori=itortyp(itype(i-2))
4656         itori1=itortyp(itype(i-1))
4657         phii=phi(i)
4658         gloci=0.0D0
4659 C Proline-Proline pair is a special case...
4660         if (itori.eq.3 .and. itori1.eq.3) then
4661           if (phii.gt.-dwapi3) then
4662             cosphi=dcos(3*phii)
4663             fac=1.0D0/(1.0D0-cosphi)
4664             etorsi=v1(1,3,3)*fac
4665             etorsi=etorsi+etorsi
4666             etors=etors+etorsi-v1(1,3,3)
4667             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4668           endif
4669           do j=1,3
4670             v1ij=v1(j+1,itori,itori1)
4671             v2ij=v2(j+1,itori,itori1)
4672             cosphi=dcos(j*phii)
4673             sinphi=dsin(j*phii)
4674             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4675             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4676           enddo
4677         else
4678           do j=1,nterm_old
4679             v1ij=v1(j,itori,itori1)
4680             v2ij=v2(j,itori,itori1)
4681             cosphi=dcos(j*phii)
4682             sinphi=dsin(j*phii)
4683             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4684             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4685           enddo
4686         endif
4687         if (lprn)
4688      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4689      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4690      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4691         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4692 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4693       enddo
4694 ! 6/20/98 - dihedral angle constraints
4695       edihcnstr=0.0d0
4696       do i=1,ndih_constr
4697         itori=idih_constr(i)
4698         phii=phi(itori)
4699         difi=phii-phi0(i)
4700         if (difi.gt.drange(i)) then
4701           difi=difi-drange(i)
4702           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4703           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4704         else if (difi.lt.-drange(i)) then
4705           difi=difi+drange(i)
4706           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4707           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4708         endif
4709 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4710 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4711       enddo
4712 !      write (iout,*) 'edihcnstr',edihcnstr
4713       return
4714       end
4715 c------------------------------------------------------------------------------
4716 #else
4717       subroutine etor(etors,edihcnstr,fact)
4718       implicit real*8 (a-h,o-z)
4719       include 'DIMENSIONS'
4720       include 'sizesclu.dat'
4721       include 'COMMON.VAR'
4722       include 'COMMON.GEO'
4723       include 'COMMON.LOCAL'
4724       include 'COMMON.TORSION'
4725       include 'COMMON.INTERACT'
4726       include 'COMMON.DERIV'
4727       include 'COMMON.CHAIN'
4728       include 'COMMON.NAMES'
4729       include 'COMMON.IOUNITS'
4730       include 'COMMON.FFIELD'
4731       include 'COMMON.TORCNSTR'
4732       logical lprn
4733 C Set lprn=.true. for debugging
4734       lprn=.false.
4735 c      lprn=.true.
4736       etors=0.0D0
4737       do i=iphi_start,iphi_end
4738         if (i.le.2) cycle
4739         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4740      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
4741         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4742          if (iabs(itype(i)).eq.20) then
4743          iblock=2
4744          else
4745          iblock=1
4746          endif
4747         itori=itortyp(itype(i-2))
4748         itori1=itortyp(itype(i-1))
4749         phii=phi(i)
4750         gloci=0.0D0
4751 C Regular cosine and sine terms
4752         do j=1,nterm(itori,itori1,iblock)
4753           v1ij=v1(j,itori,itori1,iblock)
4754           v2ij=v2(j,itori,itori1,iblock)
4755           cosphi=dcos(j*phii)
4756           sinphi=dsin(j*phii)
4757           etors=etors+v1ij*cosphi+v2ij*sinphi
4758           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4759         enddo
4760 C Lorentz terms
4761 C                         v1
4762 C  E = SUM ----------------------------------- - v1
4763 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4764 C
4765         cosphi=dcos(0.5d0*phii)
4766         sinphi=dsin(0.5d0*phii)
4767         do j=1,nlor(itori,itori1,iblock)
4768           vl1ij=vlor1(j,itori,itori1)
4769           vl2ij=vlor2(j,itori,itori1)
4770           vl3ij=vlor3(j,itori,itori1)
4771           pom=vl2ij*cosphi+vl3ij*sinphi
4772           pom1=1.0d0/(pom*pom+1.0d0)
4773           etors=etors+vl1ij*pom1
4774           pom=-pom*pom1*pom1
4775           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4776         enddo
4777 C Subtract the constant term
4778         etors=etors-v0(itori,itori1,iblock)
4779         if (lprn)
4780      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4781      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4782      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4783         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4784 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4785  1215   continue
4786       enddo
4787 ! 6/20/98 - dihedral angle constraints
4788       edihcnstr=0.0d0
4789       do i=1,ndih_constr
4790         itori=idih_constr(i)
4791         phii=phi(itori)
4792         difi=pinorm(phii-phi0(i))
4793         edihi=0.0d0
4794         if (difi.gt.drange(i)) then
4795           difi=difi-drange(i)
4796           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4797           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4798           edihi=0.25d0*ftors(i)*difi**4
4799         else if (difi.lt.-drange(i)) then
4800           difi=difi+drange(i)
4801           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4802           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4803           edihi=0.25d0*ftors(i)*difi**4
4804         else
4805           difi=0.0d0
4806         endif
4807 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4808 c     &    drange(i),edihi
4809 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4810 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4811       enddo
4812 !      write (iout,*) 'edihcnstr',edihcnstr
4813       return
4814       end
4815 c----------------------------------------------------------------------------
4816       subroutine etor_d(etors_d,fact2)
4817 C 6/23/01 Compute double torsional energy
4818       implicit real*8 (a-h,o-z)
4819       include 'DIMENSIONS'
4820       include 'sizesclu.dat'
4821       include 'COMMON.VAR'
4822       include 'COMMON.GEO'
4823       include 'COMMON.LOCAL'
4824       include 'COMMON.TORSION'
4825       include 'COMMON.INTERACT'
4826       include 'COMMON.DERIV'
4827       include 'COMMON.CHAIN'
4828       include 'COMMON.NAMES'
4829       include 'COMMON.IOUNITS'
4830       include 'COMMON.FFIELD'
4831       include 'COMMON.TORCNSTR'
4832       logical lprn
4833 C Set lprn=.true. for debugging
4834       lprn=.false.
4835 c     lprn=.true.
4836       etors_d=0.0D0
4837       do i=iphi_start,iphi_end-1
4838         if (i.le.3) cycle
4839          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
4840      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
4841      &  (itype(i+1).eq.ntyp1)) cycle
4842         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4843      &     goto 1215
4844         itori=itortyp(itype(i-2))
4845         itori1=itortyp(itype(i-1))
4846         itori2=itortyp(itype(i))
4847         phii=phi(i)
4848         phii1=phi(i+1)
4849         gloci1=0.0D0
4850         gloci2=0.0D0
4851         iblock=1
4852         if (iabs(itype(i+1)).eq.20) iblock=2
4853 C Regular cosine and sine terms
4854        do j=1,ntermd_1(itori,itori1,itori2,iblock)
4855           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4856           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4857           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4858           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4859           cosphi1=dcos(j*phii)
4860           sinphi1=dsin(j*phii)
4861           cosphi2=dcos(j*phii1)
4862           sinphi2=dsin(j*phii1)
4863           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4864      &     v2cij*cosphi2+v2sij*sinphi2
4865           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4866           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4867         enddo
4868         do k=2,ntermd_2(itori,itori1,itori2,iblock)
4869           do l=1,k-1
4870             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
4871             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
4872             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
4873             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
4874             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4875             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4876             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4877             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4878             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4879      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4880             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4881      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4882             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4883      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4884           enddo
4885         enddo
4886         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4887         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4888  1215   continue
4889       enddo
4890       return
4891       end
4892 #endif
4893 c------------------------------------------------------------------------------
4894       subroutine eback_sc_corr(esccor)
4895 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4896 c        conformational states; temporarily implemented as differences
4897 c        between UNRES torsional potentials (dependent on three types of
4898 c        residues) and the torsional potentials dependent on all 20 types
4899 c        of residues computed from AM1 energy surfaces of terminally-blocked
4900 c        amino-acid residues.
4901       implicit real*8 (a-h,o-z)
4902       include 'DIMENSIONS'
4903       include 'sizesclu.dat'
4904       include 'COMMON.VAR'
4905       include 'COMMON.GEO'
4906       include 'COMMON.LOCAL'
4907       include 'COMMON.TORSION'
4908       include 'COMMON.SCCOR'
4909       include 'COMMON.INTERACT'
4910       include 'COMMON.DERIV'
4911       include 'COMMON.CHAIN'
4912       include 'COMMON.NAMES'
4913       include 'COMMON.IOUNITS'
4914       include 'COMMON.FFIELD'
4915       include 'COMMON.CONTROL'
4916       logical lprn
4917 C Set lprn=.true. for debugging
4918       lprn=.false.
4919 c      lprn=.true.
4920 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4921       esccor=0.0D0
4922       do i=itau_start,itau_end
4923         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
4924         esccor_ii=0.0D0
4925         isccori=isccortyp(itype(i-2))
4926         isccori1=isccortyp(itype(i-1))
4927         phii=phi(i)
4928         do intertyp=1,3 !intertyp
4929 cc Added 09 May 2012 (Adasko)
4930 cc  Intertyp means interaction type of backbone mainchain correlation:
4931 c   1 = SC...Ca...Ca...Ca
4932 c   2 = Ca...Ca...Ca...SC
4933 c   3 = SC...Ca...Ca...SCi
4934         gloci=0.0D0
4935         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4936      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4937      &      (itype(i-1).eq.ntyp1)))
4938      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4939      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4940      &     .or.(itype(i).eq.ntyp1)))
4941      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4942      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4943      &      (itype(i-3).eq.ntyp1)))) cycle
4944         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
4945         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
4946      & cycle
4947        do j=1,nterm_sccor(isccori,isccori1)
4948           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4949           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4950           cosphi=dcos(j*tauangle(intertyp,i))
4951           sinphi=dsin(j*tauangle(intertyp,i))
4952            esccor=esccor+v1ij*cosphi+v2ij*sinphi
4953 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4954          enddo
4955 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
4956 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
4957         if (lprn)
4958      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4959      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4960      &  (v1sccor(j,1,itori,itori1),j=1,6),
4961      &  (v2sccor(j,1,itori,itori1),j=1,6)
4962         gsccor_loc(i-3)=gloci
4963        enddo !intertyp
4964       enddo
4965       return
4966       end
4967 c------------------------------------------------------------------------------
4968       subroutine multibody(ecorr)
4969 C This subroutine calculates multi-body contributions to energy following
4970 C the idea of Skolnick et al. If side chains I and J make a contact and
4971 C at the same time side chains I+1 and J+1 make a contact, an extra
4972 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4973       implicit real*8 (a-h,o-z)
4974       include 'DIMENSIONS'
4975       include 'COMMON.IOUNITS'
4976       include 'COMMON.DERIV'
4977       include 'COMMON.INTERACT'
4978       include 'COMMON.CONTACTS'
4979       double precision gx(3),gx1(3)
4980       logical lprn
4981
4982 C Set lprn=.true. for debugging
4983       lprn=.false.
4984
4985       if (lprn) then
4986         write (iout,'(a)') 'Contact function values:'
4987         do i=nnt,nct-2
4988           write (iout,'(i2,20(1x,i2,f10.5))')
4989      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4990         enddo
4991       endif
4992       ecorr=0.0D0
4993       do i=nnt,nct
4994         do j=1,3
4995           gradcorr(j,i)=0.0D0
4996           gradxorr(j,i)=0.0D0
4997         enddo
4998       enddo
4999       do i=nnt,nct-2
5000
5001         DO ISHIFT = 3,4
5002
5003         i1=i+ishift
5004         num_conti=num_cont(i)
5005         num_conti1=num_cont(i1)
5006         do jj=1,num_conti
5007           j=jcont(jj,i)
5008           do kk=1,num_conti1
5009             j1=jcont(kk,i1)
5010             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5011 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5012 cd   &                   ' ishift=',ishift
5013 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5014 C The system gains extra energy.
5015               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5016             endif   ! j1==j+-ishift
5017           enddo     ! kk
5018         enddo       ! jj
5019
5020         ENDDO ! ISHIFT
5021
5022       enddo         ! i
5023       return
5024       end
5025 c------------------------------------------------------------------------------
5026       double precision function esccorr(i,j,k,l,jj,kk)
5027       implicit real*8 (a-h,o-z)
5028       include 'DIMENSIONS'
5029       include 'COMMON.IOUNITS'
5030       include 'COMMON.DERIV'
5031       include 'COMMON.INTERACT'
5032       include 'COMMON.CONTACTS'
5033       double precision gx(3),gx1(3)
5034       logical lprn
5035       lprn=.false.
5036       eij=facont(jj,i)
5037       ekl=facont(kk,k)
5038 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5039 C Calculate the multi-body contribution to energy.
5040 C Calculate multi-body contributions to the gradient.
5041 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5042 cd   & k,l,(gacont(m,kk,k),m=1,3)
5043       do m=1,3
5044         gx(m) =ekl*gacont(m,jj,i)
5045         gx1(m)=eij*gacont(m,kk,k)
5046         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5047         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5048         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5049         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5050       enddo
5051       do m=i,j-1
5052         do ll=1,3
5053           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5054         enddo
5055       enddo
5056       do m=k,l-1
5057         do ll=1,3
5058           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5059         enddo
5060       enddo
5061       esccorr=-eij*ekl
5062       return
5063       end
5064 c------------------------------------------------------------------------------
5065 #ifdef MPL
5066       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5067       implicit real*8 (a-h,o-z)
5068       include 'DIMENSIONS'
5069       integer dimen1,dimen2,atom,indx
5070       double precision buffer(dimen1,dimen2)
5071       double precision zapas
5072       common /contacts_hb/ zapas(3,20,maxres,7),
5073      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5074      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5075       num_kont=num_cont_hb(atom)
5076       do i=1,num_kont
5077         do k=1,7
5078           do j=1,3
5079             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5080           enddo ! j
5081         enddo ! k
5082         buffer(i,indx+22)=facont_hb(i,atom)
5083         buffer(i,indx+23)=ees0p(i,atom)
5084         buffer(i,indx+24)=ees0m(i,atom)
5085         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5086       enddo ! i
5087       buffer(1,indx+26)=dfloat(num_kont)
5088       return
5089       end
5090 c------------------------------------------------------------------------------
5091       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5092       implicit real*8 (a-h,o-z)
5093       include 'DIMENSIONS'
5094       integer dimen1,dimen2,atom,indx
5095       double precision buffer(dimen1,dimen2)
5096       double precision zapas
5097       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5098      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5099      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5100       num_kont=buffer(1,indx+26)
5101       num_kont_old=num_cont_hb(atom)
5102       num_cont_hb(atom)=num_kont+num_kont_old
5103       do i=1,num_kont
5104         ii=i+num_kont_old
5105         do k=1,7
5106           do j=1,3
5107             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5108           enddo ! j
5109         enddo ! k
5110         facont_hb(ii,atom)=buffer(i,indx+22)
5111         ees0p(ii,atom)=buffer(i,indx+23)
5112         ees0m(ii,atom)=buffer(i,indx+24)
5113         jcont_hb(ii,atom)=buffer(i,indx+25)
5114       enddo ! i
5115       return
5116       end
5117 c------------------------------------------------------------------------------
5118 #endif
5119       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5120 C This subroutine calculates multi-body contributions to hydrogen-bonding
5121       implicit real*8 (a-h,o-z)
5122       include 'DIMENSIONS'
5123       include 'sizesclu.dat'
5124       include 'COMMON.IOUNITS'
5125 #ifdef MPL
5126       include 'COMMON.INFO'
5127 #endif
5128       include 'COMMON.FFIELD'
5129       include 'COMMON.DERIV'
5130       include 'COMMON.INTERACT'
5131       include 'COMMON.CONTACTS'
5132 #ifdef MPL
5133       parameter (max_cont=maxconts)
5134       parameter (max_dim=2*(8*3+2))
5135       parameter (msglen1=max_cont*max_dim*4)
5136       parameter (msglen2=2*msglen1)
5137       integer source,CorrelType,CorrelID,Error
5138       double precision buffer(max_cont,max_dim)
5139 #endif
5140       double precision gx(3),gx1(3)
5141       logical lprn,ldone
5142
5143 C Set lprn=.true. for debugging
5144       lprn=.false.
5145 #ifdef MPL
5146       n_corr=0
5147       n_corr1=0
5148       if (fgProcs.le.1) goto 30
5149       if (lprn) then
5150         write (iout,'(a)') 'Contact function values:'
5151         do i=nnt,nct-2
5152           write (iout,'(2i3,50(1x,i2,f5.2))')
5153      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5154      &    j=1,num_cont_hb(i))
5155         enddo
5156       endif
5157 C Caution! Following code assumes that electrostatic interactions concerning
5158 C a given atom are split among at most two processors!
5159       CorrelType=477
5160       CorrelID=MyID+1
5161       ldone=.false.
5162       do i=1,max_cont
5163         do j=1,max_dim
5164           buffer(i,j)=0.0D0
5165         enddo
5166       enddo
5167       mm=mod(MyRank,2)
5168 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5169       if (mm) 20,20,10
5170    10 continue
5171 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5172       if (MyRank.gt.0) then
5173 C Send correlation contributions to the preceding processor
5174         msglen=msglen1
5175         nn=num_cont_hb(iatel_s)
5176         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5177 cd      write (iout,*) 'The BUFFER array:'
5178 cd      do i=1,nn
5179 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5180 cd      enddo
5181         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5182           msglen=msglen2
5183             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5184 C Clear the contacts of the atom passed to the neighboring processor
5185         nn=num_cont_hb(iatel_s+1)
5186 cd      do i=1,nn
5187 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5188 cd      enddo
5189             num_cont_hb(iatel_s)=0
5190         endif
5191 cd      write (iout,*) 'Processor ',MyID,MyRank,
5192 cd   & ' is sending correlation contribution to processor',MyID-1,
5193 cd   & ' msglen=',msglen
5194 cd      write (*,*) 'Processor ',MyID,MyRank,
5195 cd   & ' is sending correlation contribution to processor',MyID-1,
5196 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5197         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5198 cd      write (iout,*) 'Processor ',MyID,
5199 cd   & ' has sent correlation contribution to processor',MyID-1,
5200 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5201 cd      write (*,*) 'Processor ',MyID,
5202 cd   & ' has sent correlation contribution to processor',MyID-1,
5203 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5204         msglen=msglen1
5205       endif ! (MyRank.gt.0)
5206       if (ldone) goto 30
5207       ldone=.true.
5208    20 continue
5209 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5210       if (MyRank.lt.fgProcs-1) then
5211 C Receive correlation contributions from the next processor
5212         msglen=msglen1
5213         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5214 cd      write (iout,*) 'Processor',MyID,
5215 cd   & ' is receiving correlation contribution from processor',MyID+1,
5216 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5217 cd      write (*,*) 'Processor',MyID,
5218 cd   & ' is receiving correlation contribution from processor',MyID+1,
5219 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5220         nbytes=-1
5221         do while (nbytes.le.0)
5222           call mp_probe(MyID+1,CorrelType,nbytes)
5223         enddo
5224 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5225         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5226 cd      write (iout,*) 'Processor',MyID,
5227 cd   & ' has received correlation contribution from processor',MyID+1,
5228 cd   & ' msglen=',msglen,' nbytes=',nbytes
5229 cd      write (iout,*) 'The received BUFFER array:'
5230 cd      do i=1,max_cont
5231 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5232 cd      enddo
5233         if (msglen.eq.msglen1) then
5234           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5235         else if (msglen.eq.msglen2)  then
5236           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5237           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5238         else
5239           write (iout,*)
5240      & 'ERROR!!!! message length changed while processing correlations.'
5241           write (*,*)
5242      & 'ERROR!!!! message length changed while processing correlations.'
5243           call mp_stopall(Error)
5244         endif ! msglen.eq.msglen1
5245       endif ! MyRank.lt.fgProcs-1
5246       if (ldone) goto 30
5247       ldone=.true.
5248       goto 10
5249    30 continue
5250 #endif
5251       if (lprn) then
5252         write (iout,'(a)') 'Contact function values:'
5253         do i=nnt,nct-2
5254           write (iout,'(2i3,50(1x,i2,f5.2))')
5255      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5256      &    j=1,num_cont_hb(i))
5257         enddo
5258       endif
5259       ecorr=0.0D0
5260 C Remove the loop below after debugging !!!
5261       do i=nnt,nct
5262         do j=1,3
5263           gradcorr(j,i)=0.0D0
5264           gradxorr(j,i)=0.0D0
5265         enddo
5266       enddo
5267 C Calculate the local-electrostatic correlation terms
5268       do i=iatel_s,iatel_e+1
5269         i1=i+1
5270         num_conti=num_cont_hb(i)
5271         num_conti1=num_cont_hb(i+1)
5272         do jj=1,num_conti
5273           j=jcont_hb(jj,i)
5274           do kk=1,num_conti1
5275             j1=jcont_hb(kk,i1)
5276 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5277 c     &         ' jj=',jj,' kk=',kk
5278             if (j1.eq.j+1 .or. j1.eq.j-1) then
5279 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5280 C The system gains extra energy.
5281               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5282               n_corr=n_corr+1
5283             else if (j1.eq.j) then
5284 C Contacts I-J and I-(J+1) occur simultaneously.
5285 C The system loses extra energy.
5286 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5287             endif
5288           enddo ! kk
5289           do kk=1,num_conti
5290             j1=jcont_hb(kk,i)
5291 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5292 c    &         ' jj=',jj,' kk=',kk
5293             if (j1.eq.j+1) then
5294 C Contacts I-J and (I+1)-J occur simultaneously.
5295 C The system loses extra energy.
5296 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5297             endif ! j1==j+1
5298           enddo ! kk
5299         enddo ! jj
5300       enddo ! i
5301       return
5302       end
5303 c------------------------------------------------------------------------------
5304       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5305      &  n_corr1)
5306 C This subroutine calculates multi-body contributions to hydrogen-bonding
5307       implicit real*8 (a-h,o-z)
5308       include 'DIMENSIONS'
5309       include 'sizesclu.dat'
5310       include 'COMMON.IOUNITS'
5311 #ifdef MPL
5312       include 'COMMON.INFO'
5313 #endif
5314       include 'COMMON.FFIELD'
5315       include 'COMMON.DERIV'
5316       include 'COMMON.INTERACT'
5317       include 'COMMON.CONTACTS'
5318 #ifdef MPL
5319       parameter (max_cont=maxconts)
5320       parameter (max_dim=2*(8*3+2))
5321       parameter (msglen1=max_cont*max_dim*4)
5322       parameter (msglen2=2*msglen1)
5323       integer source,CorrelType,CorrelID,Error
5324       double precision buffer(max_cont,max_dim)
5325 #endif
5326       double precision gx(3),gx1(3)
5327       logical lprn,ldone
5328
5329 C Set lprn=.true. for debugging
5330       lprn=.false.
5331       eturn6=0.0d0
5332 #ifdef MPL
5333       n_corr=0
5334       n_corr1=0
5335       if (fgProcs.le.1) goto 30
5336       if (lprn) then
5337         write (iout,'(a)') 'Contact function values:'
5338         do i=nnt,nct-2
5339           write (iout,'(2i3,50(1x,i2,f5.2))')
5340      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5341      &    j=1,num_cont_hb(i))
5342         enddo
5343       endif
5344 C Caution! Following code assumes that electrostatic interactions concerning
5345 C a given atom are split among at most two processors!
5346       CorrelType=477
5347       CorrelID=MyID+1
5348       ldone=.false.
5349       do i=1,max_cont
5350         do j=1,max_dim
5351           buffer(i,j)=0.0D0
5352         enddo
5353       enddo
5354       mm=mod(MyRank,2)
5355 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5356       if (mm) 20,20,10
5357    10 continue
5358 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5359       if (MyRank.gt.0) then
5360 C Send correlation contributions to the preceding processor
5361         msglen=msglen1
5362         nn=num_cont_hb(iatel_s)
5363         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5364 cd      write (iout,*) 'The BUFFER array:'
5365 cd      do i=1,nn
5366 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5367 cd      enddo
5368         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5369           msglen=msglen2
5370             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5371 C Clear the contacts of the atom passed to the neighboring processor
5372         nn=num_cont_hb(iatel_s+1)
5373 cd      do i=1,nn
5374 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5375 cd      enddo
5376             num_cont_hb(iatel_s)=0
5377         endif
5378 cd      write (iout,*) 'Processor ',MyID,MyRank,
5379 cd   & ' is sending correlation contribution to processor',MyID-1,
5380 cd   & ' msglen=',msglen
5381 cd      write (*,*) 'Processor ',MyID,MyRank,
5382 cd   & ' is sending correlation contribution to processor',MyID-1,
5383 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5384         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5385 cd      write (iout,*) 'Processor ',MyID,
5386 cd   & ' has sent correlation contribution to processor',MyID-1,
5387 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5388 cd      write (*,*) 'Processor ',MyID,
5389 cd   & ' has sent correlation contribution to processor',MyID-1,
5390 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5391         msglen=msglen1
5392       endif ! (MyRank.gt.0)
5393       if (ldone) goto 30
5394       ldone=.true.
5395    20 continue
5396 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5397       if (MyRank.lt.fgProcs-1) then
5398 C Receive correlation contributions from the next processor
5399         msglen=msglen1
5400         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5401 cd      write (iout,*) 'Processor',MyID,
5402 cd   & ' is receiving correlation contribution from processor',MyID+1,
5403 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5404 cd      write (*,*) 'Processor',MyID,
5405 cd   & ' is receiving correlation contribution from processor',MyID+1,
5406 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5407         nbytes=-1
5408         do while (nbytes.le.0)
5409           call mp_probe(MyID+1,CorrelType,nbytes)
5410         enddo
5411 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5412         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5413 cd      write (iout,*) 'Processor',MyID,
5414 cd   & ' has received correlation contribution from processor',MyID+1,
5415 cd   & ' msglen=',msglen,' nbytes=',nbytes
5416 cd      write (iout,*) 'The received BUFFER array:'
5417 cd      do i=1,max_cont
5418 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5419 cd      enddo
5420         if (msglen.eq.msglen1) then
5421           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5422         else if (msglen.eq.msglen2)  then
5423           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5424           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5425         else
5426           write (iout,*)
5427      & 'ERROR!!!! message length changed while processing correlations.'
5428           write (*,*)
5429      & 'ERROR!!!! message length changed while processing correlations.'
5430           call mp_stopall(Error)
5431         endif ! msglen.eq.msglen1
5432       endif ! MyRank.lt.fgProcs-1
5433       if (ldone) goto 30
5434       ldone=.true.
5435       goto 10
5436    30 continue
5437 #endif
5438       if (lprn) then
5439         write (iout,'(a)') 'Contact function values:'
5440         do i=nnt,nct-2
5441           write (iout,'(2i3,50(1x,i2,f5.2))')
5442      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5443      &    j=1,num_cont_hb(i))
5444         enddo
5445       endif
5446       ecorr=0.0D0
5447       ecorr5=0.0d0
5448       ecorr6=0.0d0
5449 C Remove the loop below after debugging !!!
5450       do i=nnt,nct
5451         do j=1,3
5452           gradcorr(j,i)=0.0D0
5453           gradxorr(j,i)=0.0D0
5454         enddo
5455       enddo
5456 C Calculate the dipole-dipole interaction energies
5457       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5458       do i=iatel_s,iatel_e+1
5459         num_conti=num_cont_hb(i)
5460         do jj=1,num_conti
5461           j=jcont_hb(jj,i)
5462           call dipole(i,j,jj)
5463         enddo
5464       enddo
5465       endif
5466 C Calculate the local-electrostatic correlation terms
5467       do i=iatel_s,iatel_e+1
5468         i1=i+1
5469         num_conti=num_cont_hb(i)
5470         num_conti1=num_cont_hb(i+1)
5471         do jj=1,num_conti
5472           j=jcont_hb(jj,i)
5473           do kk=1,num_conti1
5474             j1=jcont_hb(kk,i1)
5475 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5476 c     &         ' jj=',jj,' kk=',kk
5477             if (j1.eq.j+1 .or. j1.eq.j-1) then
5478 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5479 C The system gains extra energy.
5480               n_corr=n_corr+1
5481               sqd1=dsqrt(d_cont(jj,i))
5482               sqd2=dsqrt(d_cont(kk,i1))
5483               sred_geom = sqd1*sqd2
5484               IF (sred_geom.lt.cutoff_corr) THEN
5485                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5486      &            ekont,fprimcont)
5487 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5488 c     &         ' jj=',jj,' kk=',kk
5489                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5490                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5491                 do l=1,3
5492                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5493                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5494                 enddo
5495                 n_corr1=n_corr1+1
5496 cd               write (iout,*) 'sred_geom=',sred_geom,
5497 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5498                 call calc_eello(i,j,i+1,j1,jj,kk)
5499                 if (wcorr4.gt.0.0d0)
5500      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5501                 if (wcorr5.gt.0.0d0)
5502      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5503 c                print *,"wcorr5",ecorr5
5504 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5505 cd                write(2,*)'ijkl',i,j,i+1,j1
5506                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5507      &               .or. wturn6.eq.0.0d0))then
5508 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5509                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5510 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5511 cd     &            'ecorr6=',ecorr6
5512 cd                write (iout,'(4e15.5)') sred_geom,
5513 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5514 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5515 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5516                 else if (wturn6.gt.0.0d0
5517      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5518 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5519                   eturn6=eturn6+eello_turn6(i,jj,kk)
5520 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5521                 endif
5522               ENDIF
5523 1111          continue
5524             else if (j1.eq.j) then
5525 C Contacts I-J and I-(J+1) occur simultaneously.
5526 C The system loses extra energy.
5527 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5528             endif
5529           enddo ! kk
5530           do kk=1,num_conti
5531             j1=jcont_hb(kk,i)
5532 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5533 c    &         ' jj=',jj,' kk=',kk
5534             if (j1.eq.j+1) then
5535 C Contacts I-J and (I+1)-J occur simultaneously.
5536 C The system loses extra energy.
5537 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5538             endif ! j1==j+1
5539           enddo ! kk
5540         enddo ! jj
5541       enddo ! i
5542       return
5543       end
5544 c------------------------------------------------------------------------------
5545       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5546       implicit real*8 (a-h,o-z)
5547       include 'DIMENSIONS'
5548       include 'COMMON.IOUNITS'
5549       include 'COMMON.DERIV'
5550       include 'COMMON.INTERACT'
5551       include 'COMMON.CONTACTS'
5552       double precision gx(3),gx1(3)
5553       logical lprn
5554       lprn=.false.
5555       eij=facont_hb(jj,i)
5556       ekl=facont_hb(kk,k)
5557       ees0pij=ees0p(jj,i)
5558       ees0pkl=ees0p(kk,k)
5559       ees0mij=ees0m(jj,i)
5560       ees0mkl=ees0m(kk,k)
5561       ekont=eij*ekl
5562       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5563 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5564 C Following 4 lines for diagnostics.
5565 cd    ees0pkl=0.0D0
5566 cd    ees0pij=1.0D0
5567 cd    ees0mkl=0.0D0
5568 cd    ees0mij=1.0D0
5569 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5570 c    &   ' and',k,l
5571 c     write (iout,*)'Contacts have occurred for peptide groups',
5572 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5573 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5574 C Calculate the multi-body contribution to energy.
5575       ecorr=ecorr+ekont*ees
5576       if (calc_grad) then
5577 C Calculate multi-body contributions to the gradient.
5578       do ll=1,3
5579         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5580         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5581      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5582      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5583         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5584      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5585      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5586         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5587         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5588      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5589      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5590         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5591      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5592      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5593       enddo
5594       do m=i+1,j-1
5595         do ll=1,3
5596           gradcorr(ll,m)=gradcorr(ll,m)+
5597      &     ees*ekl*gacont_hbr(ll,jj,i)-
5598      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5599      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5600         enddo
5601       enddo
5602       do m=k+1,l-1
5603         do ll=1,3
5604           gradcorr(ll,m)=gradcorr(ll,m)+
5605      &     ees*eij*gacont_hbr(ll,kk,k)-
5606      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5607      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5608         enddo
5609       enddo
5610       endif
5611       ehbcorr=ekont*ees
5612       return
5613       end
5614 C---------------------------------------------------------------------------
5615       subroutine dipole(i,j,jj)
5616       implicit real*8 (a-h,o-z)
5617       include 'DIMENSIONS'
5618       include 'sizesclu.dat'
5619       include 'COMMON.IOUNITS'
5620       include 'COMMON.CHAIN'
5621       include 'COMMON.FFIELD'
5622       include 'COMMON.DERIV'
5623       include 'COMMON.INTERACT'
5624       include 'COMMON.CONTACTS'
5625       include 'COMMON.TORSION'
5626       include 'COMMON.VAR'
5627       include 'COMMON.GEO'
5628       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5629      &  auxmat(2,2)
5630       iti1 = itortyp(itype(i+1))
5631       if (j.lt.nres-1) then
5632         if (itype(j).le.ntyp) then
5633           itj1 = itortyp(itype(j+1))
5634         else
5635           itj1=ntortyp+1
5636         endif
5637       else
5638         itj1=ntortyp+1
5639       endif
5640       do iii=1,2
5641         dipi(iii,1)=Ub2(iii,i)
5642         dipderi(iii)=Ub2der(iii,i)
5643         dipi(iii,2)=b1(iii,iti1)
5644         dipj(iii,1)=Ub2(iii,j)
5645         dipderj(iii)=Ub2der(iii,j)
5646         dipj(iii,2)=b1(iii,itj1)
5647       enddo
5648       kkk=0
5649       do iii=1,2
5650         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5651         do jjj=1,2
5652           kkk=kkk+1
5653           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5654         enddo
5655       enddo
5656       if (.not.calc_grad) return
5657       do kkk=1,5
5658         do lll=1,3
5659           mmm=0
5660           do iii=1,2
5661             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5662      &        auxvec(1))
5663             do jjj=1,2
5664               mmm=mmm+1
5665               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5666             enddo
5667           enddo
5668         enddo
5669       enddo
5670       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5671       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5672       do iii=1,2
5673         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5674       enddo
5675       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5676       do iii=1,2
5677         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5678       enddo
5679       return
5680       end
5681 C---------------------------------------------------------------------------
5682       subroutine calc_eello(i,j,k,l,jj,kk)
5683 C
5684 C This subroutine computes matrices and vectors needed to calculate
5685 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5686 C
5687       implicit real*8 (a-h,o-z)
5688       include 'DIMENSIONS'
5689       include 'sizesclu.dat'
5690       include 'COMMON.IOUNITS'
5691       include 'COMMON.CHAIN'
5692       include 'COMMON.DERIV'
5693       include 'COMMON.INTERACT'
5694       include 'COMMON.CONTACTS'
5695       include 'COMMON.TORSION'
5696       include 'COMMON.VAR'
5697       include 'COMMON.GEO'
5698       include 'COMMON.FFIELD'
5699       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5700      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5701       logical lprn
5702       common /kutas/ lprn
5703 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5704 cd     & ' jj=',jj,' kk=',kk
5705 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5706       do iii=1,2
5707         do jjj=1,2
5708           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5709           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5710         enddo
5711       enddo
5712       call transpose2(aa1(1,1),aa1t(1,1))
5713       call transpose2(aa2(1,1),aa2t(1,1))
5714       do kkk=1,5
5715         do lll=1,3
5716           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5717      &      aa1tder(1,1,lll,kkk))
5718           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5719      &      aa2tder(1,1,lll,kkk))
5720         enddo
5721       enddo
5722       if (l.eq.j+1) then
5723 C parallel orientation of the two CA-CA-CA frames.
5724 c        if (i.gt.1) then
5725         if (i.gt.1 .and. itype(i).le.ntyp) then
5726           iti=itortyp(itype(i))
5727         else
5728           iti=ntortyp+1
5729         endif
5730         itk1=itortyp(itype(k+1))
5731         itj=itortyp(itype(j))
5732 c        if (l.lt.nres-1) then
5733         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5734           itl1=itortyp(itype(l+1))
5735         else
5736           itl1=ntortyp+1
5737         endif
5738 C A1 kernel(j+1) A2T
5739 cd        do iii=1,2
5740 cd          write (iout,'(3f10.5,5x,3f10.5)')
5741 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5742 cd        enddo
5743         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5744      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5745      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5746 C Following matrices are needed only for 6-th order cumulants
5747         IF (wcorr6.gt.0.0d0) THEN
5748         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5749      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5750      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(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,.false.,Ug2DtEUg(1,1,l),
5753      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5754      &   ADtEAderx(1,1,1,1,1,1))
5755         lprn=.false.
5756         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5757      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5758      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5759      &   ADtEA1derx(1,1,1,1,1,1))
5760         ENDIF
5761 C End 6-th order cumulants
5762 cd        lprn=.false.
5763 cd        if (lprn) then
5764 cd        write (2,*) 'In calc_eello6'
5765 cd        do iii=1,2
5766 cd          write (2,*) 'iii=',iii
5767 cd          do kkk=1,5
5768 cd            write (2,*) 'kkk=',kkk
5769 cd            do jjj=1,2
5770 cd              write (2,'(3(2f10.5),5x)')
5771 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5772 cd            enddo
5773 cd          enddo
5774 cd        enddo
5775 cd        endif
5776         call transpose2(EUgder(1,1,k),auxmat(1,1))
5777         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5778         call transpose2(EUg(1,1,k),auxmat(1,1))
5779         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5780         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5781         do iii=1,2
5782           do kkk=1,5
5783             do lll=1,3
5784               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5785      &          EAEAderx(1,1,lll,kkk,iii,1))
5786             enddo
5787           enddo
5788         enddo
5789 C A1T kernel(i+1) A2
5790         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5791      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5792      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5793 C Following matrices are needed only for 6-th order cumulants
5794         IF (wcorr6.gt.0.0d0) THEN
5795         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5796      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5797      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5798         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5799      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5800      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5801      &   ADtEAderx(1,1,1,1,1,2))
5802         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5803      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5804      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5805      &   ADtEA1derx(1,1,1,1,1,2))
5806         ENDIF
5807 C End 6-th order cumulants
5808         call transpose2(EUgder(1,1,l),auxmat(1,1))
5809         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5810         call transpose2(EUg(1,1,l),auxmat(1,1))
5811         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5812         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5813         do iii=1,2
5814           do kkk=1,5
5815             do lll=1,3
5816               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5817      &          EAEAderx(1,1,lll,kkk,iii,2))
5818             enddo
5819           enddo
5820         enddo
5821 C AEAb1 and AEAb2
5822 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5823 C They are needed only when the fifth- or the sixth-order cumulants are
5824 C indluded.
5825         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5826         call transpose2(AEA(1,1,1),auxmat(1,1))
5827         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5828         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5829         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5830         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5831         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5832         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5833         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5834         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5835         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5836         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5837         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5838         call transpose2(AEA(1,1,2),auxmat(1,1))
5839         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5840         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5841         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5842         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5843         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5844         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5845         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5846         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5847         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5848         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5849         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5850 C Calculate the Cartesian derivatives of the vectors.
5851         do iii=1,2
5852           do kkk=1,5
5853             do lll=1,3
5854               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5855               call matvec2(auxmat(1,1),b1(1,iti),
5856      &          AEAb1derx(1,lll,kkk,iii,1,1))
5857               call matvec2(auxmat(1,1),Ub2(1,i),
5858      &          AEAb2derx(1,lll,kkk,iii,1,1))
5859               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5860      &          AEAb1derx(1,lll,kkk,iii,2,1))
5861               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5862      &          AEAb2derx(1,lll,kkk,iii,2,1))
5863               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5864               call matvec2(auxmat(1,1),b1(1,itj),
5865      &          AEAb1derx(1,lll,kkk,iii,1,2))
5866               call matvec2(auxmat(1,1),Ub2(1,j),
5867      &          AEAb2derx(1,lll,kkk,iii,1,2))
5868               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5869      &          AEAb1derx(1,lll,kkk,iii,2,2))
5870               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5871      &          AEAb2derx(1,lll,kkk,iii,2,2))
5872             enddo
5873           enddo
5874         enddo
5875         ENDIF
5876 C End vectors
5877       else
5878 C Antiparallel orientation of the two CA-CA-CA frames.
5879 c        if (i.gt.1) then
5880         if (i.gt.1 .and. itype(i).le.ntyp) then
5881           iti=itortyp(itype(i))
5882         else
5883           iti=ntortyp+1
5884         endif
5885         itk1=itortyp(itype(k+1))
5886         itl=itortyp(itype(l))
5887         itj=itortyp(itype(j))
5888 c        if (j.lt.nres-1) then
5889         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
5890           itj1=itortyp(itype(j+1))
5891         else
5892           itj1=ntortyp+1
5893         endif
5894 C A2 kernel(j-1)T A1T
5895         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5896      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5897      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5898 C Following matrices are needed only for 6-th order cumulants
5899         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5900      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5901         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5902      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5903      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5904         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5905      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5906      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5907      &   ADtEAderx(1,1,1,1,1,1))
5908         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5909      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5910      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5911      &   ADtEA1derx(1,1,1,1,1,1))
5912         ENDIF
5913 C End 6-th order cumulants
5914         call transpose2(EUgder(1,1,k),auxmat(1,1))
5915         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5916         call transpose2(EUg(1,1,k),auxmat(1,1))
5917         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5918         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5919         do iii=1,2
5920           do kkk=1,5
5921             do lll=1,3
5922               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5923      &          EAEAderx(1,1,lll,kkk,iii,1))
5924             enddo
5925           enddo
5926         enddo
5927 C A2T kernel(i+1)T A1
5928         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5929      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5930      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5931 C Following matrices are needed only for 6-th order cumulants
5932         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5933      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5934         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5935      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5936      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5937         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5938      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5939      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5940      &   ADtEAderx(1,1,1,1,1,2))
5941         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5942      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5943      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5944      &   ADtEA1derx(1,1,1,1,1,2))
5945         ENDIF
5946 C End 6-th order cumulants
5947         call transpose2(EUgder(1,1,j),auxmat(1,1))
5948         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5949         call transpose2(EUg(1,1,j),auxmat(1,1))
5950         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5951         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5952         do iii=1,2
5953           do kkk=1,5
5954             do lll=1,3
5955               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5956      &          EAEAderx(1,1,lll,kkk,iii,2))
5957             enddo
5958           enddo
5959         enddo
5960 C AEAb1 and AEAb2
5961 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5962 C They are needed only when the fifth- or the sixth-order cumulants are
5963 C indluded.
5964         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5965      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5966         call transpose2(AEA(1,1,1),auxmat(1,1))
5967         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5968         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5969         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5970         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5971         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5972         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5973         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5974         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5975         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5976         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5977         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5978         call transpose2(AEA(1,1,2),auxmat(1,1))
5979         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5980         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5981         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5982         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5983         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5984         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5985         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5986         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5987         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5988         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5989         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5990 C Calculate the Cartesian derivatives of the vectors.
5991         do iii=1,2
5992           do kkk=1,5
5993             do lll=1,3
5994               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5995               call matvec2(auxmat(1,1),b1(1,iti),
5996      &          AEAb1derx(1,lll,kkk,iii,1,1))
5997               call matvec2(auxmat(1,1),Ub2(1,i),
5998      &          AEAb2derx(1,lll,kkk,iii,1,1))
5999               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6000      &          AEAb1derx(1,lll,kkk,iii,2,1))
6001               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6002      &          AEAb2derx(1,lll,kkk,iii,2,1))
6003               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6004               call matvec2(auxmat(1,1),b1(1,itl),
6005      &          AEAb1derx(1,lll,kkk,iii,1,2))
6006               call matvec2(auxmat(1,1),Ub2(1,l),
6007      &          AEAb2derx(1,lll,kkk,iii,1,2))
6008               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6009      &          AEAb1derx(1,lll,kkk,iii,2,2))
6010               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6011      &          AEAb2derx(1,lll,kkk,iii,2,2))
6012             enddo
6013           enddo
6014         enddo
6015         ENDIF
6016 C End vectors
6017       endif
6018       return
6019       end
6020 C---------------------------------------------------------------------------
6021       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6022      &  KK,KKderg,AKA,AKAderg,AKAderx)
6023       implicit none
6024       integer nderg
6025       logical transp
6026       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6027      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6028      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6029       integer iii,kkk,lll
6030       integer jjj,mmm
6031       logical lprn
6032       common /kutas/ lprn
6033       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6034       do iii=1,nderg
6035         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6036      &    AKAderg(1,1,iii))
6037       enddo
6038 cd      if (lprn) write (2,*) 'In kernel'
6039       do kkk=1,5
6040 cd        if (lprn) write (2,*) 'kkk=',kkk
6041         do lll=1,3
6042           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6043      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6044 cd          if (lprn) then
6045 cd            write (2,*) 'lll=',lll
6046 cd            write (2,*) 'iii=1'
6047 cd            do jjj=1,2
6048 cd              write (2,'(3(2f10.5),5x)')
6049 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6050 cd            enddo
6051 cd          endif
6052           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6053      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6054 cd          if (lprn) then
6055 cd            write (2,*) 'lll=',lll
6056 cd            write (2,*) 'iii=2'
6057 cd            do jjj=1,2
6058 cd              write (2,'(3(2f10.5),5x)')
6059 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6060 cd            enddo
6061 cd          endif
6062         enddo
6063       enddo
6064       return
6065       end
6066 C---------------------------------------------------------------------------
6067       double precision function eello4(i,j,k,l,jj,kk)
6068       implicit real*8 (a-h,o-z)
6069       include 'DIMENSIONS'
6070       include 'sizesclu.dat'
6071       include 'COMMON.IOUNITS'
6072       include 'COMMON.CHAIN'
6073       include 'COMMON.DERIV'
6074       include 'COMMON.INTERACT'
6075       include 'COMMON.CONTACTS'
6076       include 'COMMON.TORSION'
6077       include 'COMMON.VAR'
6078       include 'COMMON.GEO'
6079       double precision pizda(2,2),ggg1(3),ggg2(3)
6080 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6081 cd        eello4=0.0d0
6082 cd        return
6083 cd      endif
6084 cd      print *,'eello4:',i,j,k,l,jj,kk
6085 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6086 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6087 cold      eij=facont_hb(jj,i)
6088 cold      ekl=facont_hb(kk,k)
6089 cold      ekont=eij*ekl
6090       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6091       if (calc_grad) then
6092 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6093       gcorr_loc(k-1)=gcorr_loc(k-1)
6094      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6095       if (l.eq.j+1) then
6096         gcorr_loc(l-1)=gcorr_loc(l-1)
6097      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6098       else
6099         gcorr_loc(j-1)=gcorr_loc(j-1)
6100      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6101       endif
6102       do iii=1,2
6103         do kkk=1,5
6104           do lll=1,3
6105             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6106      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6107 cd            derx(lll,kkk,iii)=0.0d0
6108           enddo
6109         enddo
6110       enddo
6111 cd      gcorr_loc(l-1)=0.0d0
6112 cd      gcorr_loc(j-1)=0.0d0
6113 cd      gcorr_loc(k-1)=0.0d0
6114 cd      eel4=1.0d0
6115 cd      write (iout,*)'Contacts have occurred for peptide groups',
6116 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6117 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6118       if (j.lt.nres-1) then
6119         j1=j+1
6120         j2=j-1
6121       else
6122         j1=j-1
6123         j2=j-2
6124       endif
6125       if (l.lt.nres-1) then
6126         l1=l+1
6127         l2=l-1
6128       else
6129         l1=l-1
6130         l2=l-2
6131       endif
6132       do ll=1,3
6133 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6134         ggg1(ll)=eel4*g_contij(ll,1)
6135         ggg2(ll)=eel4*g_contij(ll,2)
6136         ghalf=0.5d0*ggg1(ll)
6137 cd        ghalf=0.0d0
6138         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6139         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6140         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6141         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6142 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6143         ghalf=0.5d0*ggg2(ll)
6144 cd        ghalf=0.0d0
6145         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6146         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6147         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6148         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6149       enddo
6150 cd      goto 1112
6151       do m=i+1,j-1
6152         do ll=1,3
6153 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6154           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6155         enddo
6156       enddo
6157       do m=k+1,l-1
6158         do ll=1,3
6159 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6160           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6161         enddo
6162       enddo
6163 1112  continue
6164       do m=i+2,j2
6165         do ll=1,3
6166           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6167         enddo
6168       enddo
6169       do m=k+2,l2
6170         do ll=1,3
6171           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6172         enddo
6173       enddo
6174 cd      do iii=1,nres-3
6175 cd        write (2,*) iii,gcorr_loc(iii)
6176 cd      enddo
6177       endif
6178       eello4=ekont*eel4
6179 cd      write (2,*) 'ekont',ekont
6180 cd      write (iout,*) 'eello4',ekont*eel4
6181       return
6182       end
6183 C---------------------------------------------------------------------------
6184       double precision function eello5(i,j,k,l,jj,kk)
6185       implicit real*8 (a-h,o-z)
6186       include 'DIMENSIONS'
6187       include 'sizesclu.dat'
6188       include 'COMMON.IOUNITS'
6189       include 'COMMON.CHAIN'
6190       include 'COMMON.DERIV'
6191       include 'COMMON.INTERACT'
6192       include 'COMMON.CONTACTS'
6193       include 'COMMON.TORSION'
6194       include 'COMMON.VAR'
6195       include 'COMMON.GEO'
6196       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6197       double precision ggg1(3),ggg2(3)
6198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6199 C                                                                              C
6200 C                            Parallel chains                                   C
6201 C                                                                              C
6202 C          o             o                   o             o                   C
6203 C         /l\           / \             \   / \           / \   /              C
6204 C        /   \         /   \             \ /   \         /   \ /               C
6205 C       j| o |l1       | o |              o| o |         | o |o                C
6206 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6207 C      \i/   \         /   \ /             /   \         /   \                 C
6208 C       o    k1             o                                                  C
6209 C         (I)          (II)                (III)          (IV)                 C
6210 C                                                                              C
6211 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6212 C                                                                              C
6213 C                            Antiparallel chains                               C
6214 C                                                                              C
6215 C          o             o                   o             o                   C
6216 C         /j\           / \             \   / \           / \   /              C
6217 C        /   \         /   \             \ /   \         /   \ /               C
6218 C      j1| o |l        | o |              o| o |         | o |o                C
6219 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6220 C      \i/   \         /   \ /             /   \         /   \                 C
6221 C       o     k1            o                                                  C
6222 C         (I)          (II)                (III)          (IV)                 C
6223 C                                                                              C
6224 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6225 C                                                                              C
6226 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6227 C                                                                              C
6228 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6229 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6230 cd        eello5=0.0d0
6231 cd        return
6232 cd      endif
6233 cd      write (iout,*)
6234 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6235 cd     &   ' and',k,l
6236       itk=itortyp(itype(k))
6237       itl=itortyp(itype(l))
6238       itj=itortyp(itype(j))
6239       eello5_1=0.0d0
6240       eello5_2=0.0d0
6241       eello5_3=0.0d0
6242       eello5_4=0.0d0
6243 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6244 cd     &   eel5_3_num,eel5_4_num)
6245       do iii=1,2
6246         do kkk=1,5
6247           do lll=1,3
6248             derx(lll,kkk,iii)=0.0d0
6249           enddo
6250         enddo
6251       enddo
6252 cd      eij=facont_hb(jj,i)
6253 cd      ekl=facont_hb(kk,k)
6254 cd      ekont=eij*ekl
6255 cd      write (iout,*)'Contacts have occurred for peptide groups',
6256 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6257 cd      goto 1111
6258 C Contribution from the graph I.
6259 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6260 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6261       call transpose2(EUg(1,1,k),auxmat(1,1))
6262       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6263       vv(1)=pizda(1,1)-pizda(2,2)
6264       vv(2)=pizda(1,2)+pizda(2,1)
6265       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6266      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6267       if (calc_grad) then
6268 C Explicit gradient in virtual-dihedral angles.
6269       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6270      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6271      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6272       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6273       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6274       vv(1)=pizda(1,1)-pizda(2,2)
6275       vv(2)=pizda(1,2)+pizda(2,1)
6276       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6277      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6278      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6279       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6280       vv(1)=pizda(1,1)-pizda(2,2)
6281       vv(2)=pizda(1,2)+pizda(2,1)
6282       if (l.eq.j+1) then
6283         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6284      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6285      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6286       else
6287         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6288      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6289      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6290       endif
6291 C Cartesian gradient
6292       do iii=1,2
6293         do kkk=1,5
6294           do lll=1,3
6295             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6296      &        pizda(1,1))
6297             vv(1)=pizda(1,1)-pizda(2,2)
6298             vv(2)=pizda(1,2)+pizda(2,1)
6299             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6300      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6301      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6302           enddo
6303         enddo
6304       enddo
6305 c      goto 1112
6306       endif
6307 c1111  continue
6308 C Contribution from graph II
6309       call transpose2(EE(1,1,itk),auxmat(1,1))
6310       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6311       vv(1)=pizda(1,1)+pizda(2,2)
6312       vv(2)=pizda(2,1)-pizda(1,2)
6313       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6314      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6315       if (calc_grad) then
6316 C Explicit gradient in virtual-dihedral angles.
6317       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6318      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6319       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6320       vv(1)=pizda(1,1)+pizda(2,2)
6321       vv(2)=pizda(2,1)-pizda(1,2)
6322       if (l.eq.j+1) then
6323         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6324      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6325      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6326       else
6327         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6328      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6329      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6330       endif
6331 C Cartesian gradient
6332       do iii=1,2
6333         do kkk=1,5
6334           do lll=1,3
6335             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6336      &        pizda(1,1))
6337             vv(1)=pizda(1,1)+pizda(2,2)
6338             vv(2)=pizda(2,1)-pizda(1,2)
6339             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6340      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6341      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6342           enddo
6343         enddo
6344       enddo
6345 cd      goto 1112
6346       endif
6347 cd1111  continue
6348       if (l.eq.j+1) then
6349 cd        goto 1110
6350 C Parallel orientation
6351 C Contribution from graph III
6352         call transpose2(EUg(1,1,l),auxmat(1,1))
6353         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6354         vv(1)=pizda(1,1)-pizda(2,2)
6355         vv(2)=pizda(1,2)+pizda(2,1)
6356         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6357      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6358         if (calc_grad) then
6359 C Explicit gradient in virtual-dihedral angles.
6360         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6361      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6362      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6363         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6364         vv(1)=pizda(1,1)-pizda(2,2)
6365         vv(2)=pizda(1,2)+pizda(2,1)
6366         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6367      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6368      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6369         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6370         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6371         vv(1)=pizda(1,1)-pizda(2,2)
6372         vv(2)=pizda(1,2)+pizda(2,1)
6373         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6374      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6375      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6376 C Cartesian gradient
6377         do iii=1,2
6378           do kkk=1,5
6379             do lll=1,3
6380               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6381      &          pizda(1,1))
6382               vv(1)=pizda(1,1)-pizda(2,2)
6383               vv(2)=pizda(1,2)+pizda(2,1)
6384               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6385      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6386      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6387             enddo
6388           enddo
6389         enddo
6390 cd        goto 1112
6391         endif
6392 C Contribution from graph IV
6393 cd1110    continue
6394         call transpose2(EE(1,1,itl),auxmat(1,1))
6395         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6396         vv(1)=pizda(1,1)+pizda(2,2)
6397         vv(2)=pizda(2,1)-pizda(1,2)
6398         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6399      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6400         if (calc_grad) then
6401 C Explicit gradient in virtual-dihedral angles.
6402         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6403      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6404         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6405         vv(1)=pizda(1,1)+pizda(2,2)
6406         vv(2)=pizda(2,1)-pizda(1,2)
6407         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6408      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6409      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6410 C Cartesian gradient
6411         do iii=1,2
6412           do kkk=1,5
6413             do lll=1,3
6414               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6415      &          pizda(1,1))
6416               vv(1)=pizda(1,1)+pizda(2,2)
6417               vv(2)=pizda(2,1)-pizda(1,2)
6418               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6419      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6420      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6421             enddo
6422           enddo
6423         enddo
6424         endif
6425       else
6426 C Antiparallel orientation
6427 C Contribution from graph III
6428 c        goto 1110
6429         call transpose2(EUg(1,1,j),auxmat(1,1))
6430         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6431         vv(1)=pizda(1,1)-pizda(2,2)
6432         vv(2)=pizda(1,2)+pizda(2,1)
6433         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6434      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6435         if (calc_grad) then
6436 C Explicit gradient in virtual-dihedral angles.
6437         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6438      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6439      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6440         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6441         vv(1)=pizda(1,1)-pizda(2,2)
6442         vv(2)=pizda(1,2)+pizda(2,1)
6443         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6444      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6445      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6446         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6447         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6448         vv(1)=pizda(1,1)-pizda(2,2)
6449         vv(2)=pizda(1,2)+pizda(2,1)
6450         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6451      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6452      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6453 C Cartesian gradient
6454         do iii=1,2
6455           do kkk=1,5
6456             do lll=1,3
6457               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6458      &          pizda(1,1))
6459               vv(1)=pizda(1,1)-pizda(2,2)
6460               vv(2)=pizda(1,2)+pizda(2,1)
6461               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6462      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6463      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6464             enddo
6465           enddo
6466         enddo
6467 cd        goto 1112
6468         endif
6469 C Contribution from graph IV
6470 1110    continue
6471         call transpose2(EE(1,1,itj),auxmat(1,1))
6472         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6473         vv(1)=pizda(1,1)+pizda(2,2)
6474         vv(2)=pizda(2,1)-pizda(1,2)
6475         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6476      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6477         if (calc_grad) then
6478 C Explicit gradient in virtual-dihedral angles.
6479         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6480      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6481         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6482         vv(1)=pizda(1,1)+pizda(2,2)
6483         vv(2)=pizda(2,1)-pizda(1,2)
6484         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6485      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6486      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6487 C Cartesian gradient
6488         do iii=1,2
6489           do kkk=1,5
6490             do lll=1,3
6491               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6492      &          pizda(1,1))
6493               vv(1)=pizda(1,1)+pizda(2,2)
6494               vv(2)=pizda(2,1)-pizda(1,2)
6495               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6496      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6497      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6498             enddo
6499           enddo
6500         enddo
6501       endif
6502       endif
6503 1112  continue
6504       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6505 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6506 cd        write (2,*) 'ijkl',i,j,k,l
6507 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6508 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6509 cd      endif
6510 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6511 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6512 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6513 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6514       if (calc_grad) then
6515       if (j.lt.nres-1) then
6516         j1=j+1
6517         j2=j-1
6518       else
6519         j1=j-1
6520         j2=j-2
6521       endif
6522       if (l.lt.nres-1) then
6523         l1=l+1
6524         l2=l-1
6525       else
6526         l1=l-1
6527         l2=l-2
6528       endif
6529 cd      eij=1.0d0
6530 cd      ekl=1.0d0
6531 cd      ekont=1.0d0
6532 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6533       do ll=1,3
6534         ggg1(ll)=eel5*g_contij(ll,1)
6535         ggg2(ll)=eel5*g_contij(ll,2)
6536 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6537         ghalf=0.5d0*ggg1(ll)
6538 cd        ghalf=0.0d0
6539         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6540         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6541         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6542         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6543 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6544         ghalf=0.5d0*ggg2(ll)
6545 cd        ghalf=0.0d0
6546         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6547         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6548         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6549         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6550       enddo
6551 cd      goto 1112
6552       do m=i+1,j-1
6553         do ll=1,3
6554 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6555           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6556         enddo
6557       enddo
6558       do m=k+1,l-1
6559         do ll=1,3
6560 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6561           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6562         enddo
6563       enddo
6564 c1112  continue
6565       do m=i+2,j2
6566         do ll=1,3
6567           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6568         enddo
6569       enddo
6570       do m=k+2,l2
6571         do ll=1,3
6572           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6573         enddo
6574       enddo
6575 cd      do iii=1,nres-3
6576 cd        write (2,*) iii,g_corr5_loc(iii)
6577 cd      enddo
6578       endif
6579       eello5=ekont*eel5
6580 cd      write (2,*) 'ekont',ekont
6581 cd      write (iout,*) 'eello5',ekont*eel5
6582       return
6583       end
6584 c--------------------------------------------------------------------------
6585       double precision function eello6(i,j,k,l,jj,kk)
6586       implicit real*8 (a-h,o-z)
6587       include 'DIMENSIONS'
6588       include 'sizesclu.dat'
6589       include 'COMMON.IOUNITS'
6590       include 'COMMON.CHAIN'
6591       include 'COMMON.DERIV'
6592       include 'COMMON.INTERACT'
6593       include 'COMMON.CONTACTS'
6594       include 'COMMON.TORSION'
6595       include 'COMMON.VAR'
6596       include 'COMMON.GEO'
6597       include 'COMMON.FFIELD'
6598       double precision ggg1(3),ggg2(3)
6599 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6600 cd        eello6=0.0d0
6601 cd        return
6602 cd      endif
6603 cd      write (iout,*)
6604 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6605 cd     &   ' and',k,l
6606       eello6_1=0.0d0
6607       eello6_2=0.0d0
6608       eello6_3=0.0d0
6609       eello6_4=0.0d0
6610       eello6_5=0.0d0
6611       eello6_6=0.0d0
6612 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6613 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6614       do iii=1,2
6615         do kkk=1,5
6616           do lll=1,3
6617             derx(lll,kkk,iii)=0.0d0
6618           enddo
6619         enddo
6620       enddo
6621 cd      eij=facont_hb(jj,i)
6622 cd      ekl=facont_hb(kk,k)
6623 cd      ekont=eij*ekl
6624 cd      eij=1.0d0
6625 cd      ekl=1.0d0
6626 cd      ekont=1.0d0
6627       if (l.eq.j+1) then
6628         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6629         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6630         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6631         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6632         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6633         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6634       else
6635         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6636         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6637         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6638         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6639         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6640           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6641         else
6642           eello6_5=0.0d0
6643         endif
6644         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6645       endif
6646 C If turn contributions are considered, they will be handled separately.
6647       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6648 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6649 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6650 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6651 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6652 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6653 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6654 cd      goto 1112
6655       if (calc_grad) then
6656       if (j.lt.nres-1) then
6657         j1=j+1
6658         j2=j-1
6659       else
6660         j1=j-1
6661         j2=j-2
6662       endif
6663       if (l.lt.nres-1) then
6664         l1=l+1
6665         l2=l-1
6666       else
6667         l1=l-1
6668         l2=l-2
6669       endif
6670       do ll=1,3
6671         ggg1(ll)=eel6*g_contij(ll,1)
6672         ggg2(ll)=eel6*g_contij(ll,2)
6673 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6674         ghalf=0.5d0*ggg1(ll)
6675 cd        ghalf=0.0d0
6676         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6677         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6678         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6679         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6680         ghalf=0.5d0*ggg2(ll)
6681 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6682 cd        ghalf=0.0d0
6683         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6684         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6685         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6686         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6687       enddo
6688 cd      goto 1112
6689       do m=i+1,j-1
6690         do ll=1,3
6691 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6692           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6693         enddo
6694       enddo
6695       do m=k+1,l-1
6696         do ll=1,3
6697 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6698           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6699         enddo
6700       enddo
6701 1112  continue
6702       do m=i+2,j2
6703         do ll=1,3
6704           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6705         enddo
6706       enddo
6707       do m=k+2,l2
6708         do ll=1,3
6709           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6710         enddo
6711       enddo
6712 cd      do iii=1,nres-3
6713 cd        write (2,*) iii,g_corr6_loc(iii)
6714 cd      enddo
6715       endif
6716       eello6=ekont*eel6
6717 cd      write (2,*) 'ekont',ekont
6718 cd      write (iout,*) 'eello6',ekont*eel6
6719       return
6720       end
6721 c--------------------------------------------------------------------------
6722       double precision function eello6_graph1(i,j,k,l,imat,swap)
6723       implicit real*8 (a-h,o-z)
6724       include 'DIMENSIONS'
6725       include 'sizesclu.dat'
6726       include 'COMMON.IOUNITS'
6727       include 'COMMON.CHAIN'
6728       include 'COMMON.DERIV'
6729       include 'COMMON.INTERACT'
6730       include 'COMMON.CONTACTS'
6731       include 'COMMON.TORSION'
6732       include 'COMMON.VAR'
6733       include 'COMMON.GEO'
6734       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6735       logical swap
6736       logical lprn
6737       common /kutas/ lprn
6738 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6739 C                                                                              C
6740 C      Parallel       Antiparallel                                             C
6741 C                                                                              C
6742 C          o             o                                                     C
6743 C         /l\           /j\                                                    C
6744 C        /   \         /   \                                                   C
6745 C       /| o |         | o |\                                                  C
6746 C     \ j|/k\|  /   \  |/k\|l /                                                C
6747 C      \ /   \ /     \ /   \ /                                                 C
6748 C       o     o       o     o                                                  C
6749 C       i             i                                                        C
6750 C                                                                              C
6751 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6752       itk=itortyp(itype(k))
6753       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6754       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6755       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6756       call transpose2(EUgC(1,1,k),auxmat(1,1))
6757       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6758       vv1(1)=pizda1(1,1)-pizda1(2,2)
6759       vv1(2)=pizda1(1,2)+pizda1(2,1)
6760       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6761       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6762       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6763       s5=scalar2(vv(1),Dtobr2(1,i))
6764 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6765       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6766       if (.not. calc_grad) return
6767       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6768      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6769      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6770      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6771      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6772      & +scalar2(vv(1),Dtobr2der(1,i)))
6773       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6774       vv1(1)=pizda1(1,1)-pizda1(2,2)
6775       vv1(2)=pizda1(1,2)+pizda1(2,1)
6776       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6777       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6778       if (l.eq.j+1) then
6779         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6780      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6781      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6782      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6783      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6784       else
6785         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6786      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6787      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6788      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6789      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6790       endif
6791       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6792       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6793       vv1(1)=pizda1(1,1)-pizda1(2,2)
6794       vv1(2)=pizda1(1,2)+pizda1(2,1)
6795       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6796      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6797      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6798      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6799       do iii=1,2
6800         if (swap) then
6801           ind=3-iii
6802         else
6803           ind=iii
6804         endif
6805         do kkk=1,5
6806           do lll=1,3
6807             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6808             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6809             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6810             call transpose2(EUgC(1,1,k),auxmat(1,1))
6811             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6812      &        pizda1(1,1))
6813             vv1(1)=pizda1(1,1)-pizda1(2,2)
6814             vv1(2)=pizda1(1,2)+pizda1(2,1)
6815             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6816             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6817      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6818             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6819      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6820             s5=scalar2(vv(1),Dtobr2(1,i))
6821             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6822           enddo
6823         enddo
6824       enddo
6825       return
6826       end
6827 c----------------------------------------------------------------------------
6828       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6829       implicit real*8 (a-h,o-z)
6830       include 'DIMENSIONS'
6831       include 'sizesclu.dat'
6832       include 'COMMON.IOUNITS'
6833       include 'COMMON.CHAIN'
6834       include 'COMMON.DERIV'
6835       include 'COMMON.INTERACT'
6836       include 'COMMON.CONTACTS'
6837       include 'COMMON.TORSION'
6838       include 'COMMON.VAR'
6839       include 'COMMON.GEO'
6840       logical swap
6841       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6842      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6843       logical lprn
6844       common /kutas/ lprn
6845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6846 C                                                                              C
6847 C      Parallel       Antiparallel                                             C
6848 C                                                                              C
6849 C          o             o                                                     C
6850 C     \   /l\           /j\   /                                                C
6851 C      \ /   \         /   \ /                                                 C
6852 C       o| o |         | o |o                                                  C
6853 C     \ j|/k\|      \  |/k\|l                                                  C
6854 C      \ /   \       \ /   \                                                   C
6855 C       o             o                                                        C
6856 C       i             i                                                        C
6857 C                                                                              C
6858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6859 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6860 C AL 7/4/01 s1 would occur in the sixth-order moment,
6861 C           but not in a cluster cumulant
6862 #ifdef MOMENT
6863       s1=dip(1,jj,i)*dip(1,kk,k)
6864 #endif
6865       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6866       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6867       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6868       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6869       call transpose2(EUg(1,1,k),auxmat(1,1))
6870       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6871       vv(1)=pizda(1,1)-pizda(2,2)
6872       vv(2)=pizda(1,2)+pizda(2,1)
6873       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6874 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6875 #ifdef MOMENT
6876       eello6_graph2=-(s1+s2+s3+s4)
6877 #else
6878       eello6_graph2=-(s2+s3+s4)
6879 #endif
6880 c      eello6_graph2=-s3
6881       if (.not. calc_grad) return
6882 C Derivatives in gamma(i-1)
6883       if (i.gt.1) then
6884 #ifdef MOMENT
6885         s1=dipderg(1,jj,i)*dip(1,kk,k)
6886 #endif
6887         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6888         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6889         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6890         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6891 #ifdef MOMENT
6892         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6893 #else
6894         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6895 #endif
6896 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6897       endif
6898 C Derivatives in gamma(k-1)
6899 #ifdef MOMENT
6900       s1=dip(1,jj,i)*dipderg(1,kk,k)
6901 #endif
6902       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6903       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6904       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6905       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6906       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6907       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6908       vv(1)=pizda(1,1)-pizda(2,2)
6909       vv(2)=pizda(1,2)+pizda(2,1)
6910       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6911 #ifdef MOMENT
6912       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6913 #else
6914       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6915 #endif
6916 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6917 C Derivatives in gamma(j-1) or gamma(l-1)
6918       if (j.gt.1) then
6919 #ifdef MOMENT
6920         s1=dipderg(3,jj,i)*dip(1,kk,k)
6921 #endif
6922         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6923         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6924         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6925         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6926         vv(1)=pizda(1,1)-pizda(2,2)
6927         vv(2)=pizda(1,2)+pizda(2,1)
6928         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6929 #ifdef MOMENT
6930         if (swap) then
6931           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6932         else
6933           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6934         endif
6935 #endif
6936         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6937 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6938       endif
6939 C Derivatives in gamma(l-1) or gamma(j-1)
6940       if (l.gt.1) then
6941 #ifdef MOMENT
6942         s1=dip(1,jj,i)*dipderg(3,kk,k)
6943 #endif
6944         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6945         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6946         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6947         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6948         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6949         vv(1)=pizda(1,1)-pizda(2,2)
6950         vv(2)=pizda(1,2)+pizda(2,1)
6951         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6952 #ifdef MOMENT
6953         if (swap) then
6954           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6955         else
6956           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6957         endif
6958 #endif
6959         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6960 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6961       endif
6962 C Cartesian derivatives.
6963       if (lprn) then
6964         write (2,*) 'In eello6_graph2'
6965         do iii=1,2
6966           write (2,*) 'iii=',iii
6967           do kkk=1,5
6968             write (2,*) 'kkk=',kkk
6969             do jjj=1,2
6970               write (2,'(3(2f10.5),5x)')
6971      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6972             enddo
6973           enddo
6974         enddo
6975       endif
6976       do iii=1,2
6977         do kkk=1,5
6978           do lll=1,3
6979 #ifdef MOMENT
6980             if (iii.eq.1) then
6981               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6982             else
6983               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6984             endif
6985 #endif
6986             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6987      &        auxvec(1))
6988             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6989             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6990      &        auxvec(1))
6991             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6992             call transpose2(EUg(1,1,k),auxmat(1,1))
6993             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6994      &        pizda(1,1))
6995             vv(1)=pizda(1,1)-pizda(2,2)
6996             vv(2)=pizda(1,2)+pizda(2,1)
6997             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6998 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6999 #ifdef MOMENT
7000             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7001 #else
7002             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7003 #endif
7004             if (swap) then
7005               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7006             else
7007               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7008             endif
7009           enddo
7010         enddo
7011       enddo
7012       return
7013       end
7014 c----------------------------------------------------------------------------
7015       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7016       implicit real*8 (a-h,o-z)
7017       include 'DIMENSIONS'
7018       include 'sizesclu.dat'
7019       include 'COMMON.IOUNITS'
7020       include 'COMMON.CHAIN'
7021       include 'COMMON.DERIV'
7022       include 'COMMON.INTERACT'
7023       include 'COMMON.CONTACTS'
7024       include 'COMMON.TORSION'
7025       include 'COMMON.VAR'
7026       include 'COMMON.GEO'
7027       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7028       logical swap
7029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7030 C                                                                              C
7031 C      Parallel       Antiparallel                                             C
7032 C                                                                              C
7033 C          o             o                                                     C
7034 C         /l\   /   \   /j\                                                    C
7035 C        /   \ /     \ /   \                                                   C
7036 C       /| o |o       o| o |\                                                  C
7037 C       j|/k\|  /      |/k\|l /                                                C
7038 C        /   \ /       /   \ /                                                 C
7039 C       /     o       /     o                                                  C
7040 C       i             i                                                        C
7041 C                                                                              C
7042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7043 C
7044 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7045 C           energy moment and not to the cluster cumulant.
7046       iti=itortyp(itype(i))
7047 c      if (j.lt.nres-1) then
7048       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7049         itj1=itortyp(itype(j+1))
7050       else
7051         itj1=ntortyp+1
7052       endif
7053       itk=itortyp(itype(k))
7054       itk1=itortyp(itype(k+1))
7055 c      if (l.lt.nres-1) then
7056       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7057         itl1=itortyp(itype(l+1))
7058       else
7059         itl1=ntortyp+1
7060       endif
7061 #ifdef MOMENT
7062       s1=dip(4,jj,i)*dip(4,kk,k)
7063 #endif
7064       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7065       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7066       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7067       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7068       call transpose2(EE(1,1,itk),auxmat(1,1))
7069       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7070       vv(1)=pizda(1,1)+pizda(2,2)
7071       vv(2)=pizda(2,1)-pizda(1,2)
7072       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7073 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7074 #ifdef MOMENT
7075       eello6_graph3=-(s1+s2+s3+s4)
7076 #else
7077       eello6_graph3=-(s2+s3+s4)
7078 #endif
7079 c      eello6_graph3=-s4
7080       if (.not. calc_grad) return
7081 C Derivatives in gamma(k-1)
7082       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7083       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7084       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7085       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7086 C Derivatives in gamma(l-1)
7087       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7088       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7089       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7090       vv(1)=pizda(1,1)+pizda(2,2)
7091       vv(2)=pizda(2,1)-pizda(1,2)
7092       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7093       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7094 C Cartesian derivatives.
7095       do iii=1,2
7096         do kkk=1,5
7097           do lll=1,3
7098 #ifdef MOMENT
7099             if (iii.eq.1) then
7100               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7101             else
7102               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7103             endif
7104 #endif
7105             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7106      &        auxvec(1))
7107             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7108             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7109      &        auxvec(1))
7110             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7111             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7112      &        pizda(1,1))
7113             vv(1)=pizda(1,1)+pizda(2,2)
7114             vv(2)=pizda(2,1)-pizda(1,2)
7115             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7116 #ifdef MOMENT
7117             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7118 #else
7119             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7120 #endif
7121             if (swap) then
7122               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7123             else
7124               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7125             endif
7126 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7127           enddo
7128         enddo
7129       enddo
7130       return
7131       end
7132 c----------------------------------------------------------------------------
7133       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7134       implicit real*8 (a-h,o-z)
7135       include 'DIMENSIONS'
7136       include 'sizesclu.dat'
7137       include 'COMMON.IOUNITS'
7138       include 'COMMON.CHAIN'
7139       include 'COMMON.DERIV'
7140       include 'COMMON.INTERACT'
7141       include 'COMMON.CONTACTS'
7142       include 'COMMON.TORSION'
7143       include 'COMMON.VAR'
7144       include 'COMMON.GEO'
7145       include 'COMMON.FFIELD'
7146       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7147      & auxvec1(2),auxmat1(2,2)
7148       logical swap
7149 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7150 C                                                                              C
7151 C      Parallel       Antiparallel                                             C
7152 C                                                                              C
7153 C          o             o                                                     C
7154 C         /l\   /   \   /j\                                                    C
7155 C        /   \ /     \ /   \                                                   C
7156 C       /| o |o       o| o |\                                                  C
7157 C     \ j|/k\|      \  |/k\|l                                                  C
7158 C      \ /   \       \ /   \                                                   C
7159 C       o     \       o     \                                                  C
7160 C       i             i                                                        C
7161 C                                                                              C
7162 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7163 C
7164 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7165 C           energy moment and not to the cluster cumulant.
7166 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7167       iti=itortyp(itype(i))
7168       itj=itortyp(itype(j))
7169 c      if (j.lt.nres-1) then
7170       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7171         itj1=itortyp(itype(j+1))
7172       else
7173         itj1=ntortyp+1
7174       endif
7175       itk=itortyp(itype(k))
7176 c      if (k.lt.nres-1) then
7177       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7178         itk1=itortyp(itype(k+1))
7179       else
7180         itk1=ntortyp+1
7181       endif
7182       itl=itortyp(itype(l))
7183       if (l.lt.nres-1) then
7184         itl1=itortyp(itype(l+1))
7185       else
7186         itl1=ntortyp+1
7187       endif
7188 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7189 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7190 cd     & ' itl',itl,' itl1',itl1
7191 #ifdef MOMENT
7192       if (imat.eq.1) then
7193         s1=dip(3,jj,i)*dip(3,kk,k)
7194       else
7195         s1=dip(2,jj,j)*dip(2,kk,l)
7196       endif
7197 #endif
7198       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7199       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7200       if (j.eq.l+1) then
7201         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7202         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7203       else
7204         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7205         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7206       endif
7207       call transpose2(EUg(1,1,k),auxmat(1,1))
7208       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7209       vv(1)=pizda(1,1)-pizda(2,2)
7210       vv(2)=pizda(2,1)+pizda(1,2)
7211       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7212 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7213 #ifdef MOMENT
7214       eello6_graph4=-(s1+s2+s3+s4)
7215 #else
7216       eello6_graph4=-(s2+s3+s4)
7217 #endif
7218       if (.not. calc_grad) return
7219 C Derivatives in gamma(i-1)
7220       if (i.gt.1) then
7221 #ifdef MOMENT
7222         if (imat.eq.1) then
7223           s1=dipderg(2,jj,i)*dip(3,kk,k)
7224         else
7225           s1=dipderg(4,jj,j)*dip(2,kk,l)
7226         endif
7227 #endif
7228         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7229         if (j.eq.l+1) then
7230           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7231           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7232         else
7233           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7234           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7235         endif
7236         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7237         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7238 cd          write (2,*) 'turn6 derivatives'
7239 #ifdef MOMENT
7240           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7241 #else
7242           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7243 #endif
7244         else
7245 #ifdef MOMENT
7246           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7247 #else
7248           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7249 #endif
7250         endif
7251       endif
7252 C Derivatives in gamma(k-1)
7253 #ifdef MOMENT
7254       if (imat.eq.1) then
7255         s1=dip(3,jj,i)*dipderg(2,kk,k)
7256       else
7257         s1=dip(2,jj,j)*dipderg(4,kk,l)
7258       endif
7259 #endif
7260       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7261       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7262       if (j.eq.l+1) then
7263         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7264         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7265       else
7266         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7267         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7268       endif
7269       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7270       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7271       vv(1)=pizda(1,1)-pizda(2,2)
7272       vv(2)=pizda(2,1)+pizda(1,2)
7273       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7274       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7275 #ifdef MOMENT
7276         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7277 #else
7278         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7279 #endif
7280       else
7281 #ifdef MOMENT
7282         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7283 #else
7284         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7285 #endif
7286       endif
7287 C Derivatives in gamma(j-1) or gamma(l-1)
7288       if (l.eq.j+1 .and. l.gt.1) then
7289         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7290         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7291         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7292         vv(1)=pizda(1,1)-pizda(2,2)
7293         vv(2)=pizda(2,1)+pizda(1,2)
7294         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7295         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7296       else if (j.gt.1) then
7297         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7298         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7299         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7300         vv(1)=pizda(1,1)-pizda(2,2)
7301         vv(2)=pizda(2,1)+pizda(1,2)
7302         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7303         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7304           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7305         else
7306           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7307         endif
7308       endif
7309 C Cartesian derivatives.
7310       do iii=1,2
7311         do kkk=1,5
7312           do lll=1,3
7313 #ifdef MOMENT
7314             if (iii.eq.1) then
7315               if (imat.eq.1) then
7316                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7317               else
7318                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7319               endif
7320             else
7321               if (imat.eq.1) then
7322                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7323               else
7324                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7325               endif
7326             endif
7327 #endif
7328             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7329      &        auxvec(1))
7330             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7331             if (j.eq.l+1) then
7332               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7333      &          b1(1,itj1),auxvec(1))
7334               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7335             else
7336               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7337      &          b1(1,itl1),auxvec(1))
7338               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7339             endif
7340             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7341      &        pizda(1,1))
7342             vv(1)=pizda(1,1)-pizda(2,2)
7343             vv(2)=pizda(2,1)+pizda(1,2)
7344             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7345             if (swap) then
7346               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7347 #ifdef MOMENT
7348                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7349      &             -(s1+s2+s4)
7350 #else
7351                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7352      &             -(s2+s4)
7353 #endif
7354                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7355               else
7356 #ifdef MOMENT
7357                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7358 #else
7359                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7360 #endif
7361                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7362               endif
7363             else
7364 #ifdef MOMENT
7365               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7366 #else
7367               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7368 #endif
7369               if (l.eq.j+1) then
7370                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7371               else
7372                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7373               endif
7374             endif
7375           enddo
7376         enddo
7377       enddo
7378       return
7379       end
7380 c----------------------------------------------------------------------------
7381       double precision function eello_turn6(i,jj,kk)
7382       implicit real*8 (a-h,o-z)
7383       include 'DIMENSIONS'
7384       include 'sizesclu.dat'
7385       include 'COMMON.IOUNITS'
7386       include 'COMMON.CHAIN'
7387       include 'COMMON.DERIV'
7388       include 'COMMON.INTERACT'
7389       include 'COMMON.CONTACTS'
7390       include 'COMMON.TORSION'
7391       include 'COMMON.VAR'
7392       include 'COMMON.GEO'
7393       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7394      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7395      &  ggg1(3),ggg2(3)
7396       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7397      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7398 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7399 C           the respective energy moment and not to the cluster cumulant.
7400       eello_turn6=0.0d0
7401       j=i+4
7402       k=i+1
7403       l=i+3
7404       iti=itortyp(itype(i))
7405       itk=itortyp(itype(k))
7406       itk1=itortyp(itype(k+1))
7407       itl=itortyp(itype(l))
7408       itj=itortyp(itype(j))
7409 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7410 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7411 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7412 cd        eello6=0.0d0
7413 cd        return
7414 cd      endif
7415 cd      write (iout,*)
7416 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7417 cd     &   ' and',k,l
7418 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7419       do iii=1,2
7420         do kkk=1,5
7421           do lll=1,3
7422             derx_turn(lll,kkk,iii)=0.0d0
7423           enddo
7424         enddo
7425       enddo
7426 cd      eij=1.0d0
7427 cd      ekl=1.0d0
7428 cd      ekont=1.0d0
7429       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7430 cd      eello6_5=0.0d0
7431 cd      write (2,*) 'eello6_5',eello6_5
7432 #ifdef MOMENT
7433       call transpose2(AEA(1,1,1),auxmat(1,1))
7434       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7435       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7436       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7437 #else
7438       s1 = 0.0d0
7439 #endif
7440       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7441       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7442       s2 = scalar2(b1(1,itk),vtemp1(1))
7443 #ifdef MOMENT
7444       call transpose2(AEA(1,1,2),atemp(1,1))
7445       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7446       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7447       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7448 #else
7449       s8=0.0d0
7450 #endif
7451       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7452       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7453       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7454 #ifdef MOMENT
7455       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7456       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7457       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7458       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7459       ss13 = scalar2(b1(1,itk),vtemp4(1))
7460       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7461 #else
7462       s13=0.0d0
7463 #endif
7464 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7465 c      s1=0.0d0
7466 c      s2=0.0d0
7467 c      s8=0.0d0
7468 c      s12=0.0d0
7469 c      s13=0.0d0
7470       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7471       if (calc_grad) then
7472 C Derivatives in gamma(i+2)
7473 #ifdef MOMENT
7474       call transpose2(AEA(1,1,1),auxmatd(1,1))
7475       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7476       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7477       call transpose2(AEAderg(1,1,2),atempd(1,1))
7478       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7479       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7480 #else
7481       s8d=0.0d0
7482 #endif
7483       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7484       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7485       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7486 c      s1d=0.0d0
7487 c      s2d=0.0d0
7488 c      s8d=0.0d0
7489 c      s12d=0.0d0
7490 c      s13d=0.0d0
7491       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7492 C Derivatives in gamma(i+3)
7493 #ifdef MOMENT
7494       call transpose2(AEA(1,1,1),auxmatd(1,1))
7495       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7496       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7497       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7498 #else
7499       s1d=0.0d0
7500 #endif
7501       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7502       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7503       s2d = scalar2(b1(1,itk),vtemp1d(1))
7504 #ifdef MOMENT
7505       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7506       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7507 #endif
7508       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7509 #ifdef MOMENT
7510       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7511       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7512       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7513 #else
7514       s13d=0.0d0
7515 #endif
7516 c      s1d=0.0d0
7517 c      s2d=0.0d0
7518 c      s8d=0.0d0
7519 c      s12d=0.0d0
7520 c      s13d=0.0d0
7521 #ifdef MOMENT
7522       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7523      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7524 #else
7525       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7526      &               -0.5d0*ekont*(s2d+s12d)
7527 #endif
7528 C Derivatives in gamma(i+4)
7529       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7530       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7531       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7532 #ifdef MOMENT
7533       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7534       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7535       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7536 #else
7537       s13d = 0.0d0
7538 #endif
7539 c      s1d=0.0d0
7540 c      s2d=0.0d0
7541 c      s8d=0.0d0
7542 C      s12d=0.0d0
7543 c      s13d=0.0d0
7544 #ifdef MOMENT
7545       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7546 #else
7547       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7548 #endif
7549 C Derivatives in gamma(i+5)
7550 #ifdef MOMENT
7551       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7552       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7553       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7554 #else
7555       s1d = 0.0d0
7556 #endif
7557       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7558       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7559       s2d = scalar2(b1(1,itk),vtemp1d(1))
7560 #ifdef MOMENT
7561       call transpose2(AEA(1,1,2),atempd(1,1))
7562       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7563       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7564 #else
7565       s8d = 0.0d0
7566 #endif
7567       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7568       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7569 #ifdef MOMENT
7570       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7571       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7572       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7573 #else
7574       s13d = 0.0d0
7575 #endif
7576 c      s1d=0.0d0
7577 c      s2d=0.0d0
7578 c      s8d=0.0d0
7579 c      s12d=0.0d0
7580 c      s13d=0.0d0
7581 #ifdef MOMENT
7582       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7583      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7584 #else
7585       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7586      &               -0.5d0*ekont*(s2d+s12d)
7587 #endif
7588 C Cartesian derivatives
7589       do iii=1,2
7590         do kkk=1,5
7591           do lll=1,3
7592 #ifdef MOMENT
7593             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7594             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7595             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7596 #else
7597             s1d = 0.0d0
7598 #endif
7599             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7600             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7601      &          vtemp1d(1))
7602             s2d = scalar2(b1(1,itk),vtemp1d(1))
7603 #ifdef MOMENT
7604             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7605             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7606             s8d = -(atempd(1,1)+atempd(2,2))*
7607      &           scalar2(cc(1,1,itl),vtemp2(1))
7608 #else
7609             s8d = 0.0d0
7610 #endif
7611             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7612      &           auxmatd(1,1))
7613             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7614             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7615 c      s1d=0.0d0
7616 c      s2d=0.0d0
7617 c      s8d=0.0d0
7618 c      s12d=0.0d0
7619 c      s13d=0.0d0
7620 #ifdef MOMENT
7621             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7622      &        - 0.5d0*(s1d+s2d)
7623 #else
7624             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7625      &        - 0.5d0*s2d
7626 #endif
7627 #ifdef MOMENT
7628             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7629      &        - 0.5d0*(s8d+s12d)
7630 #else
7631             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7632      &        - 0.5d0*s12d
7633 #endif
7634           enddo
7635         enddo
7636       enddo
7637 #ifdef MOMENT
7638       do kkk=1,5
7639         do lll=1,3
7640           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7641      &      achuj_tempd(1,1))
7642           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7643           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7644           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7645           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7646           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7647      &      vtemp4d(1))
7648           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7649           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7650           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7651         enddo
7652       enddo
7653 #endif
7654 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7655 cd     &  16*eel_turn6_num
7656 cd      goto 1112
7657       if (j.lt.nres-1) then
7658         j1=j+1
7659         j2=j-1
7660       else
7661         j1=j-1
7662         j2=j-2
7663       endif
7664       if (l.lt.nres-1) then
7665         l1=l+1
7666         l2=l-1
7667       else
7668         l1=l-1
7669         l2=l-2
7670       endif
7671       do ll=1,3
7672         ggg1(ll)=eel_turn6*g_contij(ll,1)
7673         ggg2(ll)=eel_turn6*g_contij(ll,2)
7674         ghalf=0.5d0*ggg1(ll)
7675 cd        ghalf=0.0d0
7676         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7677      &    +ekont*derx_turn(ll,2,1)
7678         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7679         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7680      &    +ekont*derx_turn(ll,4,1)
7681         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7682         ghalf=0.5d0*ggg2(ll)
7683 cd        ghalf=0.0d0
7684         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7685      &    +ekont*derx_turn(ll,2,2)
7686         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7687         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7688      &    +ekont*derx_turn(ll,4,2)
7689         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7690       enddo
7691 cd      goto 1112
7692       do m=i+1,j-1
7693         do ll=1,3
7694           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7695         enddo
7696       enddo
7697       do m=k+1,l-1
7698         do ll=1,3
7699           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7700         enddo
7701       enddo
7702 1112  continue
7703       do m=i+2,j2
7704         do ll=1,3
7705           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7706         enddo
7707       enddo
7708       do m=k+2,l2
7709         do ll=1,3
7710           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7711         enddo
7712       enddo
7713 cd      do iii=1,nres-3
7714 cd        write (2,*) iii,g_corr6_loc(iii)
7715 cd      enddo
7716       endif
7717       eello_turn6=ekont*eel_turn6
7718 cd      write (2,*) 'ekont',ekont
7719 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7720       return
7721       end
7722 crc-------------------------------------------------
7723       SUBROUTINE MATVEC2(A1,V1,V2)
7724       implicit real*8 (a-h,o-z)
7725       include 'DIMENSIONS'
7726       DIMENSION A1(2,2),V1(2),V2(2)
7727 c      DO 1 I=1,2
7728 c        VI=0.0
7729 c        DO 3 K=1,2
7730 c    3     VI=VI+A1(I,K)*V1(K)
7731 c        Vaux(I)=VI
7732 c    1 CONTINUE
7733
7734       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7735       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7736
7737       v2(1)=vaux1
7738       v2(2)=vaux2
7739       END
7740 C---------------------------------------
7741       SUBROUTINE MATMAT2(A1,A2,A3)
7742       implicit real*8 (a-h,o-z)
7743       include 'DIMENSIONS'
7744       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7745 c      DIMENSION AI3(2,2)
7746 c        DO  J=1,2
7747 c          A3IJ=0.0
7748 c          DO K=1,2
7749 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7750 c          enddo
7751 c          A3(I,J)=A3IJ
7752 c       enddo
7753 c      enddo
7754
7755       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7756       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7757       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7758       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7759
7760       A3(1,1)=AI3_11
7761       A3(2,1)=AI3_21
7762       A3(1,2)=AI3_12
7763       A3(2,2)=AI3_22
7764       END
7765
7766 c-------------------------------------------------------------------------
7767       double precision function scalar2(u,v)
7768       implicit none
7769       double precision u(2),v(2)
7770       double precision sc
7771       integer i
7772       scalar2=u(1)*v(1)+u(2)*v(2)
7773       return
7774       end
7775
7776 C-----------------------------------------------------------------------------
7777
7778       subroutine transpose2(a,at)
7779       implicit none
7780       double precision a(2,2),at(2,2)
7781       at(1,1)=a(1,1)
7782       at(1,2)=a(2,1)
7783       at(2,1)=a(1,2)
7784       at(2,2)=a(2,2)
7785       return
7786       end
7787 c--------------------------------------------------------------------------
7788       subroutine transpose(n,a,at)
7789       implicit none
7790       integer n,i,j
7791       double precision a(n,n),at(n,n)
7792       do i=1,n
7793         do j=1,n
7794           at(j,i)=a(i,j)
7795         enddo
7796       enddo
7797       return
7798       end
7799 C---------------------------------------------------------------------------
7800       subroutine prodmat3(a1,a2,kk,transp,prod)
7801       implicit none
7802       integer i,j
7803       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7804       logical transp
7805 crc      double precision auxmat(2,2),prod_(2,2)
7806
7807       if (transp) then
7808 crc        call transpose2(kk(1,1),auxmat(1,1))
7809 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7810 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7811
7812            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7813      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7814            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7815      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7816            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7817      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7818            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7819      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7820
7821       else
7822 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7823 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7824
7825            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7826      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7827            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7828      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7829            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7830      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7831            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7832      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7833
7834       endif
7835 c      call transpose2(a2(1,1),a2t(1,1))
7836
7837 crc      print *,transp
7838 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7839 crc      print *,((prod(i,j),i=1,2),j=1,2)
7840
7841       return
7842       end
7843 C-----------------------------------------------------------------------------
7844       double precision function scalar(u,v)
7845       implicit none
7846       double precision u(3),v(3)
7847       double precision sc
7848       integer i
7849       sc=0.0d0
7850       do i=1,3
7851         sc=sc+u(i)*v(i)
7852       enddo
7853       scalar=sc
7854       return
7855       end
7856 C-----------------------------------------------------------------------
7857       double precision function sscale(r)
7858       double precision r,gamm
7859       include "COMMON.SPLITELE"
7860       if(r.lt.r_cut-rlamb) then
7861         sscale=1.0d0
7862       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7863         gamm=(r-(r_cut-rlamb))/rlamb
7864         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
7865       else
7866         sscale=0d0
7867       endif
7868       return
7869       end
7870 C-----------------------------------------------------------------------
7871 C-----------------------------------------------------------------------
7872       double precision function sscagrad(r)
7873       double precision r,gamm
7874       include "COMMON.SPLITELE"
7875       if(r.lt.r_cut-rlamb) then
7876         sscagrad=0.0d0
7877       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7878         gamm=(r-(r_cut-rlamb))/rlamb
7879         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
7880       else
7881         sscagrad=0.0d0
7882       endif
7883       return
7884       end
7885 C-----------------------------------------------------------------------
7886