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