source/cluster/wham/src-M-NEWCORR/energy_p_new.F

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