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