source/wham/src/energy_p_new.F

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