source/wham/src-M/energy_p_new.F

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