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

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