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