source/wham/src-M/energy_p_new.F

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