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