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       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         dethetai=0.0d0
3429         dephii=0.0d0
3430         dephii1=0.0d0
3431         theti2=0.5d0*theta(i)
3432         ityp2=ithetyp(iabs(itype(i-1)))
3433         do k=1,nntheterm
3434           coskt(k)=dcos(k*theti2)
3435           sinkt(k)=dsin(k*theti2)
3436         enddo
3437         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
3438 #ifdef OSF
3439           phii=phi(i)
3440           if (phii.ne.phii) phii=150.0
3441 #else
3442           phii=phi(i)
3443 #endif
3444           ityp1=ithetyp(iabs(itype(i-2)))
3445           do k=1,nsingle
3446             cosph1(k)=dcos(k*phii)
3447             sinph1(k)=dsin(k*phii)
3448           enddo
3449         else
3450           phii=0.0d0
3451           ityp1=nthetyp+1
3452           do k=1,nsingle
3453             cosph1(k)=0.0d0
3454             sinph1(k)=0.0d0
3455           enddo
3456         endif
3457         if (i.lt.nres .and. itype(i).ne.ntyp1) then
3458 #ifdef OSF
3459           phii1=phi(i+1)
3460           if (phii1.ne.phii1) phii1=150.0
3461           phii1=pinorm(phii1)
3462 #else
3463           phii1=phi(i+1)
3464 #endif
3465           ityp3=ithetyp(iabs(itype(i)))
3466           do k=1,nsingle
3467             cosph2(k)=dcos(k*phii1)
3468             sinph2(k)=dsin(k*phii1)
3469           enddo
3470         else
3471           phii1=0.0d0
3472           ityp3=nthetyp+1
3473           do k=1,nsingle
3474             cosph2(k)=0.0d0
3475             sinph2(k)=0.0d0
3476           enddo
3477         endif
3478 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3479 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3480 c        call flush(iout)
3481         ethetai=aa0thet(ityp1,ityp2,ityp3)
3482         do k=1,ndouble
3483           do l=1,k-1
3484             ccl=cosph1(l)*cosph2(k-l)
3485             ssl=sinph1(l)*sinph2(k-l)
3486             scl=sinph1(l)*cosph2(k-l)
3487             csl=cosph1(l)*sinph2(k-l)
3488             cosph1ph2(l,k)=ccl-ssl
3489             cosph1ph2(k,l)=ccl+ssl
3490             sinph1ph2(l,k)=scl+csl
3491             sinph1ph2(k,l)=scl-csl
3492           enddo
3493         enddo
3494         if (lprn) then
3495         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3496      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3497         write (iout,*) "coskt and sinkt"
3498         do k=1,nntheterm
3499           write (iout,*) k,coskt(k),sinkt(k)
3500         enddo
3501         endif
3502         do k=1,ntheterm
3503           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3504           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3505      &      *coskt(k)
3506           if (lprn)
3507      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3508      &     " ethetai",ethetai
3509         enddo
3510         if (lprn) then
3511         write (iout,*) "cosph and sinph"
3512         do k=1,nsingle
3513           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3514         enddo
3515         write (iout,*) "cosph1ph2 and sinph2ph2"
3516         do k=2,ndouble
3517           do l=1,k-1
3518             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3519      &         sinph1ph2(l,k),sinph1ph2(k,l)
3520           enddo
3521         enddo
3522         write(iout,*) "ethetai",ethetai
3523         endif
3524         do m=1,ntheterm2
3525           do k=1,nsingle
3526             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3527      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3528      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3529      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3530             ethetai=ethetai+sinkt(m)*aux
3531             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3532             dephii=dephii+k*sinkt(m)*(
3533      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3534      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3535             dephii1=dephii1+k*sinkt(m)*(
3536      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3537      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3538             if (lprn)
3539      &      write (iout,*) "m",m," k",k," bbthet",
3540      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3541      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3542      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3543      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3544           enddo
3545         enddo
3546         if (lprn)
3547      &  write(iout,*) "ethetai",ethetai
3548         do m=1,ntheterm3
3549           do k=2,ndouble
3550             do l=1,k-1
3551               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3552      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3553      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3554      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3555               ethetai=ethetai+sinkt(m)*aux
3556               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3557               dephii=dephii+l*sinkt(m)*(
3558      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3559      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3560      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3561      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3562               dephii1=dephii1+(k-l)*sinkt(m)*(
3563      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3564      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3565      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3566      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3567               if (lprn) then
3568               write (iout,*) "m",m," k",k," l",l," ffthet",
3569      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3570      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3571      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3572      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3573               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3574      &            cosph1ph2(k,l)*sinkt(m),
3575      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3576               endif
3577             enddo
3578           enddo
3579         enddo
3580 10      continue
3581         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3582      &   i,theta(i)*rad2deg,phii*rad2deg,
3583      &   phii1*rad2deg,ethetai
3584         etheta=etheta+ethetai
3585         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3586         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3587         gloc(nphi+i-2,icg)=wang*dethetai
3588       enddo
3589       return
3590       end
3591 #endif
3592 #ifdef CRYST_SC
3593 c-----------------------------------------------------------------------------
3594       subroutine esc(escloc)
3595 C Calculate the local energy of a side chain and its derivatives in the
3596 C corresponding virtual-bond valence angles THETA and the spherical angles
3597 C ALPHA and OMEGA.
3598       implicit real*8 (a-h,o-z)
3599       include 'DIMENSIONS'
3600       include 'DIMENSIONS.ZSCOPT'
3601       include 'COMMON.GEO'
3602       include 'COMMON.LOCAL'
3603       include 'COMMON.VAR'
3604       include 'COMMON.INTERACT'
3605       include 'COMMON.DERIV'
3606       include 'COMMON.CHAIN'
3607       include 'COMMON.IOUNITS'
3608       include 'COMMON.NAMES'
3609       include 'COMMON.FFIELD'
3610       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3611      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3612       common /sccalc/ time11,time12,time112,theti,it,nlobit
3613       delta=0.02d0*pi
3614       escloc=0.0D0
3615 c     write (iout,'(a)') 'ESC'
3616       do i=loc_start,loc_end
3617         it=itype(i)
3618         if (it.eq.ntyp1) cycle
3619         if (it.eq.10) goto 1
3620         nlobit=nlob(iabs(it))
3621 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3622 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3623         theti=theta(i+1)-pipol
3624         x(1)=dtan(theti)
3625         x(2)=alph(i)
3626         x(3)=omeg(i)
3627 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3628
3629         if (x(2).gt.pi-delta) then
3630           xtemp(1)=x(1)
3631           xtemp(2)=pi-delta
3632           xtemp(3)=x(3)
3633           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3634           xtemp(2)=pi
3635           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3636           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3637      &        escloci,dersc(2))
3638           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3639      &        ddersc0(1),dersc(1))
3640           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3641      &        ddersc0(3),dersc(3))
3642           xtemp(2)=pi-delta
3643           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3644           xtemp(2)=pi
3645           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3646           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3647      &            dersc0(2),esclocbi,dersc02)
3648           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3649      &            dersc12,dersc01)
3650           call splinthet(x(2),0.5d0*delta,ss,ssd)
3651           dersc0(1)=dersc01
3652           dersc0(2)=dersc02
3653           dersc0(3)=0.0d0
3654           do k=1,3
3655             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3656           enddo
3657           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3658 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3659 c    &             esclocbi,ss,ssd
3660           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3661 c         escloci=esclocbi
3662 c         write (iout,*) escloci
3663         else if (x(2).lt.delta) then
3664           xtemp(1)=x(1)
3665           xtemp(2)=delta
3666           xtemp(3)=x(3)
3667           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3668           xtemp(2)=0.0d0
3669           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3670           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3671      &        escloci,dersc(2))
3672           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3673      &        ddersc0(1),dersc(1))
3674           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3675      &        ddersc0(3),dersc(3))
3676           xtemp(2)=delta
3677           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3678           xtemp(2)=0.0d0
3679           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3680           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3681      &            dersc0(2),esclocbi,dersc02)
3682           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3683      &            dersc12,dersc01)
3684           dersc0(1)=dersc01
3685           dersc0(2)=dersc02
3686           dersc0(3)=0.0d0
3687           call splinthet(x(2),0.5d0*delta,ss,ssd)
3688           do k=1,3
3689             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3690           enddo
3691           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3692 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3693 c    &             esclocbi,ss,ssd
3694           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3695 c         write (iout,*) escloci
3696         else
3697           call enesc(x,escloci,dersc,ddummy,.false.)
3698         endif
3699
3700         escloc=escloc+escloci
3701 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3702
3703         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3704      &   wscloc*dersc(1)
3705         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3706         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3707     1   continue
3708       enddo
3709       return
3710       end
3711 C---------------------------------------------------------------------------
3712       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3713       implicit real*8 (a-h,o-z)
3714       include 'DIMENSIONS'
3715       include 'COMMON.GEO'
3716       include 'COMMON.LOCAL'
3717       include 'COMMON.IOUNITS'
3718       common /sccalc/ time11,time12,time112,theti,it,nlobit
3719       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3720       double precision contr(maxlob,-1:1)
3721       logical mixed
3722 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3723         escloc_i=0.0D0
3724         do j=1,3
3725           dersc(j)=0.0D0
3726           if (mixed) ddersc(j)=0.0d0
3727         enddo
3728         x3=x(3)
3729
3730 C Because of periodicity of the dependence of the SC energy in omega we have
3731 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3732 C To avoid underflows, first compute & store the exponents.
3733
3734         do iii=-1,1
3735
3736           x(3)=x3+iii*dwapi
3737
3738           do j=1,nlobit
3739             do k=1,3
3740               z(k)=x(k)-censc(k,j,it)
3741             enddo
3742             do k=1,3
3743               Axk=0.0D0
3744               do l=1,3
3745                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3746               enddo
3747               Ax(k,j,iii)=Axk
3748             enddo
3749             expfac=0.0D0
3750             do k=1,3
3751               expfac=expfac+Ax(k,j,iii)*z(k)
3752             enddo
3753             contr(j,iii)=expfac
3754           enddo ! j
3755
3756         enddo ! iii
3757
3758         x(3)=x3
3759 C As in the case of ebend, we want to avoid underflows in exponentiation and
3760 C subsequent NaNs and INFs in energy calculation.
3761 C Find the largest exponent
3762         emin=contr(1,-1)
3763         do iii=-1,1
3764           do j=1,nlobit
3765             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3766           enddo
3767         enddo
3768         emin=0.5D0*emin
3769 cd      print *,'it=',it,' emin=',emin
3770
3771 C Compute the contribution to SC energy and derivatives
3772         do iii=-1,1
3773
3774           do j=1,nlobit
3775             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
3776 cd          print *,'j=',j,' expfac=',expfac
3777             escloc_i=escloc_i+expfac
3778             do k=1,3
3779               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3780             enddo
3781             if (mixed) then
3782               do k=1,3,2
3783                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3784      &            +gaussc(k,2,j,it))*expfac
3785               enddo
3786             endif
3787           enddo
3788
3789         enddo ! iii
3790
3791         dersc(1)=dersc(1)/cos(theti)**2
3792         ddersc(1)=ddersc(1)/cos(theti)**2
3793         ddersc(3)=ddersc(3)
3794
3795         escloci=-(dlog(escloc_i)-emin)
3796         do j=1,3
3797           dersc(j)=dersc(j)/escloc_i
3798         enddo
3799         if (mixed) then
3800           do j=1,3,2
3801             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3802           enddo
3803         endif
3804       return
3805       end
3806 C------------------------------------------------------------------------------
3807       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3808       implicit real*8 (a-h,o-z)
3809       include 'DIMENSIONS'
3810       include 'COMMON.GEO'
3811       include 'COMMON.LOCAL'
3812       include 'COMMON.IOUNITS'
3813       common /sccalc/ time11,time12,time112,theti,it,nlobit
3814       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3815       double precision contr(maxlob)
3816       logical mixed
3817
3818       escloc_i=0.0D0
3819
3820       do j=1,3
3821         dersc(j)=0.0D0
3822       enddo
3823
3824       do j=1,nlobit
3825         do k=1,2
3826           z(k)=x(k)-censc(k,j,it)
3827         enddo
3828         z(3)=dwapi
3829         do k=1,3
3830           Axk=0.0D0
3831           do l=1,3
3832             Axk=Axk+gaussc(l,k,j,it)*z(l)
3833           enddo
3834           Ax(k,j)=Axk
3835         enddo
3836         expfac=0.0D0
3837         do k=1,3
3838           expfac=expfac+Ax(k,j)*z(k)
3839         enddo
3840         contr(j)=expfac
3841       enddo ! j
3842
3843 C As in the case of ebend, we want to avoid underflows in exponentiation and
3844 C subsequent NaNs and INFs in energy calculation.
3845 C Find the largest exponent
3846       emin=contr(1)
3847       do j=1,nlobit
3848         if (emin.gt.contr(j)) emin=contr(j)
3849       enddo
3850       emin=0.5D0*emin
3851
3852 C Compute the contribution to SC energy and derivatives
3853
3854       dersc12=0.0d0
3855       do j=1,nlobit
3856         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
3857         escloc_i=escloc_i+expfac
3858         do k=1,2
3859           dersc(k)=dersc(k)+Ax(k,j)*expfac
3860         enddo
3861         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3862      &            +gaussc(1,2,j,it))*expfac
3863         dersc(3)=0.0d0
3864       enddo
3865
3866       dersc(1)=dersc(1)/cos(theti)**2
3867       dersc12=dersc12/cos(theti)**2
3868       escloci=-(dlog(escloc_i)-emin)
3869       do j=1,2
3870         dersc(j)=dersc(j)/escloc_i
3871       enddo
3872       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
3873       return
3874       end
3875 #else
3876 c----------------------------------------------------------------------------------
3877       subroutine esc(escloc)
3878 C Calculate the local energy of a side chain and its derivatives in the
3879 C corresponding virtual-bond valence angles THETA and the spherical angles
3880 C ALPHA and OMEGA derived from AM1 all-atom calculations.
3881 C added by Urszula Kozlowska. 07/11/2007
3882 C
3883       implicit real*8 (a-h,o-z)
3884       include 'DIMENSIONS'
3885       include 'DIMENSIONS.ZSCOPT'
3886       include 'COMMON.GEO'
3887       include 'COMMON.LOCAL'
3888       include 'COMMON.VAR'
3889       include 'COMMON.SCROT'
3890       include 'COMMON.INTERACT'
3891       include 'COMMON.DERIV'
3892       include 'COMMON.CHAIN'
3893       include 'COMMON.IOUNITS'
3894       include 'COMMON.NAMES'
3895       include 'COMMON.FFIELD'
3896       include 'COMMON.CONTROL'
3897       include 'COMMON.VECTORS'
3898       double precision x_prime(3),y_prime(3),z_prime(3)
3899      &    , sumene,dsc_i,dp2_i,x(65),
3900      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
3901      &    de_dxx,de_dyy,de_dzz,de_dt
3902       double precision s1_t,s1_6_t,s2_t,s2_6_t
3903       double precision
3904      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
3905      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
3906      & dt_dCi(3),dt_dCi1(3)
3907       common /sccalc/ time11,time12,time112,theti,it,nlobit
3908       delta=0.02d0*pi
3909       escloc=0.0D0
3910       do i=loc_start,loc_end
3911         if (itype(i).eq.ntyp1) cycle
3912         costtab(i+1) =dcos(theta(i+1))
3913         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
3914         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
3915         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
3916         cosfac2=0.5d0/(1.0d0+costtab(i+1))
3917         cosfac=dsqrt(cosfac2)
3918         sinfac2=0.5d0/(1.0d0-costtab(i+1))
3919         sinfac=dsqrt(sinfac2)
3920         it=iabs(itype(i))
3921         if (it.eq.10) goto 1
3922 c
3923 C  Compute the axes of tghe local cartesian coordinates system; store in
3924 c   x_prime, y_prime and z_prime
3925 c
3926         do j=1,3
3927           x_prime(j) = 0.00
3928           y_prime(j) = 0.00
3929           z_prime(j) = 0.00
3930         enddo
3931 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
3932 C     &   dc_norm(3,i+nres)
3933         do j = 1,3
3934           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
3935           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
3936         enddo
3937         do j = 1,3
3938           z_prime(j) = -uz(j,i-1)
3939         enddo
3940 c       write (2,*) "i",i
3941 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
3942 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
3943 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
3944 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
3945 c      & " xy",scalar(x_prime(1),y_prime(1)),
3946 c      & " xz",scalar(x_prime(1),z_prime(1)),
3947 c      & " yy",scalar(y_prime(1),y_prime(1)),
3948 c      & " yz",scalar(y_prime(1),z_prime(1)),
3949 c      & " zz",scalar(z_prime(1),z_prime(1))
3950 c
3951 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
3952 C to local coordinate system. Store in xx, yy, zz.
3953 c
3954         xx=0.0d0
3955         yy=0.0d0
3956         zz=0.0d0
3957         do j = 1,3
3958           xx = xx + x_prime(j)*dc_norm(j,i+nres)
3959           yy = yy + y_prime(j)*dc_norm(j,i+nres)
3960           zz = zz + dsign(1.0,itype(i))*z_prime(j)*dc_norm(j,i+nres)
3961         enddo
3962
3963         xxtab(i)=xx
3964         yytab(i)=yy
3965         zztab(i)=zz
3966 C
3967 C Compute the energy of the ith side cbain
3968 C
3969 c        write (2,*) "xx",xx," yy",yy," zz",zz
3970         it=iabs(itype(i))
3971         do j = 1,65
3972           x(j) = sc_parmin(j,it)
3973         enddo
3974 #ifdef CHECK_COORD
3975 Cc diagnostics - remove later
3976         xx1 = dcos(alph(2))
3977         yy1 = dsin(alph(2))*dcos(omeg(2))
3978         zz1 = -dsign(1.0,itype(i))*dsin(alph(2))*dsin(omeg(2))
3979         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
3980      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
3981      &    xx1,yy1,zz1
3982 C,"  --- ", xx_w,yy_w,zz_w
3983 c end diagnostics
3984 #endif
3985         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
3986      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
3987      &   + x(10)*yy*zz
3988         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
3989      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
3990      & + x(20)*yy*zz
3991         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
3992      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
3993      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
3994      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
3995      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
3996      &  +x(40)*xx*yy*zz
3997         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
3998      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
3999      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4000      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4001      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4002      &  +x(60)*xx*yy*zz
4003         dsc_i   = 0.743d0+x(61)
4004         dp2_i   = 1.9d0+x(62)
4005         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4006      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4007         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4008      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4009         s1=(1+x(63))/(0.1d0 + dscp1)
4010         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4011         s2=(1+x(65))/(0.1d0 + dscp2)
4012         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4013         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4014      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4015 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4016 c     &   sumene4,
4017 c     &   dscp1,dscp2,sumene
4018 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4019         escloc = escloc + sumene
4020 c        write (2,*) "escloc",escloc
4021         if (.not. calc_grad) goto 1
4022 #ifdef DEBUG
4023 C
4024 C This section to check the numerical derivatives of the energy of ith side
4025 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4026 C #define DEBUG in the code to turn it on.
4027 C
4028         write (2,*) "sumene               =",sumene
4029         aincr=1.0d-7
4030         xxsave=xx
4031         xx=xx+aincr
4032         write (2,*) xx,yy,zz
4033         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4034         de_dxx_num=(sumenep-sumene)/aincr
4035         xx=xxsave
4036         write (2,*) "xx+ sumene from enesc=",sumenep
4037         yysave=yy
4038         yy=yy+aincr
4039         write (2,*) xx,yy,zz
4040         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4041         de_dyy_num=(sumenep-sumene)/aincr
4042         yy=yysave
4043         write (2,*) "yy+ sumene from enesc=",sumenep
4044         zzsave=zz
4045         zz=zz+aincr
4046         write (2,*) xx,yy,zz
4047         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4048         de_dzz_num=(sumenep-sumene)/aincr
4049         zz=zzsave
4050         write (2,*) "zz+ sumene from enesc=",sumenep
4051         costsave=cost2tab(i+1)
4052         sintsave=sint2tab(i+1)
4053         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4054         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4055         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4056         de_dt_num=(sumenep-sumene)/aincr
4057         write (2,*) " t+ sumene from enesc=",sumenep
4058         cost2tab(i+1)=costsave
4059         sint2tab(i+1)=sintsave
4060 C End of diagnostics section.
4061 #endif
4062 C
4063 C Compute the gradient of esc
4064 C
4065         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4066         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4067         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4068         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4069         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4070         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4071         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4072         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4073         pom1=(sumene3*sint2tab(i+1)+sumene1)
4074      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4075         pom2=(sumene4*cost2tab(i+1)+sumene2)
4076      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4077         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4078         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4079      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4080      &  +x(40)*yy*zz
4081         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4082         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4083      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4084      &  +x(60)*yy*zz
4085         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4086      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4087      &        +(pom1+pom2)*pom_dx
4088 #ifdef DEBUG
4089         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4090 #endif
4091 C
4092         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4093         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4094      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4095      &  +x(40)*xx*zz
4096         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4097         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4098      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4099      &  +x(59)*zz**2 +x(60)*xx*zz
4100         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4101      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4102      &        +(pom1-pom2)*pom_dy
4103 #ifdef DEBUG
4104         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4105 #endif
4106 C
4107         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4108      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4109      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4110      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4111      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4112      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4113      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4114      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4115 #ifdef DEBUG
4116         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4117 #endif
4118 C
4119         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4120      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4121      &  +pom1*pom_dt1+pom2*pom_dt2
4122 #ifdef DEBUG
4123         write(2,*), "de_dt = ", de_dt,de_dt_num
4124 #endif
4125 c
4126 C
4127        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4128        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4129        cosfac2xx=cosfac2*xx
4130        sinfac2yy=sinfac2*yy
4131        do k = 1,3
4132          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4133      &      vbld_inv(i+1)
4134          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4135      &      vbld_inv(i)
4136          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4137          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4138 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4139 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4140 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4141 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4142          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4143          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4144          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4145          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4146          dZZ_Ci1(k)=0.0d0
4147          dZZ_Ci(k)=0.0d0
4148          do j=1,3
4149            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4150            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4151          enddo
4152
4153          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4154          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4155          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4156 c
4157          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4158          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4159        enddo
4160
4161        do k=1,3
4162          dXX_Ctab(k,i)=dXX_Ci(k)
4163          dXX_C1tab(k,i)=dXX_Ci1(k)
4164          dYY_Ctab(k,i)=dYY_Ci(k)
4165          dYY_C1tab(k,i)=dYY_Ci1(k)
4166          dZZ_Ctab(k,i)=dZZ_Ci(k)
4167          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4168          dXX_XYZtab(k,i)=dXX_XYZ(k)
4169          dYY_XYZtab(k,i)=dYY_XYZ(k)
4170          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4171        enddo
4172
4173        do k = 1,3
4174 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4175 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4176 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4177 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4178 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4179 c     &    dt_dci(k)
4180 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4181 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4182          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4183      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4184          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4185      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4186          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4187      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4188        enddo
4189 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4190 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4191
4192 C to check gradient call subroutine check_grad
4193
4194     1 continue
4195       enddo
4196       return
4197       end
4198 #endif
4199 c------------------------------------------------------------------------------
4200       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4201 C
4202 C This procedure calculates two-body contact function g(rij) and its derivative:
4203 C
4204 C           eps0ij                                     !       x < -1
4205 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4206 C            0                                         !       x > 1
4207 C
4208 C where x=(rij-r0ij)/delta
4209 C
4210 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4211 C
4212       implicit none
4213       double precision rij,r0ij,eps0ij,fcont,fprimcont
4214       double precision x,x2,x4,delta
4215 c     delta=0.02D0*r0ij
4216 c      delta=0.2D0*r0ij
4217       x=(rij-r0ij)/delta
4218       if (x.lt.-1.0D0) then
4219         fcont=eps0ij
4220         fprimcont=0.0D0
4221       else if (x.le.1.0D0) then
4222         x2=x*x
4223         x4=x2*x2
4224         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4225         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4226       else
4227         fcont=0.0D0
4228         fprimcont=0.0D0
4229       endif
4230       return
4231       end
4232 c------------------------------------------------------------------------------
4233       subroutine splinthet(theti,delta,ss,ssder)
4234       implicit real*8 (a-h,o-z)
4235       include 'DIMENSIONS'
4236       include 'DIMENSIONS.ZSCOPT'
4237       include 'COMMON.VAR'
4238       include 'COMMON.GEO'
4239       thetup=pi-delta
4240       thetlow=delta
4241       if (theti.gt.pipol) then
4242         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4243       else
4244         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4245         ssder=-ssder
4246       endif
4247       return
4248       end
4249 c------------------------------------------------------------------------------
4250       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4251       implicit none
4252       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4253       double precision ksi,ksi2,ksi3,a1,a2,a3
4254       a1=fprim0*delta/(f1-f0)
4255       a2=3.0d0-2.0d0*a1
4256       a3=a1-2.0d0
4257       ksi=(x-x0)/delta
4258       ksi2=ksi*ksi
4259       ksi3=ksi2*ksi
4260       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4261       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4262       return
4263       end
4264 c------------------------------------------------------------------------------
4265       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4266       implicit none
4267       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4268       double precision ksi,ksi2,ksi3,a1,a2,a3
4269       ksi=(x-x0)/delta
4270       ksi2=ksi*ksi
4271       ksi3=ksi2*ksi
4272       a1=fprim0x*delta
4273       a2=3*(f1x-f0x)-2*fprim0x*delta
4274       a3=fprim0x*delta-2*(f1x-f0x)
4275       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4276       return
4277       end
4278 C-----------------------------------------------------------------------------
4279 #ifdef CRYST_TOR
4280 C-----------------------------------------------------------------------------
4281       subroutine etor(etors,edihcnstr,fact)
4282       implicit real*8 (a-h,o-z)
4283       include 'DIMENSIONS'
4284       include 'DIMENSIONS.ZSCOPT'
4285       include 'COMMON.VAR'
4286       include 'COMMON.GEO'
4287       include 'COMMON.LOCAL'
4288       include 'COMMON.TORSION'
4289       include 'COMMON.INTERACT'
4290       include 'COMMON.DERIV'
4291       include 'COMMON.CHAIN'
4292       include 'COMMON.NAMES'
4293       include 'COMMON.IOUNITS'
4294       include 'COMMON.FFIELD'
4295       include 'COMMON.TORCNSTR'
4296       logical lprn
4297 C Set lprn=.true. for debugging
4298       lprn=.false.
4299 c      lprn=.true.
4300       etors=0.0D0
4301       do i=iphi_start,iphi_end
4302         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4303      &      .or. itype(i).eq.ntyp1) cycle
4304         itori=itortyp(itype(i-2))
4305         itori1=itortyp(itype(i-1))
4306         phii=phi(i)
4307         gloci=0.0D0
4308 C Proline-Proline pair is a special case...
4309         if (itori.eq.3 .and. itori1.eq.3) then
4310           if (phii.gt.-dwapi3) then
4311             cosphi=dcos(3*phii)
4312             fac=1.0D0/(1.0D0-cosphi)
4313             etorsi=v1(1,3,3)*fac
4314             etorsi=etorsi+etorsi
4315             etors=etors+etorsi-v1(1,3,3)
4316             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4317           endif
4318           do j=1,3
4319             v1ij=v1(j+1,itori,itori1)
4320             v2ij=v2(j+1,itori,itori1)
4321             cosphi=dcos(j*phii)
4322             sinphi=dsin(j*phii)
4323             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4324             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4325           enddo
4326         else
4327           do j=1,nterm_old
4328             v1ij=v1(j,itori,itori1)
4329             v2ij=v2(j,itori,itori1)
4330             cosphi=dcos(j*phii)
4331             sinphi=dsin(j*phii)
4332             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4333             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4334           enddo
4335         endif
4336         if (lprn)
4337      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4338      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4339      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4340         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4341 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4342       enddo
4343 ! 6/20/98 - dihedral angle constraints
4344       edihcnstr=0.0d0
4345       do i=1,ndih_constr
4346         itori=idih_constr(i)
4347         phii=phi(itori)
4348         difi=phii-phi0(i)
4349         if (difi.gt.drange(i)) then
4350           difi=difi-drange(i)
4351           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4352           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4353         else if (difi.lt.-drange(i)) then
4354           difi=difi+drange(i)
4355           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4356           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4357         endif
4358 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4359 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4360       enddo
4361 !      write (iout,*) 'edihcnstr',edihcnstr
4362       return
4363       end
4364 c------------------------------------------------------------------------------
4365 #else
4366       subroutine etor(etors,edihcnstr,fact)
4367       implicit real*8 (a-h,o-z)
4368       include 'DIMENSIONS'
4369       include 'DIMENSIONS.ZSCOPT'
4370       include 'COMMON.VAR'
4371       include 'COMMON.GEO'
4372       include 'COMMON.LOCAL'
4373       include 'COMMON.TORSION'
4374       include 'COMMON.INTERACT'
4375       include 'COMMON.DERIV'
4376       include 'COMMON.CHAIN'
4377       include 'COMMON.NAMES'
4378       include 'COMMON.IOUNITS'
4379       include 'COMMON.FFIELD'
4380       include 'COMMON.TORCNSTR'
4381       logical lprn
4382 C Set lprn=.true. for debugging
4383       lprn=.false.
4384 c      lprn=.true.
4385       etors=0.0D0
4386       do i=iphi_start,iphi_end
4387         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4388      &       .or. itype(i).eq.ntyp1) cycle
4389         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4390          if (iabs(itype(i)).eq.20) then
4391          iblock=2
4392          else
4393          iblock=1
4394          endif
4395         itori=itortyp(itype(i-2))
4396         itori1=itortyp(itype(i-1))
4397         phii=phi(i)
4398         gloci=0.0D0
4399 C Regular cosine and sine terms
4400         do j=1,nterm(itori,itori1,iblock)
4401           v1ij=v1(j,itori,itori1,iblock)
4402           v2ij=v2(j,itori,itori1,iblock)
4403           cosphi=dcos(j*phii)
4404           sinphi=dsin(j*phii)
4405           etors=etors+v1ij*cosphi+v2ij*sinphi
4406           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4407         enddo
4408 C Lorentz terms
4409 C                         v1
4410 C  E = SUM ----------------------------------- - v1
4411 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4412 C
4413         cosphi=dcos(0.5d0*phii)
4414         sinphi=dsin(0.5d0*phii)
4415         do j=1,nlor(itori,itori1,iblock)
4416           vl1ij=vlor1(j,itori,itori1)
4417           vl2ij=vlor2(j,itori,itori1)
4418           vl3ij=vlor3(j,itori,itori1)
4419           pom=vl2ij*cosphi+vl3ij*sinphi
4420           pom1=1.0d0/(pom*pom+1.0d0)
4421           etors=etors+vl1ij*pom1
4422 c          if (energy_dec) etors_ii=etors_ii+
4423 c     &                vl1ij*pom1
4424           pom=-pom*pom1*pom1
4425           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4426         enddo
4427 C Subtract the constant term
4428         etors=etors-v0(itori,itori1,iblock)
4429         if (lprn)
4430      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4431      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4432      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4433         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4434 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4435  1215   continue
4436       enddo
4437 ! 6/20/98 - dihedral angle constraints
4438       edihcnstr=0.0d0
4439       do i=1,ndih_constr
4440         itori=idih_constr(i)
4441         phii=phi(itori)
4442         difi=pinorm(phii-phi0(i))
4443         edihi=0.0d0
4444         if (difi.gt.drange(i)) then
4445           difi=difi-drange(i)
4446           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4447           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4448           edihi=0.25d0*ftors*difi**4
4449         else if (difi.lt.-drange(i)) then
4450           difi=difi+drange(i)
4451           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4452           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4453           edihi=0.25d0*ftors*difi**4
4454         else
4455           difi=0.0d0
4456         endif
4457 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4458 c     &    drange(i),edihi
4459 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4460 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4461       enddo
4462 !      write (iout,*) 'edihcnstr',edihcnstr
4463       return
4464       end
4465 c----------------------------------------------------------------------------
4466       subroutine etor_d(etors_d,fact2)
4467 C 6/23/01 Compute double torsional energy
4468       implicit real*8 (a-h,o-z)
4469       include 'DIMENSIONS'
4470       include 'DIMENSIONS.ZSCOPT'
4471       include 'COMMON.VAR'
4472       include 'COMMON.GEO'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.TORSION'
4475       include 'COMMON.INTERACT'
4476       include 'COMMON.DERIV'
4477       include 'COMMON.CHAIN'
4478       include 'COMMON.NAMES'
4479       include 'COMMON.IOUNITS'
4480       include 'COMMON.FFIELD'
4481       include 'COMMON.TORCNSTR'
4482       logical lprn
4483 C Set lprn=.true. for debugging
4484       lprn=.false.
4485 c     lprn=.true.
4486       etors_d=0.0D0
4487       do i=iphi_start,iphi_end-1
4488         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4489      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4490         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4491      &     goto 1215
4492         itori=itortyp(itype(i-2))
4493         itori1=itortyp(itype(i-1))
4494         itori2=itortyp(itype(i))
4495         phii=phi(i)
4496         phii1=phi(i+1)
4497         gloci1=0.0D0
4498         gloci2=0.0D0
4499         iblock=1
4500         if (iabs(itype(i+1)).eq.20) iblock=2
4501 C Regular cosine and sine terms
4502         do j=1,ntermd_1(itori,itori1,itori2,iblock)
4503           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4504           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4505           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4506           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4507           cosphi1=dcos(j*phii)
4508           sinphi1=dsin(j*phii)
4509           cosphi2=dcos(j*phii1)
4510           sinphi2=dsin(j*phii1)
4511           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4512      &     v2cij*cosphi2+v2sij*sinphi2
4513           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4514           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4515         enddo
4516         do k=2,ntermd_2(itori,itori1,itori2,iblock)
4517           do l=1,k-1
4518             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
4519             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
4520             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
4521             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
4522             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4523             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4524             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4525             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4526             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4527      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4528             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4529      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4530             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4531      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4532           enddo
4533         enddo
4534         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4535         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4536  1215   continue
4537       enddo
4538       return
4539       end
4540 #endif
4541 c------------------------------------------------------------------------------
4542       subroutine eback_sc_corr(esccor)
4543 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4544 c        conformational states; temporarily implemented as differences
4545 c        between UNRES torsional potentials (dependent on three types of
4546 c        residues) and the torsional potentials dependent on all 20 types
4547 c        of residues computed from AM1 energy surfaces of terminally-blocked
4548 c        amino-acid residues.
4549       implicit real*8 (a-h,o-z)
4550       include 'DIMENSIONS'
4551       include 'DIMENSIONS.ZSCOPT'
4552       include 'COMMON.VAR'
4553       include 'COMMON.GEO'
4554       include 'COMMON.LOCAL'
4555       include 'COMMON.TORSION'
4556       include 'COMMON.SCCOR'
4557       include 'COMMON.INTERACT'
4558       include 'COMMON.DERIV'
4559       include 'COMMON.CHAIN'
4560       include 'COMMON.NAMES'
4561       include 'COMMON.IOUNITS'
4562       include 'COMMON.FFIELD'
4563       include 'COMMON.CONTROL'
4564       logical lprn
4565 C Set lprn=.true. for debugging
4566       lprn=.false.
4567 c      lprn=.true.
4568 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4569       esccor=0.0D0
4570       do i=itau_start,itau_end
4571         esccor_ii=0.0D0
4572         isccori=isccortyp(itype(i-2))
4573         isccori1=isccortyp(itype(i-1))
4574         phii=phi(i)
4575         do intertyp=1,3 !intertyp
4576 cc Added 09 May 2012 (Adasko)
4577 cc  Intertyp means interaction type of backbone mainchain correlation:
4578 c   1 = SC...Ca...Ca...Ca
4579 c   2 = Ca...Ca...Ca...SC
4580 c   3 = SC...Ca...Ca...SCi
4581         gloci=0.0D0
4582         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4583      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4584      &      (itype(i-1).eq.ntyp1)))
4585      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4586      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4587      &     .or.(itype(i).eq.ntyp1)))
4588      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4589      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4590      &      (itype(i-3).eq.ntyp1)))) cycle
4591         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
4592         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
4593      & cycle
4594        do j=1,nterm_sccor(isccori,isccori1)
4595           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4596           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4597           cosphi=dcos(j*tauangle(intertyp,i))
4598           sinphi=dsin(j*tauangle(intertyp,i))
4599            esccor=esccor+v1ij*cosphi+v2ij*sinphi
4600            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4601          enddo
4602 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
4603         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4604         if (lprn)
4605      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4606      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4607      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
4608         gsccor_loc(i-3)=gloci
4609        enddo !intertyp
4610       enddo
4611       return
4612       end
4613 c------------------------------------------------------------------------------
4614       subroutine multibody(ecorr)
4615 C This subroutine calculates multi-body contributions to energy following
4616 C the idea of Skolnick et al. If side chains I and J make a contact and
4617 C at the same time side chains I+1 and J+1 make a contact, an extra
4618 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4619       implicit real*8 (a-h,o-z)
4620       include 'DIMENSIONS'
4621       include 'COMMON.IOUNITS'
4622       include 'COMMON.DERIV'
4623       include 'COMMON.INTERACT'
4624       include 'COMMON.CONTACTS'
4625       double precision gx(3),gx1(3)
4626       logical lprn
4627
4628 C Set lprn=.true. for debugging
4629       lprn=.false.
4630
4631       if (lprn) then
4632         write (iout,'(a)') 'Contact function values:'
4633         do i=nnt,nct-2
4634           write (iout,'(i2,20(1x,i2,f10.5))')
4635      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4636         enddo
4637       endif
4638       ecorr=0.0D0
4639       do i=nnt,nct
4640         do j=1,3
4641           gradcorr(j,i)=0.0D0
4642           gradxorr(j,i)=0.0D0
4643         enddo
4644       enddo
4645       do i=nnt,nct-2
4646
4647         DO ISHIFT = 3,4
4648
4649         i1=i+ishift
4650         num_conti=num_cont(i)
4651         num_conti1=num_cont(i1)
4652         do jj=1,num_conti
4653           j=jcont(jj,i)
4654           do kk=1,num_conti1
4655             j1=jcont(kk,i1)
4656             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4657 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4658 cd   &                   ' ishift=',ishift
4659 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4660 C The system gains extra energy.
4661               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4662             endif   ! j1==j+-ishift
4663           enddo     ! kk
4664         enddo       ! jj
4665
4666         ENDDO ! ISHIFT
4667
4668       enddo         ! i
4669       return
4670       end
4671 c------------------------------------------------------------------------------
4672       double precision function esccorr(i,j,k,l,jj,kk)
4673       implicit real*8 (a-h,o-z)
4674       include 'DIMENSIONS'
4675       include 'COMMON.IOUNITS'
4676       include 'COMMON.DERIV'
4677       include 'COMMON.INTERACT'
4678       include 'COMMON.CONTACTS'
4679       double precision gx(3),gx1(3)
4680       logical lprn
4681       lprn=.false.
4682       eij=facont(jj,i)
4683       ekl=facont(kk,k)
4684 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4685 C Calculate the multi-body contribution to energy.
4686 C Calculate multi-body contributions to the gradient.
4687 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4688 cd   & k,l,(gacont(m,kk,k),m=1,3)
4689       do m=1,3
4690         gx(m) =ekl*gacont(m,jj,i)
4691         gx1(m)=eij*gacont(m,kk,k)
4692         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4693         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4694         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4695         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4696       enddo
4697       do m=i,j-1
4698         do ll=1,3
4699           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4700         enddo
4701       enddo
4702       do m=k,l-1
4703         do ll=1,3
4704           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4705         enddo
4706       enddo
4707       esccorr=-eij*ekl
4708       return
4709       end
4710 c------------------------------------------------------------------------------
4711 #ifdef MPL
4712       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4713       implicit real*8 (a-h,o-z)
4714       include 'DIMENSIONS'
4715       integer dimen1,dimen2,atom,indx
4716       double precision buffer(dimen1,dimen2)
4717       double precision zapas
4718       common /contacts_hb/ zapas(3,20,maxres,7),
4719      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4720      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4721       num_kont=num_cont_hb(atom)
4722       do i=1,num_kont
4723         do k=1,7
4724           do j=1,3
4725             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4726           enddo ! j
4727         enddo ! k
4728         buffer(i,indx+22)=facont_hb(i,atom)
4729         buffer(i,indx+23)=ees0p(i,atom)
4730         buffer(i,indx+24)=ees0m(i,atom)
4731         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4732       enddo ! i
4733       buffer(1,indx+26)=dfloat(num_kont)
4734       return
4735       end
4736 c------------------------------------------------------------------------------
4737       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4738       implicit real*8 (a-h,o-z)
4739       include 'DIMENSIONS'
4740       integer dimen1,dimen2,atom,indx
4741       double precision buffer(dimen1,dimen2)
4742       double precision zapas
4743       common /contacts_hb/ zapas(3,20,maxres,7),
4744      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4745      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4746       num_kont=buffer(1,indx+26)
4747       num_kont_old=num_cont_hb(atom)
4748       num_cont_hb(atom)=num_kont+num_kont_old
4749       do i=1,num_kont
4750         ii=i+num_kont_old
4751         do k=1,7
4752           do j=1,3
4753             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4754           enddo ! j
4755         enddo ! k
4756         facont_hb(ii,atom)=buffer(i,indx+22)
4757         ees0p(ii,atom)=buffer(i,indx+23)
4758         ees0m(ii,atom)=buffer(i,indx+24)
4759         jcont_hb(ii,atom)=buffer(i,indx+25)
4760       enddo ! i
4761       return
4762       end
4763 c------------------------------------------------------------------------------
4764 #endif
4765       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4766 C This subroutine calculates multi-body contributions to hydrogen-bonding
4767       implicit real*8 (a-h,o-z)
4768       include 'DIMENSIONS'
4769       include 'DIMENSIONS.ZSCOPT'
4770       include 'COMMON.IOUNITS'
4771 #ifdef MPL
4772       include 'COMMON.INFO'
4773 #endif
4774       include 'COMMON.FFIELD'
4775       include 'COMMON.DERIV'
4776       include 'COMMON.INTERACT'
4777       include 'COMMON.CONTACTS'
4778 #ifdef MPL
4779       parameter (max_cont=maxconts)
4780       parameter (max_dim=2*(8*3+2))
4781       parameter (msglen1=max_cont*max_dim*4)
4782       parameter (msglen2=2*msglen1)
4783       integer source,CorrelType,CorrelID,Error
4784       double precision buffer(max_cont,max_dim)
4785 #endif
4786       double precision gx(3),gx1(3)
4787       logical lprn,ldone
4788
4789 C Set lprn=.true. for debugging
4790       lprn=.false.
4791 #ifdef MPL
4792       n_corr=0
4793       n_corr1=0
4794       if (fgProcs.le.1) goto 30
4795       if (lprn) then
4796         write (iout,'(a)') 'Contact function values:'
4797         do i=nnt,nct-2
4798           write (iout,'(2i3,50(1x,i2,f5.2))')
4799      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4800      &    j=1,num_cont_hb(i))
4801         enddo
4802       endif
4803 C Caution! Following code assumes that electrostatic interactions concerning
4804 C a given atom are split among at most two processors!
4805       CorrelType=477
4806       CorrelID=MyID+1
4807       ldone=.false.
4808       do i=1,max_cont
4809         do j=1,max_dim
4810           buffer(i,j)=0.0D0
4811         enddo
4812       enddo
4813       mm=mod(MyRank,2)
4814 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4815       if (mm) 20,20,10
4816    10 continue
4817 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4818       if (MyRank.gt.0) then
4819 C Send correlation contributions to the preceding processor
4820         msglen=msglen1
4821         nn=num_cont_hb(iatel_s)
4822         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4823 cd      write (iout,*) 'The BUFFER array:'
4824 cd      do i=1,nn
4825 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4826 cd      enddo
4827         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4828           msglen=msglen2
4829             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4830 C Clear the contacts of the atom passed to the neighboring processor
4831         nn=num_cont_hb(iatel_s+1)
4832 cd      do i=1,nn
4833 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4834 cd      enddo
4835             num_cont_hb(iatel_s)=0
4836         endif
4837 cd      write (iout,*) 'Processor ',MyID,MyRank,
4838 cd   & ' is sending correlation contribution to processor',MyID-1,
4839 cd   & ' msglen=',msglen
4840 cd      write (*,*) 'Processor ',MyID,MyRank,
4841 cd   & ' is sending correlation contribution to processor',MyID-1,
4842 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4843         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4844 cd      write (iout,*) 'Processor ',MyID,
4845 cd   & ' has sent correlation contribution to processor',MyID-1,
4846 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4847 cd      write (*,*) 'Processor ',MyID,
4848 cd   & ' has sent correlation contribution to processor',MyID-1,
4849 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4850         msglen=msglen1
4851       endif ! (MyRank.gt.0)
4852       if (ldone) goto 30
4853       ldone=.true.
4854    20 continue
4855 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4856       if (MyRank.lt.fgProcs-1) then
4857 C Receive correlation contributions from the next processor
4858         msglen=msglen1
4859         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4860 cd      write (iout,*) 'Processor',MyID,
4861 cd   & ' is receiving correlation contribution from processor',MyID+1,
4862 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4863 cd      write (*,*) 'Processor',MyID,
4864 cd   & ' is receiving correlation contribution from processor',MyID+1,
4865 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4866         nbytes=-1
4867         do while (nbytes.le.0)
4868           call mp_probe(MyID+1,CorrelType,nbytes)
4869         enddo
4870 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4871         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4872 cd      write (iout,*) 'Processor',MyID,
4873 cd   & ' has received correlation contribution from processor',MyID+1,
4874 cd   & ' msglen=',msglen,' nbytes=',nbytes
4875 cd      write (iout,*) 'The received BUFFER array:'
4876 cd      do i=1,max_cont
4877 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4878 cd      enddo
4879         if (msglen.eq.msglen1) then
4880           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4881         else if (msglen.eq.msglen2)  then
4882           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4883           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4884         else
4885           write (iout,*)
4886      & 'ERROR!!!! message length changed while processing correlations.'
4887           write (*,*)
4888      & 'ERROR!!!! message length changed while processing correlations.'
4889           call mp_stopall(Error)
4890         endif ! msglen.eq.msglen1
4891       endif ! MyRank.lt.fgProcs-1
4892       if (ldone) goto 30
4893       ldone=.true.
4894       goto 10
4895    30 continue
4896 #endif
4897       if (lprn) then
4898         write (iout,'(a)') 'Contact function values:'
4899         do i=nnt,nct-2
4900           write (iout,'(2i3,50(1x,i2,f5.2))')
4901      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4902      &    j=1,num_cont_hb(i))
4903         enddo
4904       endif
4905       ecorr=0.0D0
4906 C Remove the loop below after debugging !!!
4907       do i=nnt,nct
4908         do j=1,3
4909           gradcorr(j,i)=0.0D0
4910           gradxorr(j,i)=0.0D0
4911         enddo
4912       enddo
4913 C Calculate the local-electrostatic correlation terms
4914       do i=iatel_s,iatel_e+1
4915         i1=i+1
4916         num_conti=num_cont_hb(i)
4917         num_conti1=num_cont_hb(i+1)
4918         do jj=1,num_conti
4919           j=jcont_hb(jj,i)
4920           do kk=1,num_conti1
4921             j1=jcont_hb(kk,i1)
4922 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4923 c     &         ' jj=',jj,' kk=',kk
4924             if (j1.eq.j+1 .or. j1.eq.j-1) then
4925 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4926 C The system gains extra energy.
4927               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4928               n_corr=n_corr+1
4929             else if (j1.eq.j) then
4930 C Contacts I-J and I-(J+1) occur simultaneously.
4931 C The system loses extra energy.
4932 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4933             endif
4934           enddo ! kk
4935           do kk=1,num_conti
4936             j1=jcont_hb(kk,i)
4937 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4938 c    &         ' jj=',jj,' kk=',kk
4939             if (j1.eq.j+1) then
4940 C Contacts I-J and (I+1)-J occur simultaneously.
4941 C The system loses extra energy.
4942 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4943             endif ! j1==j+1
4944           enddo ! kk
4945         enddo ! jj
4946       enddo ! i
4947       return
4948       end
4949 c------------------------------------------------------------------------------
4950       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4951      &  n_corr1)
4952 C This subroutine calculates multi-body contributions to hydrogen-bonding
4953       implicit real*8 (a-h,o-z)
4954       include 'DIMENSIONS'
4955       include 'DIMENSIONS.ZSCOPT'
4956       include 'COMMON.IOUNITS'
4957 #ifdef MPL
4958       include 'COMMON.INFO'
4959 #endif
4960       include 'COMMON.FFIELD'
4961       include 'COMMON.DERIV'
4962       include 'COMMON.INTERACT'
4963       include 'COMMON.CONTACTS'
4964 #ifdef MPL
4965       parameter (max_cont=maxconts)
4966       parameter (max_dim=2*(8*3+2))
4967       parameter (msglen1=max_cont*max_dim*4)
4968       parameter (msglen2=2*msglen1)
4969       integer source,CorrelType,CorrelID,Error
4970       double precision buffer(max_cont,max_dim)
4971 #endif
4972       double precision gx(3),gx1(3)
4973       logical lprn,ldone
4974
4975 C Set lprn=.true. for debugging
4976       lprn=.false.
4977       eturn6=0.0d0
4978 #ifdef MPL
4979       n_corr=0
4980       n_corr1=0
4981       if (fgProcs.le.1) goto 30
4982       if (lprn) then
4983         write (iout,'(a)') 'Contact function values:'
4984         do i=nnt,nct-2
4985           write (iout,'(2i3,50(1x,i2,f5.2))')
4986      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4987      &    j=1,num_cont_hb(i))
4988         enddo
4989       endif
4990 C Caution! Following code assumes that electrostatic interactions concerning
4991 C a given atom are split among at most two processors!
4992       CorrelType=477
4993       CorrelID=MyID+1
4994       ldone=.false.
4995       do i=1,max_cont
4996         do j=1,max_dim
4997           buffer(i,j)=0.0D0
4998         enddo
4999       enddo
5000       mm=mod(MyRank,2)
5001 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5002       if (mm) 20,20,10
5003    10 continue
5004 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5005       if (MyRank.gt.0) then
5006 C Send correlation contributions to the preceding processor
5007         msglen=msglen1
5008         nn=num_cont_hb(iatel_s)
5009         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5010 cd      write (iout,*) 'The BUFFER array:'
5011 cd      do i=1,nn
5012 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5013 cd      enddo
5014         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5015           msglen=msglen2
5016             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5017 C Clear the contacts of the atom passed to the neighboring processor
5018         nn=num_cont_hb(iatel_s+1)
5019 cd      do i=1,nn
5020 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5021 cd      enddo
5022             num_cont_hb(iatel_s)=0
5023         endif
5024 cd      write (iout,*) 'Processor ',MyID,MyRank,
5025 cd   & ' is sending correlation contribution to processor',MyID-1,
5026 cd   & ' msglen=',msglen
5027 cd      write (*,*) 'Processor ',MyID,MyRank,
5028 cd   & ' is sending correlation contribution to processor',MyID-1,
5029 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5030         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5031 cd      write (iout,*) 'Processor ',MyID,
5032 cd   & ' has sent correlation contribution to processor',MyID-1,
5033 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5034 cd      write (*,*) 'Processor ',MyID,
5035 cd   & ' has sent correlation contribution to processor',MyID-1,
5036 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5037         msglen=msglen1
5038       endif ! (MyRank.gt.0)
5039       if (ldone) goto 30
5040       ldone=.true.
5041    20 continue
5042 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5043       if (MyRank.lt.fgProcs-1) then
5044 C Receive correlation contributions from the next processor
5045         msglen=msglen1
5046         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5047 cd      write (iout,*) 'Processor',MyID,
5048 cd   & ' is receiving correlation contribution from processor',MyID+1,
5049 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5050 cd      write (*,*) 'Processor',MyID,
5051 cd   & ' is receiving correlation contribution from processor',MyID+1,
5052 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5053         nbytes=-1
5054         do while (nbytes.le.0)
5055           call mp_probe(MyID+1,CorrelType,nbytes)
5056         enddo
5057 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5058         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5059 cd      write (iout,*) 'Processor',MyID,
5060 cd   & ' has received correlation contribution from processor',MyID+1,
5061 cd   & ' msglen=',msglen,' nbytes=',nbytes
5062 cd      write (iout,*) 'The received BUFFER array:'
5063 cd      do i=1,max_cont
5064 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5065 cd      enddo
5066         if (msglen.eq.msglen1) then
5067           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5068         else if (msglen.eq.msglen2)  then
5069           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5070           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5071         else
5072           write (iout,*)
5073      & 'ERROR!!!! message length changed while processing correlations.'
5074           write (*,*)
5075      & 'ERROR!!!! message length changed while processing correlations.'
5076           call mp_stopall(Error)
5077         endif ! msglen.eq.msglen1
5078       endif ! MyRank.lt.fgProcs-1
5079       if (ldone) goto 30
5080       ldone=.true.
5081       goto 10
5082    30 continue
5083 #endif
5084       if (lprn) then
5085         write (iout,'(a)') 'Contact function values:'
5086         do i=nnt,nct-2
5087           write (iout,'(2i3,50(1x,i2,f5.2))')
5088      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5089      &    j=1,num_cont_hb(i))
5090         enddo
5091       endif
5092       ecorr=0.0D0
5093       ecorr5=0.0d0
5094       ecorr6=0.0d0
5095 C Remove the loop below after debugging !!!
5096       do i=nnt,nct
5097         do j=1,3
5098           gradcorr(j,i)=0.0D0
5099           gradxorr(j,i)=0.0D0
5100         enddo
5101       enddo
5102 C Calculate the dipole-dipole interaction energies
5103       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5104       do i=iatel_s,iatel_e+1
5105         num_conti=num_cont_hb(i)
5106         do jj=1,num_conti
5107           j=jcont_hb(jj,i)
5108           call dipole(i,j,jj)
5109         enddo
5110       enddo
5111       endif
5112 C Calculate the local-electrostatic correlation terms
5113       do i=iatel_s,iatel_e+1
5114         i1=i+1
5115         num_conti=num_cont_hb(i)
5116         num_conti1=num_cont_hb(i+1)
5117         do jj=1,num_conti
5118           j=jcont_hb(jj,i)
5119           do kk=1,num_conti1
5120             j1=jcont_hb(kk,i1)
5121 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5122 c     &         ' jj=',jj,' kk=',kk
5123             if (j1.eq.j+1 .or. j1.eq.j-1) then
5124 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5125 C The system gains extra energy.
5126               n_corr=n_corr+1
5127               sqd1=dsqrt(d_cont(jj,i))
5128               sqd2=dsqrt(d_cont(kk,i1))
5129               sred_geom = sqd1*sqd2
5130               IF (sred_geom.lt.cutoff_corr) THEN
5131                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5132      &            ekont,fprimcont)
5133 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5134 c     &         ' jj=',jj,' kk=',kk
5135                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5136                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5137                 do l=1,3
5138                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5139                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5140                 enddo
5141                 n_corr1=n_corr1+1
5142 cd               write (iout,*) 'sred_geom=',sred_geom,
5143 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5144                 call calc_eello(i,j,i+1,j1,jj,kk)
5145                 if (wcorr4.gt.0.0d0)
5146      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5147                 if (wcorr5.gt.0.0d0)
5148      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5149 c                print *,"wcorr5",ecorr5
5150 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5151 cd                write(2,*)'ijkl',i,j,i+1,j1
5152                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5153      &               .or. wturn6.eq.0.0d0))then
5154 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5155                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5156 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5157 cd     &            'ecorr6=',ecorr6
5158 cd                write (iout,'(4e15.5)') sred_geom,
5159 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5160 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5161 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5162                 else if (wturn6.gt.0.0d0
5163      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5164 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5165                   eturn6=eturn6+eello_turn6(i,jj,kk)
5166 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5167                 endif
5168               ENDIF
5169 1111          continue
5170             else if (j1.eq.j) then
5171 C Contacts I-J and I-(J+1) occur simultaneously.
5172 C The system loses extra energy.
5173 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5174             endif
5175           enddo ! kk
5176           do kk=1,num_conti
5177             j1=jcont_hb(kk,i)
5178 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5179 c    &         ' jj=',jj,' kk=',kk
5180             if (j1.eq.j+1) then
5181 C Contacts I-J and (I+1)-J occur simultaneously.
5182 C The system loses extra energy.
5183 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5184             endif ! j1==j+1
5185           enddo ! kk
5186         enddo ! jj
5187       enddo ! i
5188       return
5189       end
5190 c------------------------------------------------------------------------------
5191       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5192       implicit real*8 (a-h,o-z)
5193       include 'DIMENSIONS'
5194       include 'COMMON.IOUNITS'
5195       include 'COMMON.DERIV'
5196       include 'COMMON.INTERACT'
5197       include 'COMMON.CONTACTS'
5198       double precision gx(3),gx1(3)
5199       logical lprn
5200       lprn=.false.
5201       eij=facont_hb(jj,i)
5202       ekl=facont_hb(kk,k)
5203       ees0pij=ees0p(jj,i)
5204       ees0pkl=ees0p(kk,k)
5205       ees0mij=ees0m(jj,i)
5206       ees0mkl=ees0m(kk,k)
5207       ekont=eij*ekl
5208       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5209 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5210 C Following 4 lines for diagnostics.
5211 cd    ees0pkl=0.0D0
5212 cd    ees0pij=1.0D0
5213 cd    ees0mkl=0.0D0
5214 cd    ees0mij=1.0D0
5215 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5216 c    &   ' and',k,l
5217 c     write (iout,*)'Contacts have occurred for peptide groups',
5218 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5219 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5220 C Calculate the multi-body contribution to energy.
5221       ecorr=ecorr+ekont*ees
5222       if (calc_grad) then
5223 C Calculate multi-body contributions to the gradient.
5224       do ll=1,3
5225         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5226         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5227      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5228      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5229         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5230      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5231      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5232         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5233         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5234      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5235      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5236         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5237      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5238      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5239       enddo
5240       do m=i+1,j-1
5241         do ll=1,3
5242           gradcorr(ll,m)=gradcorr(ll,m)+
5243      &     ees*ekl*gacont_hbr(ll,jj,i)-
5244      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5245      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5246         enddo
5247       enddo
5248       do m=k+1,l-1
5249         do ll=1,3
5250           gradcorr(ll,m)=gradcorr(ll,m)+
5251      &     ees*eij*gacont_hbr(ll,kk,k)-
5252      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5253      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5254         enddo
5255       enddo
5256       endif
5257       ehbcorr=ekont*ees
5258       return
5259       end
5260 C---------------------------------------------------------------------------
5261       subroutine dipole(i,j,jj)
5262       implicit real*8 (a-h,o-z)
5263       include 'DIMENSIONS'
5264       include 'DIMENSIONS.ZSCOPT'
5265       include 'COMMON.IOUNITS'
5266       include 'COMMON.CHAIN'
5267       include 'COMMON.FFIELD'
5268       include 'COMMON.DERIV'
5269       include 'COMMON.INTERACT'
5270       include 'COMMON.CONTACTS'
5271       include 'COMMON.TORSION'
5272       include 'COMMON.VAR'
5273       include 'COMMON.GEO'
5274       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5275      &  auxmat(2,2)
5276       iti1 = itortyp(itype(i+1))
5277       if (j.lt.nres-1) then
5278         if (itype(j).le.ntyp) then
5279           itj1 = itortyp(itype(j+1))
5280         else
5281           itj=ntortyp+1
5282         endif
5283       else
5284         itj1=ntortyp+1
5285       endif
5286       do iii=1,2
5287         dipi(iii,1)=Ub2(iii,i)
5288         dipderi(iii)=Ub2der(iii,i)
5289         dipi(iii,2)=b1(iii,iti1)
5290         dipj(iii,1)=Ub2(iii,j)
5291         dipderj(iii)=Ub2der(iii,j)
5292         dipj(iii,2)=b1(iii,itj1)
5293       enddo
5294       kkk=0
5295       do iii=1,2
5296         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5297         do jjj=1,2
5298           kkk=kkk+1
5299           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5300         enddo
5301       enddo
5302       if (.not.calc_grad) return
5303       do kkk=1,5
5304         do lll=1,3
5305           mmm=0
5306           do iii=1,2
5307             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5308      &        auxvec(1))
5309             do jjj=1,2
5310               mmm=mmm+1
5311               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5312             enddo
5313           enddo
5314         enddo
5315       enddo
5316       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5317       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5318       do iii=1,2
5319         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5320       enddo
5321       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5322       do iii=1,2
5323         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5324       enddo
5325       return
5326       end
5327 C---------------------------------------------------------------------------
5328       subroutine calc_eello(i,j,k,l,jj,kk)
5329 C
5330 C This subroutine computes matrices and vectors needed to calculate
5331 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5332 C
5333       implicit real*8 (a-h,o-z)
5334       include 'DIMENSIONS'
5335       include 'DIMENSIONS.ZSCOPT'
5336       include 'COMMON.IOUNITS'
5337       include 'COMMON.CHAIN'
5338       include 'COMMON.DERIV'
5339       include 'COMMON.INTERACT'
5340       include 'COMMON.CONTACTS'
5341       include 'COMMON.TORSION'
5342       include 'COMMON.VAR'
5343       include 'COMMON.GEO'
5344       include 'COMMON.FFIELD'
5345       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5346      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5347       logical lprn
5348       common /kutas/ lprn
5349 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5350 cd     & ' jj=',jj,' kk=',kk
5351 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5352       do iii=1,2
5353         do jjj=1,2
5354           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5355           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5356         enddo
5357       enddo
5358       call transpose2(aa1(1,1),aa1t(1,1))
5359       call transpose2(aa2(1,1),aa2t(1,1))
5360       do kkk=1,5
5361         do lll=1,3
5362           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5363      &      aa1tder(1,1,lll,kkk))
5364           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5365      &      aa2tder(1,1,lll,kkk))
5366         enddo
5367       enddo
5368       if (l.eq.j+1) then
5369 C parallel orientation of the two CA-CA-CA frames.
5370         if (i.gt.1 .and. itype(i).le.ntyp) then
5371           iti=itortyp(itype(i))
5372         else
5373           iti=ntortyp+1
5374         endif
5375         itk1=itortyp(itype(k+1))
5376         itj=itortyp(itype(j))
5377         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5378           itl1=itortyp(itype(l+1))
5379         else
5380           itl1=ntortyp+1
5381         endif
5382 C A1 kernel(j+1) A2T
5383 cd        do iii=1,2
5384 cd          write (iout,'(3f10.5,5x,3f10.5)')
5385 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5386 cd        enddo
5387         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5388      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5389      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5390 C Following matrices are needed only for 6-th order cumulants
5391         IF (wcorr6.gt.0.0d0) THEN
5392         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5393      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5394      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5395         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5396      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5397      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5398      &   ADtEAderx(1,1,1,1,1,1))
5399         lprn=.false.
5400         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5401      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5402      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5403      &   ADtEA1derx(1,1,1,1,1,1))
5404         ENDIF
5405 C End 6-th order cumulants
5406 cd        lprn=.false.
5407 cd        if (lprn) then
5408 cd        write (2,*) 'In calc_eello6'
5409 cd        do iii=1,2
5410 cd          write (2,*) 'iii=',iii
5411 cd          do kkk=1,5
5412 cd            write (2,*) 'kkk=',kkk
5413 cd            do jjj=1,2
5414 cd              write (2,'(3(2f10.5),5x)')
5415 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5416 cd            enddo
5417 cd          enddo
5418 cd        enddo
5419 cd        endif
5420         call transpose2(EUgder(1,1,k),auxmat(1,1))
5421         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5422         call transpose2(EUg(1,1,k),auxmat(1,1))
5423         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5424         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5425         do iii=1,2
5426           do kkk=1,5
5427             do lll=1,3
5428               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5429      &          EAEAderx(1,1,lll,kkk,iii,1))
5430             enddo
5431           enddo
5432         enddo
5433 C A1T kernel(i+1) A2
5434         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5435      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5436      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5437 C Following matrices are needed only for 6-th order cumulants
5438         IF (wcorr6.gt.0.0d0) THEN
5439         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5440      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5441      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5442         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5443      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5444      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5445      &   ADtEAderx(1,1,1,1,1,2))
5446         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5447      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5448      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5449      &   ADtEA1derx(1,1,1,1,1,2))
5450         ENDIF
5451 C End 6-th order cumulants
5452         call transpose2(EUgder(1,1,l),auxmat(1,1))
5453         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5454         call transpose2(EUg(1,1,l),auxmat(1,1))
5455         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5456         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5457         do iii=1,2
5458           do kkk=1,5
5459             do lll=1,3
5460               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5461      &          EAEAderx(1,1,lll,kkk,iii,2))
5462             enddo
5463           enddo
5464         enddo
5465 C AEAb1 and AEAb2
5466 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5467 C They are needed only when the fifth- or the sixth-order cumulants are
5468 C indluded.
5469         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5470         call transpose2(AEA(1,1,1),auxmat(1,1))
5471         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5472         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5473         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5474         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5475         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5476         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5477         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5478         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5479         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5480         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5481         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5482         call transpose2(AEA(1,1,2),auxmat(1,1))
5483         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5484         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5485         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5486         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5487         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5488         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5489         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5490         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5491         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5492         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5493         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5494 C Calculate the Cartesian derivatives of the vectors.
5495         do iii=1,2
5496           do kkk=1,5
5497             do lll=1,3
5498               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5499               call matvec2(auxmat(1,1),b1(1,iti),
5500      &          AEAb1derx(1,lll,kkk,iii,1,1))
5501               call matvec2(auxmat(1,1),Ub2(1,i),
5502      &          AEAb2derx(1,lll,kkk,iii,1,1))
5503               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5504      &          AEAb1derx(1,lll,kkk,iii,2,1))
5505               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5506      &          AEAb2derx(1,lll,kkk,iii,2,1))
5507               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5508               call matvec2(auxmat(1,1),b1(1,itj),
5509      &          AEAb1derx(1,lll,kkk,iii,1,2))
5510               call matvec2(auxmat(1,1),Ub2(1,j),
5511      &          AEAb2derx(1,lll,kkk,iii,1,2))
5512               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5513      &          AEAb1derx(1,lll,kkk,iii,2,2))
5514               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5515      &          AEAb2derx(1,lll,kkk,iii,2,2))
5516             enddo
5517           enddo
5518         enddo
5519         ENDIF
5520 C End vectors
5521       else
5522 C Antiparallel orientation of the two CA-CA-CA frames.
5523         if (i.gt.1 .and. itype(i).le.ntyp) then
5524           iti=itortyp(itype(i))
5525         else
5526           iti=ntortyp+1
5527         endif
5528         itk1=itortyp(itype(k+1))
5529         itl=itortyp(itype(l))
5530         itj=itortyp(itype(j))
5531         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
5532           itj1=itortyp(itype(j+1))
5533         else
5534           itj1=ntortyp+1
5535         endif
5536 C A2 kernel(j-1)T A1T
5537         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5538      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5539      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5540 C Following matrices are needed only for 6-th order cumulants
5541         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5542      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5543         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5544      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5545      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5546         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5547      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5548      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5549      &   ADtEAderx(1,1,1,1,1,1))
5550         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5551      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5552      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5553      &   ADtEA1derx(1,1,1,1,1,1))
5554         ENDIF
5555 C End 6-th order cumulants
5556         call transpose2(EUgder(1,1,k),auxmat(1,1))
5557         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5558         call transpose2(EUg(1,1,k),auxmat(1,1))
5559         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5560         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5561         do iii=1,2
5562           do kkk=1,5
5563             do lll=1,3
5564               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5565      &          EAEAderx(1,1,lll,kkk,iii,1))
5566             enddo
5567           enddo
5568         enddo
5569 C A2T kernel(i+1)T A1
5570         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5571      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5572      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5573 C Following matrices are needed only for 6-th order cumulants
5574         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5575      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5576         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5577      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5578      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5579         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5580      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5581      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5582      &   ADtEAderx(1,1,1,1,1,2))
5583         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5584      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5585      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5586      &   ADtEA1derx(1,1,1,1,1,2))
5587         ENDIF
5588 C End 6-th order cumulants
5589         call transpose2(EUgder(1,1,j),auxmat(1,1))
5590         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5591         call transpose2(EUg(1,1,j),auxmat(1,1))
5592         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5593         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5594         do iii=1,2
5595           do kkk=1,5
5596             do lll=1,3
5597               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5598      &          EAEAderx(1,1,lll,kkk,iii,2))
5599             enddo
5600           enddo
5601         enddo
5602 C AEAb1 and AEAb2
5603 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5604 C They are needed only when the fifth- or the sixth-order cumulants are
5605 C indluded.
5606         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5607      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5608         call transpose2(AEA(1,1,1),auxmat(1,1))
5609         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5610         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5611         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5612         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5613         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5614         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5615         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5616         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5617         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5618         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5619         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5620         call transpose2(AEA(1,1,2),auxmat(1,1))
5621         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5622         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5623         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5624         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5625         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5626         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5627         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5628         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5629         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5630         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5631         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5632 C Calculate the Cartesian derivatives of the vectors.
5633         do iii=1,2
5634           do kkk=1,5
5635             do lll=1,3
5636               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5637               call matvec2(auxmat(1,1),b1(1,iti),
5638      &          AEAb1derx(1,lll,kkk,iii,1,1))
5639               call matvec2(auxmat(1,1),Ub2(1,i),
5640      &          AEAb2derx(1,lll,kkk,iii,1,1))
5641               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5642      &          AEAb1derx(1,lll,kkk,iii,2,1))
5643               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5644      &          AEAb2derx(1,lll,kkk,iii,2,1))
5645               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5646               call matvec2(auxmat(1,1),b1(1,itl),
5647      &          AEAb1derx(1,lll,kkk,iii,1,2))
5648               call matvec2(auxmat(1,1),Ub2(1,l),
5649      &          AEAb2derx(1,lll,kkk,iii,1,2))
5650               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5651      &          AEAb1derx(1,lll,kkk,iii,2,2))
5652               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5653      &          AEAb2derx(1,lll,kkk,iii,2,2))
5654             enddo
5655           enddo
5656         enddo
5657         ENDIF
5658 C End vectors
5659       endif
5660       return
5661       end
5662 C---------------------------------------------------------------------------
5663       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5664      &  KK,KKderg,AKA,AKAderg,AKAderx)
5665       implicit none
5666       integer nderg
5667       logical transp
5668       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5669      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5670      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5671       integer iii,kkk,lll
5672       integer jjj,mmm
5673       logical lprn
5674       common /kutas/ lprn
5675       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5676       do iii=1,nderg
5677         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5678      &    AKAderg(1,1,iii))
5679       enddo
5680 cd      if (lprn) write (2,*) 'In kernel'
5681       do kkk=1,5
5682 cd        if (lprn) write (2,*) 'kkk=',kkk
5683         do lll=1,3
5684           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5685      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5686 cd          if (lprn) then
5687 cd            write (2,*) 'lll=',lll
5688 cd            write (2,*) 'iii=1'
5689 cd            do jjj=1,2
5690 cd              write (2,'(3(2f10.5),5x)')
5691 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5692 cd            enddo
5693 cd          endif
5694           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5695      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5696 cd          if (lprn) then
5697 cd            write (2,*) 'lll=',lll
5698 cd            write (2,*) 'iii=2'
5699 cd            do jjj=1,2
5700 cd              write (2,'(3(2f10.5),5x)')
5701 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5702 cd            enddo
5703 cd          endif
5704         enddo
5705       enddo
5706       return
5707       end
5708 C---------------------------------------------------------------------------
5709       double precision function eello4(i,j,k,l,jj,kk)
5710       implicit real*8 (a-h,o-z)
5711       include 'DIMENSIONS'
5712       include 'DIMENSIONS.ZSCOPT'
5713       include 'COMMON.IOUNITS'
5714       include 'COMMON.CHAIN'
5715       include 'COMMON.DERIV'
5716       include 'COMMON.INTERACT'
5717       include 'COMMON.CONTACTS'
5718       include 'COMMON.TORSION'
5719       include 'COMMON.VAR'
5720       include 'COMMON.GEO'
5721       double precision pizda(2,2),ggg1(3),ggg2(3)
5722 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5723 cd        eello4=0.0d0
5724 cd        return
5725 cd      endif
5726 cd      print *,'eello4:',i,j,k,l,jj,kk
5727 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5728 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5729 cold      eij=facont_hb(jj,i)
5730 cold      ekl=facont_hb(kk,k)
5731 cold      ekont=eij*ekl
5732       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5733       if (calc_grad) then
5734 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5735       gcorr_loc(k-1)=gcorr_loc(k-1)
5736      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5737       if (l.eq.j+1) then
5738         gcorr_loc(l-1)=gcorr_loc(l-1)
5739      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5740       else
5741         gcorr_loc(j-1)=gcorr_loc(j-1)
5742      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5743       endif
5744       do iii=1,2
5745         do kkk=1,5
5746           do lll=1,3
5747             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5748      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5749 cd            derx(lll,kkk,iii)=0.0d0
5750           enddo
5751         enddo
5752       enddo
5753 cd      gcorr_loc(l-1)=0.0d0
5754 cd      gcorr_loc(j-1)=0.0d0
5755 cd      gcorr_loc(k-1)=0.0d0
5756 cd      eel4=1.0d0
5757 cd      write (iout,*)'Contacts have occurred for peptide groups',
5758 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5759 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5760       if (j.lt.nres-1) then
5761         j1=j+1
5762         j2=j-1
5763       else
5764         j1=j-1
5765         j2=j-2
5766       endif
5767       if (l.lt.nres-1) then
5768         l1=l+1
5769         l2=l-1
5770       else
5771         l1=l-1
5772         l2=l-2
5773       endif
5774       do ll=1,3
5775 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5776         ggg1(ll)=eel4*g_contij(ll,1)
5777         ggg2(ll)=eel4*g_contij(ll,2)
5778         ghalf=0.5d0*ggg1(ll)
5779 cd        ghalf=0.0d0
5780         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5781         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5782         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5783         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5784 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5785         ghalf=0.5d0*ggg2(ll)
5786 cd        ghalf=0.0d0
5787         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5788         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5789         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5790         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5791       enddo
5792 cd      goto 1112
5793       do m=i+1,j-1
5794         do ll=1,3
5795 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5796           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5797         enddo
5798       enddo
5799       do m=k+1,l-1
5800         do ll=1,3
5801 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5802           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5803         enddo
5804       enddo
5805 1112  continue
5806       do m=i+2,j2
5807         do ll=1,3
5808           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5809         enddo
5810       enddo
5811       do m=k+2,l2
5812         do ll=1,3
5813           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5814         enddo
5815       enddo
5816 cd      do iii=1,nres-3
5817 cd        write (2,*) iii,gcorr_loc(iii)
5818 cd      enddo
5819       endif
5820       eello4=ekont*eel4
5821 cd      write (2,*) 'ekont',ekont
5822 cd      write (iout,*) 'eello4',ekont*eel4
5823       return
5824       end
5825 C---------------------------------------------------------------------------
5826       double precision function eello5(i,j,k,l,jj,kk)
5827       implicit real*8 (a-h,o-z)
5828       include 'DIMENSIONS'
5829       include 'DIMENSIONS.ZSCOPT'
5830       include 'COMMON.IOUNITS'
5831       include 'COMMON.CHAIN'
5832       include 'COMMON.DERIV'
5833       include 'COMMON.INTERACT'
5834       include 'COMMON.CONTACTS'
5835       include 'COMMON.TORSION'
5836       include 'COMMON.VAR'
5837       include 'COMMON.GEO'
5838       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5839       double precision ggg1(3),ggg2(3)
5840 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5841 C                                                                              C
5842 C                            Parallel chains                                   C
5843 C                                                                              C
5844 C          o             o                   o             o                   C
5845 C         /l\           / \             \   / \           / \   /              C
5846 C        /   \         /   \             \ /   \         /   \ /               C
5847 C       j| o |l1       | o |              o| o |         | o |o                C
5848 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5849 C      \i/   \         /   \ /             /   \         /   \                 C
5850 C       o    k1             o                                                  C
5851 C         (I)          (II)                (III)          (IV)                 C
5852 C                                                                              C
5853 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5854 C                                                                              C
5855 C                            Antiparallel chains                               C
5856 C                                                                              C
5857 C          o             o                   o             o                   C
5858 C         /j\           / \             \   / \           / \   /              C
5859 C        /   \         /   \             \ /   \         /   \ /               C
5860 C      j1| o |l        | o |              o| o |         | o |o                C
5861 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5862 C      \i/   \         /   \ /             /   \         /   \                 C
5863 C       o     k1            o                                                  C
5864 C         (I)          (II)                (III)          (IV)                 C
5865 C                                                                              C
5866 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5867 C                                                                              C
5868 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5869 C                                                                              C
5870 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5871 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5872 cd        eello5=0.0d0
5873 cd        return
5874 cd      endif
5875 cd      write (iout,*)
5876 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5877 cd     &   ' and',k,l
5878       itk=itortyp(itype(k))
5879       itl=itortyp(itype(l))
5880       itj=itortyp(itype(j))
5881       eello5_1=0.0d0
5882       eello5_2=0.0d0
5883       eello5_3=0.0d0
5884       eello5_4=0.0d0
5885 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
5886 cd     &   eel5_3_num,eel5_4_num)
5887       do iii=1,2
5888         do kkk=1,5
5889           do lll=1,3
5890             derx(lll,kkk,iii)=0.0d0
5891           enddo
5892         enddo
5893       enddo
5894 cd      eij=facont_hb(jj,i)
5895 cd      ekl=facont_hb(kk,k)
5896 cd      ekont=eij*ekl
5897 cd      write (iout,*)'Contacts have occurred for peptide groups',
5898 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
5899 cd      goto 1111
5900 C Contribution from the graph I.
5901 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
5902 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
5903       call transpose2(EUg(1,1,k),auxmat(1,1))
5904       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
5905       vv(1)=pizda(1,1)-pizda(2,2)
5906       vv(2)=pizda(1,2)+pizda(2,1)
5907       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
5908      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5909       if (calc_grad) then
5910 C Explicit gradient in virtual-dihedral angles.
5911       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
5912      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
5913      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
5914       call transpose2(EUgder(1,1,k),auxmat1(1,1))
5915       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
5916       vv(1)=pizda(1,1)-pizda(2,2)
5917       vv(2)=pizda(1,2)+pizda(2,1)
5918       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5919      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
5920      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5921       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
5922       vv(1)=pizda(1,1)-pizda(2,2)
5923       vv(2)=pizda(1,2)+pizda(2,1)
5924       if (l.eq.j+1) then
5925         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
5926      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5927      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5928       else
5929         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
5930      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5931      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5932       endif
5933 C Cartesian gradient
5934       do iii=1,2
5935         do kkk=1,5
5936           do lll=1,3
5937             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
5938      &        pizda(1,1))
5939             vv(1)=pizda(1,1)-pizda(2,2)
5940             vv(2)=pizda(1,2)+pizda(2,1)
5941             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5942      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
5943      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5944           enddo
5945         enddo
5946       enddo
5947 c      goto 1112
5948       endif
5949 c1111  continue
5950 C Contribution from graph II
5951       call transpose2(EE(1,1,itk),auxmat(1,1))
5952       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
5953       vv(1)=pizda(1,1)+pizda(2,2)
5954       vv(2)=pizda(2,1)-pizda(1,2)
5955       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
5956      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
5957       if (calc_grad) then
5958 C Explicit gradient in virtual-dihedral angles.
5959       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5960      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
5961       call matmat2(auxmat(1,1),AEAderg(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       if (l.eq.j+1) then
5965         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5966      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5967      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5968       else
5969         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5970      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5971      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5972       endif
5973 C Cartesian gradient
5974       do iii=1,2
5975         do kkk=1,5
5976           do lll=1,3
5977             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5978      &        pizda(1,1))
5979             vv(1)=pizda(1,1)+pizda(2,2)
5980             vv(2)=pizda(2,1)-pizda(1,2)
5981             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5982      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
5983      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
5984           enddo
5985         enddo
5986       enddo
5987 cd      goto 1112
5988       endif
5989 cd1111  continue
5990       if (l.eq.j+1) then
5991 cd        goto 1110
5992 C Parallel orientation
5993 C Contribution from graph III
5994         call transpose2(EUg(1,1,l),auxmat(1,1))
5995         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5996         vv(1)=pizda(1,1)-pizda(2,2)
5997         vv(2)=pizda(1,2)+pizda(2,1)
5998         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
5999      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6000         if (calc_grad) then
6001 C Explicit gradient in virtual-dihedral angles.
6002         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6003      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6004      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6005         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6006         vv(1)=pizda(1,1)-pizda(2,2)
6007         vv(2)=pizda(1,2)+pizda(2,1)
6008         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6009      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6010      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6011         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6012         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6013         vv(1)=pizda(1,1)-pizda(2,2)
6014         vv(2)=pizda(1,2)+pizda(2,1)
6015         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6016      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6017      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6018 C Cartesian gradient
6019         do iii=1,2
6020           do kkk=1,5
6021             do lll=1,3
6022               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6023      &          pizda(1,1))
6024               vv(1)=pizda(1,1)-pizda(2,2)
6025               vv(2)=pizda(1,2)+pizda(2,1)
6026               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6027      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6028      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6029             enddo
6030           enddo
6031         enddo
6032 cd        goto 1112
6033         endif
6034 C Contribution from graph IV
6035 cd1110    continue
6036         call transpose2(EE(1,1,itl),auxmat(1,1))
6037         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6038         vv(1)=pizda(1,1)+pizda(2,2)
6039         vv(2)=pizda(2,1)-pizda(1,2)
6040         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6041      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6042         if (calc_grad) then
6043 C Explicit gradient in virtual-dihedral angles.
6044         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6045      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6046         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6050      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6051      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6052 C Cartesian gradient
6053         do iii=1,2
6054           do kkk=1,5
6055             do lll=1,3
6056               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6057      &          pizda(1,1))
6058               vv(1)=pizda(1,1)+pizda(2,2)
6059               vv(2)=pizda(2,1)-pizda(1,2)
6060               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6061      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6062      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6063             enddo
6064           enddo
6065         enddo
6066         endif
6067       else
6068 C Antiparallel orientation
6069 C Contribution from graph III
6070 c        goto 1110
6071         call transpose2(EUg(1,1,j),auxmat(1,1))
6072         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6073         vv(1)=pizda(1,1)-pizda(2,2)
6074         vv(2)=pizda(1,2)+pizda(2,1)
6075         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6076      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6077         if (calc_grad) then
6078 C Explicit gradient in virtual-dihedral angles.
6079         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6080      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6081      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6082         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6083         vv(1)=pizda(1,1)-pizda(2,2)
6084         vv(2)=pizda(1,2)+pizda(2,1)
6085         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6086      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6087      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6088         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6089         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6090         vv(1)=pizda(1,1)-pizda(2,2)
6091         vv(2)=pizda(1,2)+pizda(2,1)
6092         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6093      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6094      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6095 C Cartesian gradient
6096         do iii=1,2
6097           do kkk=1,5
6098             do lll=1,3
6099               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6100      &          pizda(1,1))
6101               vv(1)=pizda(1,1)-pizda(2,2)
6102               vv(2)=pizda(1,2)+pizda(2,1)
6103               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6104      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6105      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6106             enddo
6107           enddo
6108         enddo
6109 cd        goto 1112
6110         endif
6111 C Contribution from graph IV
6112 1110    continue
6113         call transpose2(EE(1,1,itj),auxmat(1,1))
6114         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6115         vv(1)=pizda(1,1)+pizda(2,2)
6116         vv(2)=pizda(2,1)-pizda(1,2)
6117         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6118      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6119         if (calc_grad) then
6120 C Explicit gradient in virtual-dihedral angles.
6121         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6122      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6123         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6127      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6128      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6129 C Cartesian gradient
6130         do iii=1,2
6131           do kkk=1,5
6132             do lll=1,3
6133               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6134      &          pizda(1,1))
6135               vv(1)=pizda(1,1)+pizda(2,2)
6136               vv(2)=pizda(2,1)-pizda(1,2)
6137               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6138      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6139      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6140             enddo
6141           enddo
6142         enddo
6143       endif
6144       endif
6145 1112  continue
6146       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6147 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6148 cd        write (2,*) 'ijkl',i,j,k,l
6149 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6150 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6151 cd      endif
6152 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6153 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6154 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6155 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6156       if (calc_grad) then
6157       if (j.lt.nres-1) then
6158         j1=j+1
6159         j2=j-1
6160       else
6161         j1=j-1
6162         j2=j-2
6163       endif
6164       if (l.lt.nres-1) then
6165         l1=l+1
6166         l2=l-1
6167       else
6168         l1=l-1
6169         l2=l-2
6170       endif
6171 cd      eij=1.0d0
6172 cd      ekl=1.0d0
6173 cd      ekont=1.0d0
6174 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6175       do ll=1,3
6176         ggg1(ll)=eel5*g_contij(ll,1)
6177         ggg2(ll)=eel5*g_contij(ll,2)
6178 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6179         ghalf=0.5d0*ggg1(ll)
6180 cd        ghalf=0.0d0
6181         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6182         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6183         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6184         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6185 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6186         ghalf=0.5d0*ggg2(ll)
6187 cd        ghalf=0.0d0
6188         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6189         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6190         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6191         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6192       enddo
6193 cd      goto 1112
6194       do m=i+1,j-1
6195         do ll=1,3
6196 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6197           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6198         enddo
6199       enddo
6200       do m=k+1,l-1
6201         do ll=1,3
6202 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6203           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6204         enddo
6205       enddo
6206 c1112  continue
6207       do m=i+2,j2
6208         do ll=1,3
6209           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6210         enddo
6211       enddo
6212       do m=k+2,l2
6213         do ll=1,3
6214           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6215         enddo
6216       enddo
6217 cd      do iii=1,nres-3
6218 cd        write (2,*) iii,g_corr5_loc(iii)
6219 cd      enddo
6220       endif
6221       eello5=ekont*eel5
6222 cd      write (2,*) 'ekont',ekont
6223 cd      write (iout,*) 'eello5',ekont*eel5
6224       return
6225       end
6226 c--------------------------------------------------------------------------
6227       double precision function eello6(i,j,k,l,jj,kk)
6228       implicit real*8 (a-h,o-z)
6229       include 'DIMENSIONS'
6230       include 'DIMENSIONS.ZSCOPT'
6231       include 'COMMON.IOUNITS'
6232       include 'COMMON.CHAIN'
6233       include 'COMMON.DERIV'
6234       include 'COMMON.INTERACT'
6235       include 'COMMON.CONTACTS'
6236       include 'COMMON.TORSION'
6237       include 'COMMON.VAR'
6238       include 'COMMON.GEO'
6239       include 'COMMON.FFIELD'
6240       double precision ggg1(3),ggg2(3)
6241 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6242 cd        eello6=0.0d0
6243 cd        return
6244 cd      endif
6245 cd      write (iout,*)
6246 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6247 cd     &   ' and',k,l
6248       eello6_1=0.0d0
6249       eello6_2=0.0d0
6250       eello6_3=0.0d0
6251       eello6_4=0.0d0
6252       eello6_5=0.0d0
6253       eello6_6=0.0d0
6254 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6255 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6256       do iii=1,2
6257         do kkk=1,5
6258           do lll=1,3
6259             derx(lll,kkk,iii)=0.0d0
6260           enddo
6261         enddo
6262       enddo
6263 cd      eij=facont_hb(jj,i)
6264 cd      ekl=facont_hb(kk,k)
6265 cd      ekont=eij*ekl
6266 cd      eij=1.0d0
6267 cd      ekl=1.0d0
6268 cd      ekont=1.0d0
6269       if (l.eq.j+1) then
6270         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6271         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6272         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6273         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6274         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6275         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6276       else
6277         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6278         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6279         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6280         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6281         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6282           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6283         else
6284           eello6_5=0.0d0
6285         endif
6286         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6287       endif
6288 C If turn contributions are considered, they will be handled separately.
6289       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6290 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6291 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6292 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6293 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6294 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6295 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6296 cd      goto 1112
6297       if (calc_grad) then
6298       if (j.lt.nres-1) then
6299         j1=j+1
6300         j2=j-1
6301       else
6302         j1=j-1
6303         j2=j-2
6304       endif
6305       if (l.lt.nres-1) then
6306         l1=l+1
6307         l2=l-1
6308       else
6309         l1=l-1
6310         l2=l-2
6311       endif
6312       do ll=1,3
6313         ggg1(ll)=eel6*g_contij(ll,1)
6314         ggg2(ll)=eel6*g_contij(ll,2)
6315 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6316         ghalf=0.5d0*ggg1(ll)
6317 cd        ghalf=0.0d0
6318         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6319         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6320         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6321         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6322         ghalf=0.5d0*ggg2(ll)
6323 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6324 cd        ghalf=0.0d0
6325         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6326         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6327         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6328         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6329       enddo
6330 cd      goto 1112
6331       do m=i+1,j-1
6332         do ll=1,3
6333 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6334           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6335         enddo
6336       enddo
6337       do m=k+1,l-1
6338         do ll=1,3
6339 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6340           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6341         enddo
6342       enddo
6343 1112  continue
6344       do m=i+2,j2
6345         do ll=1,3
6346           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6347         enddo
6348       enddo
6349       do m=k+2,l2
6350         do ll=1,3
6351           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6352         enddo
6353       enddo
6354 cd      do iii=1,nres-3
6355 cd        write (2,*) iii,g_corr6_loc(iii)
6356 cd      enddo
6357       endif
6358       eello6=ekont*eel6
6359 cd      write (2,*) 'ekont',ekont
6360 cd      write (iout,*) 'eello6',ekont*eel6
6361       return
6362       end
6363 c--------------------------------------------------------------------------
6364       double precision function eello6_graph1(i,j,k,l,imat,swap)
6365       implicit real*8 (a-h,o-z)
6366       include 'DIMENSIONS'
6367       include 'DIMENSIONS.ZSCOPT'
6368       include 'COMMON.IOUNITS'
6369       include 'COMMON.CHAIN'
6370       include 'COMMON.DERIV'
6371       include 'COMMON.INTERACT'
6372       include 'COMMON.CONTACTS'
6373       include 'COMMON.TORSION'
6374       include 'COMMON.VAR'
6375       include 'COMMON.GEO'
6376       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6377       logical swap
6378       logical lprn
6379       common /kutas/ lprn
6380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6381 C                                                                              C
6382 C      Parallel       Antiparallel                                             C
6383 C                                                                              C
6384 C          o             o                                                     C
6385 C         /l\           /j\                                                    C
6386 C        /   \         /   \                                                   C
6387 C       /| o |         | o |\                                                  C
6388 C     \ j|/k\|  /   \  |/k\|l /                                                C
6389 C      \ /   \ /     \ /   \ /                                                 C
6390 C       o     o       o     o                                                  C
6391 C       i             i                                                        C
6392 C                                                                              C
6393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6394       itk=itortyp(itype(k))
6395       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6396       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6397       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6398       call transpose2(EUgC(1,1,k),auxmat(1,1))
6399       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6400       vv1(1)=pizda1(1,1)-pizda1(2,2)
6401       vv1(2)=pizda1(1,2)+pizda1(2,1)
6402       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6403       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6404       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6405       s5=scalar2(vv(1),Dtobr2(1,i))
6406 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6407       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6408       if (.not. calc_grad) return
6409       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6410      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6411      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6412      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6413      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6414      & +scalar2(vv(1),Dtobr2der(1,i)))
6415       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6416       vv1(1)=pizda1(1,1)-pizda1(2,2)
6417       vv1(2)=pizda1(1,2)+pizda1(2,1)
6418       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6419       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6420       if (l.eq.j+1) then
6421         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6422      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6423      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6424      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6425      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6426       else
6427         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6428      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6429      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6430      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6431      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6432       endif
6433       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6434       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6435       vv1(1)=pizda1(1,1)-pizda1(2,2)
6436       vv1(2)=pizda1(1,2)+pizda1(2,1)
6437       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6438      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6439      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6440      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6441       do iii=1,2
6442         if (swap) then
6443           ind=3-iii
6444         else
6445           ind=iii
6446         endif
6447         do kkk=1,5
6448           do lll=1,3
6449             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6450             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6451             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6452             call transpose2(EUgC(1,1,k),auxmat(1,1))
6453             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6454      &        pizda1(1,1))
6455             vv1(1)=pizda1(1,1)-pizda1(2,2)
6456             vv1(2)=pizda1(1,2)+pizda1(2,1)
6457             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6458             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6459      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6460             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6461      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6462             s5=scalar2(vv(1),Dtobr2(1,i))
6463             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6464           enddo
6465         enddo
6466       enddo
6467       return
6468       end
6469 c----------------------------------------------------------------------------
6470       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6471       implicit real*8 (a-h,o-z)
6472       include 'DIMENSIONS'
6473       include 'DIMENSIONS.ZSCOPT'
6474       include 'COMMON.IOUNITS'
6475       include 'COMMON.CHAIN'
6476       include 'COMMON.DERIV'
6477       include 'COMMON.INTERACT'
6478       include 'COMMON.CONTACTS'
6479       include 'COMMON.TORSION'
6480       include 'COMMON.VAR'
6481       include 'COMMON.GEO'
6482       logical swap
6483       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6484      & auxvec1(2),auxvec2(1),auxmat1(2,2)
6485       logical lprn
6486       common /kutas/ lprn
6487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6488 C                                                                              C
6489 C      Parallel       Antiparallel                                             C
6490 C                                                                              C
6491 C          o             o                                                     C
6492 C     \   /l\           /j\   /                                                C
6493 C      \ /   \         /   \ /                                                 C
6494 C       o| o |         | o |o                                                  C
6495 C     \ j|/k\|      \  |/k\|l                                                  C
6496 C      \ /   \       \ /   \                                                   C
6497 C       o             o                                                        C
6498 C       i             i                                                        C
6499 C                                                                              C
6500 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6501 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6502 C AL 7/4/01 s1 would occur in the sixth-order moment,
6503 C           but not in a cluster cumulant
6504 #ifdef MOMENT
6505       s1=dip(1,jj,i)*dip(1,kk,k)
6506 #endif
6507       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6508       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6509       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6510       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6511       call transpose2(EUg(1,1,k),auxmat(1,1))
6512       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6513       vv(1)=pizda(1,1)-pizda(2,2)
6514       vv(2)=pizda(1,2)+pizda(2,1)
6515       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6516 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6517 #ifdef MOMENT
6518       eello6_graph2=-(s1+s2+s3+s4)
6519 #else
6520       eello6_graph2=-(s2+s3+s4)
6521 #endif
6522 c      eello6_graph2=-s3
6523       if (.not. calc_grad) return
6524 C Derivatives in gamma(i-1)
6525       if (i.gt.1) then
6526 #ifdef MOMENT
6527         s1=dipderg(1,jj,i)*dip(1,kk,k)
6528 #endif
6529         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6530         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6531         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6532         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6533 #ifdef MOMENT
6534         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6535 #else
6536         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6537 #endif
6538 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6539       endif
6540 C Derivatives in gamma(k-1)
6541 #ifdef MOMENT
6542       s1=dip(1,jj,i)*dipderg(1,kk,k)
6543 #endif
6544       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6545       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6546       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6547       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6548       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6549       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6550       vv(1)=pizda(1,1)-pizda(2,2)
6551       vv(2)=pizda(1,2)+pizda(2,1)
6552       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6553 #ifdef MOMENT
6554       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6555 #else
6556       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6557 #endif
6558 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6559 C Derivatives in gamma(j-1) or gamma(l-1)
6560       if (j.gt.1) then
6561 #ifdef MOMENT
6562         s1=dipderg(3,jj,i)*dip(1,kk,k)
6563 #endif
6564         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6565         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6566         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6567         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6568         vv(1)=pizda(1,1)-pizda(2,2)
6569         vv(2)=pizda(1,2)+pizda(2,1)
6570         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6571 #ifdef MOMENT
6572         if (swap) then
6573           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6574         else
6575           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6576         endif
6577 #endif
6578         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6579 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6580       endif
6581 C Derivatives in gamma(l-1) or gamma(j-1)
6582       if (l.gt.1) then
6583 #ifdef MOMENT
6584         s1=dip(1,jj,i)*dipderg(3,kk,k)
6585 #endif
6586         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6587         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6588         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6589         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6590         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6591         vv(1)=pizda(1,1)-pizda(2,2)
6592         vv(2)=pizda(1,2)+pizda(2,1)
6593         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6594 #ifdef MOMENT
6595         if (swap) then
6596           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6597         else
6598           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6599         endif
6600 #endif
6601         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6602 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6603       endif
6604 C Cartesian derivatives.
6605       if (lprn) then
6606         write (2,*) 'In eello6_graph2'
6607         do iii=1,2
6608           write (2,*) 'iii=',iii
6609           do kkk=1,5
6610             write (2,*) 'kkk=',kkk
6611             do jjj=1,2
6612               write (2,'(3(2f10.5),5x)')
6613      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6614             enddo
6615           enddo
6616         enddo
6617       endif
6618       do iii=1,2
6619         do kkk=1,5
6620           do lll=1,3
6621 #ifdef MOMENT
6622             if (iii.eq.1) then
6623               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6624             else
6625               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6626             endif
6627 #endif
6628             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6629      &        auxvec(1))
6630             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6631             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6632      &        auxvec(1))
6633             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6634             call transpose2(EUg(1,1,k),auxmat(1,1))
6635             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6636      &        pizda(1,1))
6637             vv(1)=pizda(1,1)-pizda(2,2)
6638             vv(2)=pizda(1,2)+pizda(2,1)
6639             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6640 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6641 #ifdef MOMENT
6642             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6643 #else
6644             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6645 #endif
6646             if (swap) then
6647               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6648             else
6649               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6650             endif
6651           enddo
6652         enddo
6653       enddo
6654       return
6655       end
6656 c----------------------------------------------------------------------------
6657       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6658       implicit real*8 (a-h,o-z)
6659       include 'DIMENSIONS'
6660       include 'DIMENSIONS.ZSCOPT'
6661       include 'COMMON.IOUNITS'
6662       include 'COMMON.CHAIN'
6663       include 'COMMON.DERIV'
6664       include 'COMMON.INTERACT'
6665       include 'COMMON.CONTACTS'
6666       include 'COMMON.TORSION'
6667       include 'COMMON.VAR'
6668       include 'COMMON.GEO'
6669       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6670       logical swap
6671 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6672 C                                                                              C
6673 C      Parallel       Antiparallel                                             C
6674 C                                                                              C
6675 C          o             o                                                     C
6676 C         /l\   /   \   /j\                                                    C
6677 C        /   \ /     \ /   \                                                   C
6678 C       /| o |o       o| o |\                                                  C
6679 C       j|/k\|  /      |/k\|l /                                                C
6680 C        /   \ /       /   \ /                                                 C
6681 C       /     o       /     o                                                  C
6682 C       i             i                                                        C
6683 C                                                                              C
6684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6685 C
6686 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6687 C           energy moment and not to the cluster cumulant.
6688       iti=itortyp(itype(i))
6689       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6690         itj1=itortyp(itype(j+1))
6691       else
6692         itj1=ntortyp+1
6693       endif
6694       itk=itortyp(itype(k))
6695       itk1=itortyp(itype(k+1))
6696       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6697         itl1=itortyp(itype(l+1))
6698       else
6699         itl1=ntortyp+1
6700       endif
6701 #ifdef MOMENT
6702       s1=dip(4,jj,i)*dip(4,kk,k)
6703 #endif
6704       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6705       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6706       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6707       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6708       call transpose2(EE(1,1,itk),auxmat(1,1))
6709       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6710       vv(1)=pizda(1,1)+pizda(2,2)
6711       vv(2)=pizda(2,1)-pizda(1,2)
6712       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6713 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6714 #ifdef MOMENT
6715       eello6_graph3=-(s1+s2+s3+s4)
6716 #else
6717       eello6_graph3=-(s2+s3+s4)
6718 #endif
6719 c      eello6_graph3=-s4
6720       if (.not. calc_grad) return
6721 C Derivatives in gamma(k-1)
6722       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6723       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6724       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6725       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6726 C Derivatives in gamma(l-1)
6727       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6728       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6729       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6730       vv(1)=pizda(1,1)+pizda(2,2)
6731       vv(2)=pizda(2,1)-pizda(1,2)
6732       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6733       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6734 C Cartesian derivatives.
6735       do iii=1,2
6736         do kkk=1,5
6737           do lll=1,3
6738 #ifdef MOMENT
6739             if (iii.eq.1) then
6740               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6741             else
6742               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6743             endif
6744 #endif
6745             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6746      &        auxvec(1))
6747             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6748             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6749      &        auxvec(1))
6750             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6751             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6752      &        pizda(1,1))
6753             vv(1)=pizda(1,1)+pizda(2,2)
6754             vv(2)=pizda(2,1)-pizda(1,2)
6755             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6756 #ifdef MOMENT
6757             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6758 #else
6759             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6760 #endif
6761             if (swap) then
6762               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6763             else
6764               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6765             endif
6766 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6767           enddo
6768         enddo
6769       enddo
6770       return
6771       end
6772 c----------------------------------------------------------------------------
6773       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6774       implicit real*8 (a-h,o-z)
6775       include 'DIMENSIONS'
6776       include 'DIMENSIONS.ZSCOPT'
6777       include 'COMMON.IOUNITS'
6778       include 'COMMON.CHAIN'
6779       include 'COMMON.DERIV'
6780       include 'COMMON.INTERACT'
6781       include 'COMMON.CONTACTS'
6782       include 'COMMON.TORSION'
6783       include 'COMMON.VAR'
6784       include 'COMMON.GEO'
6785       include 'COMMON.FFIELD'
6786       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6787      & auxvec1(2),auxmat1(2,2)
6788       logical swap
6789 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6790 C                                                                              C
6791 C      Parallel       Antiparallel                                             C
6792 C                                                                              C
6793 C          o             o                                                     C
6794 C         /l\   /   \   /j\                                                    C
6795 C        /   \ /     \ /   \                                                   C
6796 C       /| o |o       o| o |\                                                  C
6797 C     \ j|/k\|      \  |/k\|l                                                  C
6798 C      \ /   \       \ /   \                                                   C
6799 C       o     \       o     \                                                  C
6800 C       i             i                                                        C
6801 C                                                                              C
6802 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6803 C
6804 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6805 C           energy moment and not to the cluster cumulant.
6806 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6807       iti=itortyp(itype(i))
6808       itj=itortyp(itype(j))
6809       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6810         itj1=itortyp(itype(j+1))
6811       else
6812         itj1=ntortyp+1
6813       endif
6814       itk=itortyp(itype(k))
6815       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
6816         itk1=itortyp(itype(k+1))
6817       else
6818         itk1=ntortyp+1
6819       endif
6820       itl=itortyp(itype(l))
6821       if (l.lt.nres-1) then
6822         itl1=itortyp(itype(l+1))
6823       else
6824         itl1=ntortyp+1
6825       endif
6826 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6827 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6828 cd     & ' itl',itl,' itl1',itl1
6829 #ifdef MOMENT
6830       if (imat.eq.1) then
6831         s1=dip(3,jj,i)*dip(3,kk,k)
6832       else
6833         s1=dip(2,jj,j)*dip(2,kk,l)
6834       endif
6835 #endif
6836       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6837       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6838       if (j.eq.l+1) then
6839         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6840         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6841       else
6842         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6843         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6844       endif
6845       call transpose2(EUg(1,1,k),auxmat(1,1))
6846       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6847       vv(1)=pizda(1,1)-pizda(2,2)
6848       vv(2)=pizda(2,1)+pizda(1,2)
6849       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6850 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6851 #ifdef MOMENT
6852       eello6_graph4=-(s1+s2+s3+s4)
6853 #else
6854       eello6_graph4=-(s2+s3+s4)
6855 #endif
6856       if (.not. calc_grad) return
6857 C Derivatives in gamma(i-1)
6858       if (i.gt.1) then
6859 #ifdef MOMENT
6860         if (imat.eq.1) then
6861           s1=dipderg(2,jj,i)*dip(3,kk,k)
6862         else
6863           s1=dipderg(4,jj,j)*dip(2,kk,l)
6864         endif
6865 #endif
6866         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6867         if (j.eq.l+1) then
6868           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6869           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6870         else
6871           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6872           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6873         endif
6874         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6875         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6876 cd          write (2,*) 'turn6 derivatives'
6877 #ifdef MOMENT
6878           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6879 #else
6880           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6881 #endif
6882         else
6883 #ifdef MOMENT
6884           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6885 #else
6886           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6887 #endif
6888         endif
6889       endif
6890 C Derivatives in gamma(k-1)
6891 #ifdef MOMENT
6892       if (imat.eq.1) then
6893         s1=dip(3,jj,i)*dipderg(2,kk,k)
6894       else
6895         s1=dip(2,jj,j)*dipderg(4,kk,l)
6896       endif
6897 #endif
6898       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
6899       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
6900       if (j.eq.l+1) then
6901         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
6902         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6903       else
6904         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
6905         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6906       endif
6907       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6908       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
6909       vv(1)=pizda(1,1)-pizda(2,2)
6910       vv(2)=pizda(2,1)+pizda(1,2)
6911       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6912       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6913 #ifdef MOMENT
6914         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
6915 #else
6916         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
6917 #endif
6918       else
6919 #ifdef MOMENT
6920         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6921 #else
6922         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6923 #endif
6924       endif
6925 C Derivatives in gamma(j-1) or gamma(l-1)
6926       if (l.eq.j+1 .and. l.gt.1) then
6927         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6928         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6929         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6930         vv(1)=pizda(1,1)-pizda(2,2)
6931         vv(2)=pizda(2,1)+pizda(1,2)
6932         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6933         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6934       else if (j.gt.1) then
6935         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6936         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6937         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6938         vv(1)=pizda(1,1)-pizda(2,2)
6939         vv(2)=pizda(2,1)+pizda(1,2)
6940         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6941         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6942           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
6943         else
6944           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
6945         endif
6946       endif
6947 C Cartesian derivatives.
6948       do iii=1,2
6949         do kkk=1,5
6950           do lll=1,3
6951 #ifdef MOMENT
6952             if (iii.eq.1) then
6953               if (imat.eq.1) then
6954                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
6955               else
6956                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
6957               endif
6958             else
6959               if (imat.eq.1) then
6960                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
6961               else
6962                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
6963               endif
6964             endif
6965 #endif
6966             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
6967      &        auxvec(1))
6968             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6969             if (j.eq.l+1) then
6970               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6971      &          b1(1,itj1),auxvec(1))
6972               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
6973             else
6974               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6975      &          b1(1,itl1),auxvec(1))
6976               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
6977             endif
6978             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6979      &        pizda(1,1))
6980             vv(1)=pizda(1,1)-pizda(2,2)
6981             vv(2)=pizda(2,1)+pizda(1,2)
6982             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6983             if (swap) then
6984               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6985 #ifdef MOMENT
6986                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6987      &             -(s1+s2+s4)
6988 #else
6989                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6990      &             -(s2+s4)
6991 #endif
6992                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
6993               else
6994 #ifdef MOMENT
6995                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
6996 #else
6997                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
6998 #endif
6999                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7000               endif
7001             else
7002 #ifdef MOMENT
7003               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7004 #else
7005               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7006 #endif
7007               if (l.eq.j+1) then
7008                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7009               else
7010                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7011               endif
7012             endif
7013           enddo
7014         enddo
7015       enddo
7016       return
7017       end
7018 c----------------------------------------------------------------------------
7019       double precision function eello_turn6(i,jj,kk)
7020       implicit real*8 (a-h,o-z)
7021       include 'DIMENSIONS'
7022       include 'DIMENSIONS.ZSCOPT'
7023       include 'COMMON.IOUNITS'
7024       include 'COMMON.CHAIN'
7025       include 'COMMON.DERIV'
7026       include 'COMMON.INTERACT'
7027       include 'COMMON.CONTACTS'
7028       include 'COMMON.TORSION'
7029       include 'COMMON.VAR'
7030       include 'COMMON.GEO'
7031       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7032      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7033      &  ggg1(3),ggg2(3)
7034       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7035      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7036 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7037 C           the respective energy moment and not to the cluster cumulant.
7038       eello_turn6=0.0d0
7039       j=i+4
7040       k=i+1
7041       l=i+3
7042       iti=itortyp(itype(i))
7043       itk=itortyp(itype(k))
7044       itk1=itortyp(itype(k+1))
7045       itl=itortyp(itype(l))
7046       itj=itortyp(itype(j))
7047 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7048 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7049 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7050 cd        eello6=0.0d0
7051 cd        return
7052 cd      endif
7053 cd      write (iout,*)
7054 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7055 cd     &   ' and',k,l
7056 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7057       do iii=1,2
7058         do kkk=1,5
7059           do lll=1,3
7060             derx_turn(lll,kkk,iii)=0.0d0
7061           enddo
7062         enddo
7063       enddo
7064 cd      eij=1.0d0
7065 cd      ekl=1.0d0
7066 cd      ekont=1.0d0
7067       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7068 cd      eello6_5=0.0d0
7069 cd      write (2,*) 'eello6_5',eello6_5
7070 #ifdef MOMENT
7071       call transpose2(AEA(1,1,1),auxmat(1,1))
7072       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7073       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7074       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7075 #else
7076       s1 = 0.0d0
7077 #endif
7078       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7079       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7080       s2 = scalar2(b1(1,itk),vtemp1(1))
7081 #ifdef MOMENT
7082       call transpose2(AEA(1,1,2),atemp(1,1))
7083       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7084       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7085       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7086 #else
7087       s8=0.0d0
7088 #endif
7089       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7090       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7091       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7092 #ifdef MOMENT
7093       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7094       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7095       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7096       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7097       ss13 = scalar2(b1(1,itk),vtemp4(1))
7098       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7099 #else
7100       s13=0.0d0
7101 #endif
7102 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7103 c      s1=0.0d0
7104 c      s2=0.0d0
7105 c      s8=0.0d0
7106 c      s12=0.0d0
7107 c      s13=0.0d0
7108       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7109       if (calc_grad) then
7110 C Derivatives in gamma(i+2)
7111 #ifdef MOMENT
7112       call transpose2(AEA(1,1,1),auxmatd(1,1))
7113       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7114       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7115       call transpose2(AEAderg(1,1,2),atempd(1,1))
7116       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7117       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7118 #else
7119       s8d=0.0d0
7120 #endif
7121       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7122       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7123       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7124 c      s1d=0.0d0
7125 c      s2d=0.0d0
7126 c      s8d=0.0d0
7127 c      s12d=0.0d0
7128 c      s13d=0.0d0
7129       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7130 C Derivatives in gamma(i+3)
7131 #ifdef MOMENT
7132       call transpose2(AEA(1,1,1),auxmatd(1,1))
7133       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7134       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7135       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7136 #else
7137       s1d=0.0d0
7138 #endif
7139       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7140       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7141       s2d = scalar2(b1(1,itk),vtemp1d(1))
7142 #ifdef MOMENT
7143       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7144       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7145 #endif
7146       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7147 #ifdef MOMENT
7148       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7149       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7150       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7151 #else
7152       s13d=0.0d0
7153 #endif
7154 c      s1d=0.0d0
7155 c      s2d=0.0d0
7156 c      s8d=0.0d0
7157 c      s12d=0.0d0
7158 c      s13d=0.0d0
7159 #ifdef MOMENT
7160       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7161      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7162 #else
7163       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7164      &               -0.5d0*ekont*(s2d+s12d)
7165 #endif
7166 C Derivatives in gamma(i+4)
7167       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7168       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7169       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7170 #ifdef MOMENT
7171       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7172       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7173       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7174 #else
7175       s13d = 0.0d0
7176 #endif
7177 c      s1d=0.0d0
7178 c      s2d=0.0d0
7179 c      s8d=0.0d0
7180 C      s12d=0.0d0
7181 c      s13d=0.0d0
7182 #ifdef MOMENT
7183       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7184 #else
7185       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7186 #endif
7187 C Derivatives in gamma(i+5)
7188 #ifdef MOMENT
7189       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7190       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7191       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7192 #else
7193       s1d = 0.0d0
7194 #endif
7195       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7196       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7197       s2d = scalar2(b1(1,itk),vtemp1d(1))
7198 #ifdef MOMENT
7199       call transpose2(AEA(1,1,2),atempd(1,1))
7200       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7201       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7202 #else
7203       s8d = 0.0d0
7204 #endif
7205       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7206       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7207 #ifdef MOMENT
7208       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7209       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7210       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7211 #else
7212       s13d = 0.0d0
7213 #endif
7214 c      s1d=0.0d0
7215 c      s2d=0.0d0
7216 c      s8d=0.0d0
7217 c      s12d=0.0d0
7218 c      s13d=0.0d0
7219 #ifdef MOMENT
7220       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7221      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7222 #else
7223       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7224      &               -0.5d0*ekont*(s2d+s12d)
7225 #endif
7226 C Cartesian derivatives
7227       do iii=1,2
7228         do kkk=1,5
7229           do lll=1,3
7230 #ifdef MOMENT
7231             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7232             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7233             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7234 #else
7235             s1d = 0.0d0
7236 #endif
7237             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7238             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7239      &          vtemp1d(1))
7240             s2d = scalar2(b1(1,itk),vtemp1d(1))
7241 #ifdef MOMENT
7242             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7243             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7244             s8d = -(atempd(1,1)+atempd(2,2))*
7245      &           scalar2(cc(1,1,itl),vtemp2(1))
7246 #else
7247             s8d = 0.0d0
7248 #endif
7249             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7250      &           auxmatd(1,1))
7251             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7252             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7253 c      s1d=0.0d0
7254 c      s2d=0.0d0
7255 c      s8d=0.0d0
7256 c      s12d=0.0d0
7257 c      s13d=0.0d0
7258 #ifdef MOMENT
7259             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7260      &        - 0.5d0*(s1d+s2d)
7261 #else
7262             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7263      &        - 0.5d0*s2d
7264 #endif
7265 #ifdef MOMENT
7266             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7267      &        - 0.5d0*(s8d+s12d)
7268 #else
7269             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7270      &        - 0.5d0*s12d
7271 #endif
7272           enddo
7273         enddo
7274       enddo
7275 #ifdef MOMENT
7276       do kkk=1,5
7277         do lll=1,3
7278           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7279      &      achuj_tempd(1,1))
7280           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7281           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7282           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7283           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7284           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7285      &      vtemp4d(1))
7286           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7287           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7288           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7289         enddo
7290       enddo
7291 #endif
7292 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7293 cd     &  16*eel_turn6_num
7294 cd      goto 1112
7295       if (j.lt.nres-1) then
7296         j1=j+1
7297         j2=j-1
7298       else
7299         j1=j-1
7300         j2=j-2
7301       endif
7302       if (l.lt.nres-1) then
7303         l1=l+1
7304         l2=l-1
7305       else
7306         l1=l-1
7307         l2=l-2
7308       endif
7309       do ll=1,3
7310         ggg1(ll)=eel_turn6*g_contij(ll,1)
7311         ggg2(ll)=eel_turn6*g_contij(ll,2)
7312         ghalf=0.5d0*ggg1(ll)
7313 cd        ghalf=0.0d0
7314         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7315      &    +ekont*derx_turn(ll,2,1)
7316         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7317         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7318      &    +ekont*derx_turn(ll,4,1)
7319         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7320         ghalf=0.5d0*ggg2(ll)
7321 cd        ghalf=0.0d0
7322         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7323      &    +ekont*derx_turn(ll,2,2)
7324         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7325         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7326      &    +ekont*derx_turn(ll,4,2)
7327         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7328       enddo
7329 cd      goto 1112
7330       do m=i+1,j-1
7331         do ll=1,3
7332           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7333         enddo
7334       enddo
7335       do m=k+1,l-1
7336         do ll=1,3
7337           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7338         enddo
7339       enddo
7340 1112  continue
7341       do m=i+2,j2
7342         do ll=1,3
7343           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7344         enddo
7345       enddo
7346       do m=k+2,l2
7347         do ll=1,3
7348           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7349         enddo
7350       enddo
7351 cd      do iii=1,nres-3
7352 cd        write (2,*) iii,g_corr6_loc(iii)
7353 cd      enddo
7354       endif
7355       eello_turn6=ekont*eel_turn6
7356 cd      write (2,*) 'ekont',ekont
7357 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7358       return
7359       end
7360 crc-------------------------------------------------
7361       SUBROUTINE MATVEC2(A1,V1,V2)
7362       implicit real*8 (a-h,o-z)
7363       include 'DIMENSIONS'
7364       DIMENSION A1(2,2),V1(2),V2(2)
7365 c      DO 1 I=1,2
7366 c        VI=0.0
7367 c        DO 3 K=1,2
7368 c    3     VI=VI+A1(I,K)*V1(K)
7369 c        Vaux(I)=VI
7370 c    1 CONTINUE
7371
7372       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7373       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7374
7375       v2(1)=vaux1
7376       v2(2)=vaux2
7377       END
7378 C---------------------------------------
7379       SUBROUTINE MATMAT2(A1,A2,A3)
7380       implicit real*8 (a-h,o-z)
7381       include 'DIMENSIONS'
7382       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7383 c      DIMENSION AI3(2,2)
7384 c        DO  J=1,2
7385 c          A3IJ=0.0
7386 c          DO K=1,2
7387 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7388 c          enddo
7389 c          A3(I,J)=A3IJ
7390 c       enddo
7391 c      enddo
7392
7393       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7394       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7395       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7396       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7397
7398       A3(1,1)=AI3_11
7399       A3(2,1)=AI3_21
7400       A3(1,2)=AI3_12
7401       A3(2,2)=AI3_22
7402       END
7403
7404 c-------------------------------------------------------------------------
7405       double precision function scalar2(u,v)
7406       implicit none
7407       double precision u(2),v(2)
7408       double precision sc
7409       integer i
7410       scalar2=u(1)*v(1)+u(2)*v(2)
7411       return
7412       end
7413
7414 C-----------------------------------------------------------------------------
7415
7416       subroutine transpose2(a,at)
7417       implicit none
7418       double precision a(2,2),at(2,2)
7419       at(1,1)=a(1,1)
7420       at(1,2)=a(2,1)
7421       at(2,1)=a(1,2)
7422       at(2,2)=a(2,2)
7423       return
7424       end
7425 c--------------------------------------------------------------------------
7426       subroutine transpose(n,a,at)
7427       implicit none
7428       integer n,i,j
7429       double precision a(n,n),at(n,n)
7430       do i=1,n
7431         do j=1,n
7432           at(j,i)=a(i,j)
7433         enddo
7434       enddo
7435       return
7436       end
7437 C---------------------------------------------------------------------------
7438       subroutine prodmat3(a1,a2,kk,transp,prod)
7439       implicit none
7440       integer i,j
7441       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7442       logical transp
7443 crc      double precision auxmat(2,2),prod_(2,2)
7444
7445       if (transp) then
7446 crc        call transpose2(kk(1,1),auxmat(1,1))
7447 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7448 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7449
7450            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7451      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7452            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7453      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7454            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7455      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7456            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7457      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7458
7459       else
7460 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7461 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7462
7463            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7464      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7465            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7466      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7467            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7468      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7469            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7470      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7471
7472       endif
7473 c      call transpose2(a2(1,1),a2t(1,1))
7474
7475 crc      print *,transp
7476 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7477 crc      print *,((prod(i,j),i=1,2),j=1,2)
7478
7479       return
7480       end
7481 C-----------------------------------------------------------------------------
7482       double precision function scalar(u,v)
7483       implicit none
7484       double precision u(3),v(3)
7485       double precision sc
7486       integer i
7487       sc=0.0d0
7488       do i=1,3
7489         sc=sc+u(i)*v(i)
7490       enddo
7491       scalar=sc
7492       return
7493       end
7494