source/wham/src-M/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      write(iout,*) 'po elektostatyce'
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106  call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  52 C            write(iout,*) 'po eelec'
  53
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61
  62       call ebond(estr)
  63 C       write (iout,*) "estr",estr
  64 C
  65 C Calculate the disulfide-bridge and other energy and the contributions
  66 C from other distance constraints.
  67 cd    print *,'Calling EHPB'
  68       call edis(ehpb)
  69 cd    print *,'EHPB exitted succesfully.'
  70 C
  71 C Calculate the virtual-bond-angle energy.
  72 C
  73       call ebend(ebe)
  74 C      print *,'Bend energy finished.'
  75 C
  76 C Calculate the SC local energy.
  77 C
  78       call esc(escloc)
  79 C       print *,'SCLOC energy finished.'
  80 C
  81 C Calculate the virtual-bond torsional energy.
  82 C
  83 cd    print *,'nterm=',nterm
  84       call etor(etors,edihcnstr,fact(1))
  85 C
  86 C 6/23/01 Calculate double-torsional energy
  87 C
  88       call etor_d(etors_d,fact(2))
  89 C
  90 C 21/5/07 Calculate local sicdechain correlation energy
  91 C
  92       call eback_sc_corr(esccor)
  93
  94       if (wliptran.gt.0) then
  95         call Eliptransfer(eliptran)
  96       endif
  97
  98 C
  99 C 12/1/95 Multi-body terms
 100 C
 101       n_corr=0
 102       n_corr1=0
 103       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 104      &    .or. wturn6.gt.0.0d0) then
 105 c         print *,"calling multibody_eello"
 106          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 107 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 108 c         print *,ecorr,ecorr5,ecorr6,eturn6
 109       endif
 110       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 111          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 112       endif
 113 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 114 #ifdef SPLITELE
 115       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 116      & +wvdwpp*evdw1
 117      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 118      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 119      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 120      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 121      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 122      & +wbond*estr+wsccor*fact(1)*esccor+wliptran*eliptran
 123 #else
 124       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 125      & +welec*fact(1)*(ees+evdw1)
 126      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 127      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 128      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 129      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 130      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 131      & +wbond*estr+wsccor*fact(1)*esccor+wliptran*eliptran
 132 #endif
 133       energia(0)=etot
 134       energia(1)=evdw
 135 #ifdef SCP14
 136       energia(2)=evdw2-evdw2_14
 137       energia(17)=evdw2_14
 138 #else
 139       energia(2)=evdw2
 140       energia(17)=0.0d0
 141 #endif
 142 #ifdef SPLITELE
 143       energia(3)=ees
 144       energia(16)=evdw1
 145 #else
 146       energia(3)=ees+evdw1
 147       energia(16)=0.0d0
 148 #endif
 149       energia(4)=ecorr
 150       energia(5)=ecorr5
 151       energia(6)=ecorr6
 152       energia(7)=eel_loc
 153       energia(8)=eello_turn3
 154       energia(9)=eello_turn4
 155       energia(10)=eturn6
 156       energia(11)=ebe
 157       energia(12)=escloc
 158       energia(13)=etors
 159       energia(14)=etors_d
 160       energia(15)=ehpb
 161       energia(18)=estr
 162       energia(19)=esccor
 163       energia(20)=edihcnstr
 164       energia(21)=evdw_t
 165       energia(22)=eliptran
 166
 167 c detecting NaNQ
 168 #ifdef ISNAN
 169 #ifdef AIX
 170       if (isnan(etot).ne.0) energia(0)=1.0d+99
 171 #else
 172       if (isnan(etot)) energia(0)=1.0d+99
 173 #endif
 174 #else
 175       i=0
 176 #ifdef WINPGI
 177       idumm=proc_proc(etot,i)
 178 #else
 179       call proc_proc(etot,i)
 180 #endif
 181       if(i.eq.1)energia(0)=1.0d+99
 182 #endif
 183 #ifdef MPL
 184 c     endif
 185 #endif
 186       if (calc_grad) then
 187 C
 188 C Sum up the components of the Cartesian gradient.
 189 C
 190 #ifdef SPLITELE
 191       do i=1,nct
 192         do j=1,3
 193           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 194      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 195      &                wbond*gradb(j,i)+
 196      &                wstrain*ghpbc(j,i)+
 197      &                wcorr*fact(3)*gradcorr(j,i)+
 198      &                wel_loc*fact(2)*gel_loc(j,i)+
 199      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 200      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 201      &                wcorr5*fact(4)*gradcorr5(j,i)+
 202      &                wcorr6*fact(5)*gradcorr6(j,i)+
 203      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 204      &                wsccor*fact(2)*gsccorc(j,i)
 205      &               +wliptran*gliptranc(j,i)
 206           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 207      &                  wbond*gradbx(j,i)+
 208      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 209      &                  wsccor*fact(2)*gsccorx(j,i)
 210      &                 +wliptran*gliptranx(j,i)
 211         enddo
 212 #else
 213       do i=1,nct
 214         do j=1,3
 215           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 216      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 217      &                wbond*gradb(j,i)+
 218      &                wcorr*fact(3)*gradcorr(j,i)+
 219      &                wel_loc*fact(2)*gel_loc(j,i)+
 220      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 221      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 222      &                wcorr5*fact(4)*gradcorr5(j,i)+
 223      &                wcorr6*fact(5)*gradcorr6(j,i)+
 224      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 225      &                wsccor*fact(2)*gsccorc(j,i)
 226      &               +wliptran*gliptranc(j,i)
 227           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 228      &                  wbond*gradbx(j,i)+
 229      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 230      &                  wsccor*fact(1)*gsccorx(j,i)
 231      &                 +wliptran*gliptranx(j,i)
 232         enddo
 233 #endif
 234       enddo
 235
 236
 237       do i=1,nres-3
 238         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 239      &   +wcorr5*fact(4)*g_corr5_loc(i)
 240      &   +wcorr6*fact(5)*g_corr6_loc(i)
 241      &   +wturn4*fact(3)*gel_loc_turn4(i)
 242      &   +wturn3*fact(2)*gel_loc_turn3(i)
 243      &   +wturn6*fact(5)*gel_loc_turn6(i)
 244      &   +wel_loc*fact(2)*gel_loc_loc(i)
 245       enddo
 246       endif
 247       return
 248       end
 249 C------------------------------------------------------------------------
 250       subroutine enerprint(energia,fact)
 251       implicit real*8 (a-h,o-z)
 252       include 'DIMENSIONS'
 253       include 'DIMENSIONS.ZSCOPT'
 254       include 'COMMON.IOUNITS'
 255       include 'COMMON.FFIELD'
 256       include 'COMMON.SBRIDGE'
 257       double precision energia(0:max_ene),fact(6)
 258       etot=energia(0)
 259       evdw=energia(1)+fact(6)*energia(21)
 260 #ifdef SCP14
 261       evdw2=energia(2)+energia(17)
 262 #else
 263       evdw2=energia(2)
 264 #endif
 265       ees=energia(3)
 266 #ifdef SPLITELE
 267       evdw1=energia(16)
 268 #endif
 269       ecorr=energia(4)
 270       ecorr5=energia(5)
 271       ecorr6=energia(6)
 272       eel_loc=energia(7)
 273       eello_turn3=energia(8)
 274       eello_turn4=energia(9)
 275       eello_turn6=energia(10)
 276       ebe=energia(11)
 277       escloc=energia(12)
 278       etors=energia(13)
 279       etors_d=energia(14)
 280       ehpb=energia(15)
 281       esccor=energia(19)
 282       edihcnstr=energia(20)
 283       estr=energia(18)
 284       eliptran=energia(22)
 285 #ifdef SPLITELE
 286       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 287      &  wvdwpp,
 288      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 289      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 290      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 291      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 292      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 293      &  esccor,wsccor*fact(1),edihcnstr,ebr*nss,eliptran,wliptran,etot
 294    10 format (/'Virtual-chain energies:'//
 295      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 296      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 297      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 298      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 299      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 300      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 301      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 302      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 303      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 304      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 305      & ' (SS bridges & dist. cnstr.)'/
 306      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 307      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 308      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 309      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 310      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 311      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 312      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 313      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 314      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 315      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 316      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 317      & 'ETOT=  ',1pE16.6,' (total)')
 318 #else
 319       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 320      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 321      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 322      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 323      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 324      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 325      &  edihcnstr,ebr*nss,eliptran,wliptran,etot
 326    10 format (/'Virtual-chain energies:'//
 327      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 328      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 329      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 330      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 331      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 332      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 333      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 334      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 335      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 336      & ' (SS bridges & dist. cnstr.)'/
 337      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 338      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 339      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 340      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 341      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 342      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 343      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 344      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 345      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 346      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 347      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 348      & 'ETOT=  ',1pE16.6,' (total)')
 349 #endif
 350       return
 351       end
 352 C-----------------------------------------------------------------------
 353       subroutine elj(evdw,evdw_t)
 354 C
 355 C This subroutine calculates the interaction energy of nonbonded side chains
 356 C assuming the LJ potential of interaction.
 357 C
 358       implicit real*8 (a-h,o-z)
 359       include 'DIMENSIONS'
 360       include 'DIMENSIONS.ZSCOPT'
 361       include "DIMENSIONS.COMPAR"
 362       parameter (accur=1.0d-10)
 363       include 'COMMON.GEO'
 364       include 'COMMON.VAR'
 365       include 'COMMON.LOCAL'
 366       include 'COMMON.CHAIN'
 367       include 'COMMON.DERIV'
 368       include 'COMMON.INTERACT'
 369       include 'COMMON.TORSION'
 370       include 'COMMON.ENEPS'
 371       include 'COMMON.SBRIDGE'
 372       include 'COMMON.NAMES'
 373       include 'COMMON.IOUNITS'
 374       include 'COMMON.CONTACTS'
 375       dimension gg(3)
 376       integer icant
 377       external icant
 378 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 379       do i=1,210
 380         do j=1,2
 381           eneps_temp(j,i)=0.0d0
 382         enddo
 383       enddo
 384       evdw=0.0D0
 385       evdw_t=0.0d0
 386       do i=iatsc_s,iatsc_e
 387         itypi=iabs(itype(i))
 388         if (itypi.eq.ntyp1) cycle
 389         itypi1=iabs(itype(i+1))
 390         xi=c(1,nres+i)
 391         yi=c(2,nres+i)
 392         zi=c(3,nres+i)
 393 C Change 12/1/95
 394         num_conti=0
 395 C
 396 C Calculate SC interaction energy.
 397 C
 398         do iint=1,nint_gr(i)
 399 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 400 cd   &                  'iend=',iend(i,iint)
 401           do j=istart(i,iint),iend(i,iint)
 402             itypj=iabs(itype(j))
 403             if (itypj.eq.ntyp1) cycle
 404             xj=c(1,nres+j)-xi
 405             yj=c(2,nres+j)-yi
 406             zj=c(3,nres+j)-zi
 407 C Change 12/1/95 to calculate four-body interactions
 408             rij=xj*xj+yj*yj+zj*zj
 409             rrij=1.0D0/rij
 410 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 411             eps0ij=eps(itypi,itypj)
 412             fac=rrij**expon2
 413             e1=fac*fac*aa
 414             e2=fac*bb
 415             evdwij=e1+e2
 416             ij=icant(itypi,itypj)
 417             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 418             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 419 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 420 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 421 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 422 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 423 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 424 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 425             if (bb.gt.0.0d0) then
 426               evdw=evdw+evdwij
 427             else
 428               evdw_t=evdw_t+evdwij
 429             endif
 430             if (calc_grad) then
 431 C
 432 C Calculate the components of the gradient in DC and X
 433 C
 434             fac=-rrij*(e1+evdwij)
 435             gg(1)=xj*fac
 436             gg(2)=yj*fac
 437             gg(3)=zj*fac
 438             do k=1,3
 439               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 440               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 441             enddo
 442             do k=i,j-1
 443               do l=1,3
 444                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 445               enddo
 446             enddo
 447             endif
 448 C
 449 C 12/1/95, revised on 5/20/97
 450 C
 451 C Calculate the contact function. The ith column of the array JCONT will
 452 C contain the numbers of atoms that make contacts with the atom I (of numbers
 453 C greater than I). The arrays FACONT and GACONT will contain the values of
 454 C the contact function and its derivative.
 455 C
 456 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 457 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 458 C Uncomment next line, if the correlation interactions are contact function only
 459             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 460               rij=dsqrt(rij)
 461               sigij=sigma(itypi,itypj)
 462               r0ij=rs0(itypi,itypj)
 463 C
 464 C Check whether the SC's are not too far to make a contact.
 465 C
 466               rcut=1.5d0*r0ij
 467               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 468 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 469 C
 470               if (fcont.gt.0.0D0) then
 471 C If the SC-SC distance if close to sigma, apply spline.
 472 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 473 cAdam &             fcont1,fprimcont1)
 474 cAdam           fcont1=1.0d0-fcont1
 475 cAdam           if (fcont1.gt.0.0d0) then
 476 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 477 cAdam             fcont=fcont*fcont1
 478 cAdam           endif
 479 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 480 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 481 cga             do k=1,3
 482 cga               gg(k)=gg(k)*eps0ij
 483 cga             enddo
 484 cga             eps0ij=-evdwij*eps0ij
 485 C Uncomment for AL's type of SC correlation interactions.
 486 cadam           eps0ij=-evdwij
 487                 num_conti=num_conti+1
 488                 jcont(num_conti,i)=j
 489                 facont(num_conti,i)=fcont*eps0ij
 490                 fprimcont=eps0ij*fprimcont/rij
 491                 fcont=expon*fcont
 492 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 493 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 494 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 495 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 496                 gacont(1,num_conti,i)=-fprimcont*xj
 497                 gacont(2,num_conti,i)=-fprimcont*yj
 498                 gacont(3,num_conti,i)=-fprimcont*zj
 499 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 500 cd              write (iout,'(2i3,3f10.5)')
 501 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 502               endif
 503             endif
 504           enddo      ! j
 505         enddo        ! iint
 506 C Change 12/1/95
 507         num_cont(i)=num_conti
 508       enddo          ! i
 509       if (calc_grad) then
 510       do i=1,nct
 511         do j=1,3
 512           gvdwc(j,i)=expon*gvdwc(j,i)
 513           gvdwx(j,i)=expon*gvdwx(j,i)
 514         enddo
 515       enddo
 516       endif
 517 C******************************************************************************
 518 C
 519 C                              N O T E !!!
 520 C
 521 C To save time, the factor of EXPON has been extracted from ALL components
 522 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 523 C use!
 524 C
 525 C******************************************************************************
 526       return
 527       end
 528 C-----------------------------------------------------------------------------
 529       subroutine eljk(evdw,evdw_t)
 530 C
 531 C This subroutine calculates the interaction energy of nonbonded side chains
 532 C assuming the LJK potential of interaction.
 533 C
 534       implicit real*8 (a-h,o-z)
 535       include 'DIMENSIONS'
 536       include 'DIMENSIONS.ZSCOPT'
 537       include "DIMENSIONS.COMPAR"
 538       include 'COMMON.GEO'
 539       include 'COMMON.VAR'
 540       include 'COMMON.LOCAL'
 541       include 'COMMON.CHAIN'
 542       include 'COMMON.DERIV'
 543       include 'COMMON.INTERACT'
 544       include 'COMMON.ENEPS'
 545       include 'COMMON.IOUNITS'
 546       include 'COMMON.NAMES'
 547       dimension gg(3)
 548       logical scheck
 549       integer icant
 550       external icant
 551 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 552       do i=1,210
 553         do j=1,2
 554           eneps_temp(j,i)=0.0d0
 555         enddo
 556       enddo
 557       evdw=0.0D0
 558       evdw_t=0.0d0
 559       do i=iatsc_s,iatsc_e
 560         itypi=iabs(itype(i))
 561         if (itypi.eq.ntyp1) cycle
 562         itypi1=iabs(itype(i+1))
 563         xi=c(1,nres+i)
 564         yi=c(2,nres+i)
 565         zi=c(3,nres+i)
 566 C
 567 C Calculate SC interaction energy.
 568 C
 569         do iint=1,nint_gr(i)
 570           do j=istart(i,iint),iend(i,iint)
 571             itypj=iabs(itype(j))
 572             if (itypj.eq.ntyp1) cycle
 573             xj=c(1,nres+j)-xi
 574             yj=c(2,nres+j)-yi
 575             zj=c(3,nres+j)-zi
 576             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 577             fac_augm=rrij**expon
 578             e_augm=augm(itypi,itypj)*fac_augm
 579             r_inv_ij=dsqrt(rrij)
 580             rij=1.0D0/r_inv_ij
 581             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 582             fac=r_shift_inv**expon
 583             e1=fac*fac*aa
 584             e2=fac*bb
 585             evdwij=e_augm+e1+e2
 586             ij=icant(itypi,itypj)
 587             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 588      &        /dabs(eps(itypi,itypj))
 589             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 590 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 591 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 592 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 593 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 594 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 595 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 596 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 597             if (bb.gt.0.0d0) then
 598               evdw=evdw+evdwij
 599             else
 600               evdw_t=evdw_t+evdwij
 601             endif
 602             if (calc_grad) then
 603 C
 604 C Calculate the components of the gradient in DC and X
 605 C
 606             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 607             gg(1)=xj*fac
 608             gg(2)=yj*fac
 609             gg(3)=zj*fac
 610             do k=1,3
 611               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 612               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 613             enddo
 614             do k=i,j-1
 615               do l=1,3
 616                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 617               enddo
 618             enddo
 619             endif
 620           enddo      ! j
 621         enddo        ! iint
 622       enddo          ! i
 623       if (calc_grad) then
 624       do i=1,nct
 625         do j=1,3
 626           gvdwc(j,i)=expon*gvdwc(j,i)
 627           gvdwx(j,i)=expon*gvdwx(j,i)
 628         enddo
 629       enddo
 630       endif
 631       return
 632       end
 633 C-----------------------------------------------------------------------------
 634       subroutine ebp(evdw,evdw_t)
 635 C
 636 C This subroutine calculates the interaction energy of nonbonded side chains
 637 C assuming the Berne-Pechukas potential of interaction.
 638 C
 639       implicit real*8 (a-h,o-z)
 640       include 'DIMENSIONS'
 641       include 'DIMENSIONS.ZSCOPT'
 642       include "DIMENSIONS.COMPAR"
 643       include 'COMMON.GEO'
 644       include 'COMMON.VAR'
 645       include 'COMMON.LOCAL'
 646       include 'COMMON.CHAIN'
 647       include 'COMMON.DERIV'
 648       include 'COMMON.NAMES'
 649       include 'COMMON.INTERACT'
 650       include 'COMMON.ENEPS'
 651       include 'COMMON.IOUNITS'
 652       include 'COMMON.CALC'
 653       common /srutu/ icall
 654 c     double precision rrsave(maxdim)
 655       logical lprn
 656       integer icant
 657       external icant
 658       do i=1,210
 659         do j=1,2
 660           eneps_temp(j,i)=0.0d0
 661         enddo
 662       enddo
 663       evdw=0.0D0
 664       evdw_t=0.0d0
 665 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 666 c     if (icall.eq.0) then
 667 c       lprn=.true.
 668 c     else
 669         lprn=.false.
 670 c     endif
 671       ind=0
 672       do i=iatsc_s,iatsc_e
 673         itypi=iabs(itype(i))
 674         if (itypi.eq.ntyp1) cycle
 675         itypi1=iabs(itype(i+1))
 676         xi=c(1,nres+i)
 677         yi=c(2,nres+i)
 678         zi=c(3,nres+i)
 679         dxi=dc_norm(1,nres+i)
 680         dyi=dc_norm(2,nres+i)
 681         dzi=dc_norm(3,nres+i)
 682         dsci_inv=vbld_inv(i+nres)
 683 C
 684 C Calculate SC interaction energy.
 685 C
 686         do iint=1,nint_gr(i)
 687           do j=istart(i,iint),iend(i,iint)
 688             ind=ind+1
 689             itypj=iabs(itype(j))
 690             if (itypj.eq.ntyp1) cycle
 691             dscj_inv=vbld_inv(j+nres)
 692             chi1=chi(itypi,itypj)
 693             chi2=chi(itypj,itypi)
 694             chi12=chi1*chi2
 695             chip1=chip(itypi)
 696             chip2=chip(itypj)
 697             chip12=chip1*chip2
 698             alf1=alp(itypi)
 699             alf2=alp(itypj)
 700             alf12=0.5D0*(alf1+alf2)
 701 C For diagnostics only!!!
 702 c           chi1=0.0D0
 703 c           chi2=0.0D0
 704 c           chi12=0.0D0
 705 c           chip1=0.0D0
 706 c           chip2=0.0D0
 707 c           chip12=0.0D0
 708 c           alf1=0.0D0
 709 c           alf2=0.0D0
 710 c           alf12=0.0D0
 711             xj=c(1,nres+j)-xi
 712             yj=c(2,nres+j)-yi
 713             zj=c(3,nres+j)-zi
 714             dxj=dc_norm(1,nres+j)
 715             dyj=dc_norm(2,nres+j)
 716             dzj=dc_norm(3,nres+j)
 717             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 718 cd          if (icall.eq.0) then
 719 cd            rrsave(ind)=rrij
 720 cd          else
 721 cd            rrij=rrsave(ind)
 722 cd          endif
 723             rij=dsqrt(rrij)
 724 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 725             call sc_angular
 726 C Calculate whole angle-dependent part of epsilon and contributions
 727 C to its derivatives
 728             fac=(rrij*sigsq)**expon2
 729             e1=fac*fac*aa
 730             e2=fac*bb
 731             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 732             eps2der=evdwij*eps3rt
 733             eps3der=evdwij*eps2rt
 734             evdwij=evdwij*eps2rt*eps3rt
 735             ij=icant(itypi,itypj)
 736             aux=eps1*eps2rt**2*eps3rt**2
 737             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 738      &        /dabs(eps(itypi,itypj))
 739             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 740             if (bb.gt.0.0d0) then
 741               evdw=evdw+evdwij
 742             else
 743               evdw_t=evdw_t+evdwij
 744             endif
 745             if (calc_grad) then
 746             if (lprn) then
 747             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 748             epsi=bb**2/aa
 749             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 750      &        restyp(itypi),i,restyp(itypj),j,
 751      &        epsi,sigm,chi1,chi2,chip1,chip2,
 752      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 753      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 754      &        evdwij
 755             endif
 756 C Calculate gradient components.
 757             e1=e1*eps1*eps2rt**2*eps3rt**2
 758             fac=-expon*(e1+evdwij)
 759             sigder=fac/sigsq
 760             fac=rrij*fac
 761 C Calculate radial part of the gradient
 762             gg(1)=xj*fac
 763             gg(2)=yj*fac
 764             gg(3)=zj*fac
 765 C Calculate the angular part of the gradient and sum add the contributions
 766 C to the appropriate components of the Cartesian gradient.
 767             call sc_grad
 768             endif
 769           enddo      ! j
 770         enddo        ! iint
 771       enddo          ! i
 772 c     stop
 773       return
 774       end
 775 C-----------------------------------------------------------------------------
 776       subroutine egb(evdw,evdw_t)
 777 C
 778 C This subroutine calculates the interaction energy of nonbonded side chains
 779 C assuming the Gay-Berne potential of interaction.
 780 C
 781       implicit real*8 (a-h,o-z)
 782       include 'DIMENSIONS'
 783       include 'DIMENSIONS.ZSCOPT'
 784       include "DIMENSIONS.COMPAR"
 785       include 'COMMON.GEO'
 786       include 'COMMON.VAR'
 787       include 'COMMON.LOCAL'
 788       include 'COMMON.CHAIN'
 789       include 'COMMON.DERIV'
 790       include 'COMMON.NAMES'
 791       include 'COMMON.INTERACT'
 792       include 'COMMON.ENEPS'
 793       include 'COMMON.IOUNITS'
 794       include 'COMMON.CALC'
 795       logical lprn
 796       common /srutu/icall
 797       integer icant
 798       external icant
 799       do i=1,210
 800         do j=1,2
 801           eneps_temp(j,i)=0.0d0
 802         enddo
 803       enddo
 804 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 805       evdw=0.0D0
 806       evdw_t=0.0d0
 807       lprn=.false.
 808 c      if (icall.gt.0) lprn=.true.
 809       ind=0
 810       do i=iatsc_s,iatsc_e
 811         itypi=iabs(itype(i))
 812         if (itypi.eq.ntyp1) cycle
 813         itypi1=iabs(itype(i+1))
 814         xi=c(1,nres+i)
 815         yi=c(2,nres+i)
 816         zi=c(3,nres+i)
 817 C returning the ith atom to box
 818           xi=mod(xi,boxxsize)
 819           if (xi.lt.0) xi=xi+boxxsize
 820           yi=mod(yi,boxysize)
 821           if (yi.lt.0) yi=yi+boxysize
 822           zi=mod(zi,boxzsize)
 823           if (zi.lt.0) zi=zi+boxzsize
 824        if ((zi.gt.bordlipbot)
 825      &.and.(zi.lt.bordliptop)) then
 826 C the energy transfer exist
 827         if (zi.lt.buflipbot) then
 828 C what fraction I am in
 829          fracinbuf=1.0d0-
 830      &        ((zi-bordlipbot)/lipbufthick)
 831 C lipbufthick is thickenes of lipid buffore
 832          sslipi=sscalelip(fracinbuf)
 833          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 834         elseif (zi.gt.bufliptop) then
 835          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 836          sslipi=sscalelip(fracinbuf)
 837          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 838         else
 839          sslipi=1.0d0
 840          ssgradlipi=0.0
 841         endif
 842        else
 843          sslipi=0.0d0
 844          ssgradlipi=0.0
 845        endif
 846
 847         dxi=dc_norm(1,nres+i)
 848         dyi=dc_norm(2,nres+i)
 849         dzi=dc_norm(3,nres+i)
 850         dsci_inv=vbld_inv(i+nres)
 851 C
 852 C Calculate SC interaction energy.
 853 C
 854         do iint=1,nint_gr(i)
 855           do j=istart(i,iint),iend(i,iint)
 856             ind=ind+1
 857             itypj=iabs(itype(j))
 858             if (itypj.eq.ntyp1) cycle
 859             dscj_inv=vbld_inv(j+nres)
 860             sig0ij=sigma(itypi,itypj)
 861             chi1=chi(itypi,itypj)
 862             chi2=chi(itypj,itypi)
 863             chi12=chi1*chi2
 864             chip1=chip(itypi)
 865             chip2=chip(itypj)
 866             chip12=chip1*chip2
 867             alf1=alp(itypi)
 868             alf2=alp(itypj)
 869             alf12=0.5D0*(alf1+alf2)
 870 C For diagnostics only!!!
 871 c           chi1=0.0D0
 872 c           chi2=0.0D0
 873 c           chi12=0.0D0
 874 c           chip1=0.0D0
 875 c           chip2=0.0D0
 876 c           chip12=0.0D0
 877 c           alf1=0.0D0
 878 c           alf2=0.0D0
 879 c           alf12=0.0D0
 880             xj=c(1,nres+j)
 881             yj=c(2,nres+j)
 882             zj=c(3,nres+j)
 883 C returning jth atom to box
 884           xj=mod(xj,boxxsize)
 885           if (xj.lt.0) xj=xj+boxxsize
 886           yj=mod(yj,boxysize)
 887           if (yj.lt.0) yj=yj+boxysize
 888           zj=mod(zj,boxzsize)
 889           if (zj.lt.0) zj=zj+boxzsize
 890        if ((zj.gt.bordlipbot)
 891      &.and.(zj.lt.bordliptop)) then
 892 C the energy transfer exist
 893         if (zj.lt.buflipbot) then
 894 C what fraction I am in
 895          fracinbuf=1.0d0-
 896      &        ((zj-bordlipbot)/lipbufthick)
 897 C lipbufthick is thickenes of lipid buffore
 898          sslipj=sscalelip(fracinbuf)
 899          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 900         elseif (zj.gt.bufliptop) then
 901          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 902          sslipj=sscalelip(fracinbuf)
 903          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 904         else
 905          sslipj=1.0d0
 906          ssgradlipj=0.0
 907         endif
 908        else
 909          sslipj=0.0d0
 910          ssgradlipj=0.0
 911        endif
 912       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 913      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 914       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 915      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 916 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
 917 C checking the distance
 918       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 919       xj_safe=xj
 920       yj_safe=yj
 921       zj_safe=zj
 922       subchap=0
 923 C finding the closest
 924       do xshift=-1,1
 925       do yshift=-1,1
 926       do zshift=-1,1
 927           xj=xj_safe+xshift*boxxsize
 928           yj=yj_safe+yshift*boxysize
 929           zj=zj_safe+zshift*boxzsize
 930           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 931           if(dist_temp.lt.dist_init) then
 932             dist_init=dist_temp
 933             xj_temp=xj
 934             yj_temp=yj
 935             zj_temp=zj
 936             subchap=1
 937           endif
 938        enddo
 939        enddo
 940        enddo
 941        if (subchap.eq.1) then
 942           xj=xj_temp-xi
 943           yj=yj_temp-yi
 944           zj=zj_temp-zi
 945        else
 946           xj=xj_safe-xi
 947           yj=yj_safe-yi
 948           zj=zj_safe-zi
 949        endif
 950
 951             dxj=dc_norm(1,nres+j)
 952             dyj=dc_norm(2,nres+j)
 953             dzj=dc_norm(3,nres+j)
 954 c            write (iout,*) i,j,xj,yj,zj
 955             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 956             rij=dsqrt(rrij)
 957             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
 958             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
 959             if (sss.le.0.0) cycle
 960 C Calculate angle-dependent terms of energy and contributions to their
 961 C derivatives.
 962
 963             call sc_angular
 964             sigsq=1.0D0/sigsq
 965             sig=sig0ij*dsqrt(sigsq)
 966             rij_shift=1.0D0/rij-sig+sig0ij
 967 C I hate to put IF's in the loops, but here don't have another choice!!!!
 968             if (rij_shift.le.0.0D0) then
 969               evdw=1.0D20
 970               return
 971             endif
 972             sigder=-sig*sigsq
 973 c---------------------------------------------------------------
 974             rij_shift=1.0D0/rij_shift
 975             fac=rij_shift**expon
 976             e1=fac*fac*aa
 977             e2=fac*bb
 978             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 979             eps2der=evdwij*eps3rt
 980             eps3der=evdwij*eps2rt
 981             evdwij=evdwij*eps2rt*eps3rt
 982             if (bb.gt.0) then
 983               evdw=evdw+evdwij*sss
 984             else
 985               evdw_t=evdw_t+evdwij*sss
 986             endif
 987             ij=icant(itypi,itypj)
 988             aux=eps1*eps2rt**2*eps3rt**2
 989             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 990      &        /dabs(eps(itypi,itypj))
 991             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 992 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 993 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 994 c     &         aux*e2/eps(itypi,itypj)
 995 c            if (lprn) then
 996             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 997             epsi=bb**2/aa
 998 #ifdef DEBUG
 999             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1000      &        restyp(itypi),i,restyp(itypj),j,
1001      &        epsi,sigm,chi1,chi2,chip1,chip2,
1002      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1003      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1004      &        evdwij
1005              write (iout,*) "partial sum", evdw, evdw_t
1006 #endif
1007 c            endif
1008             if (calc_grad) then
1009 C Calculate gradient components.
1010             e1=e1*eps1*eps2rt**2*eps3rt**2
1011             fac=-expon*(e1+evdwij)*rij_shift
1012             sigder=fac*sigder
1013             fac=rij*fac
1014             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1015 C Calculate the radial part of the gradient
1016             gg(1)=xj*fac
1017             gg(2)=yj*fac
1018             gg(3)=zj*fac
1019 C Calculate angular part of the gradient.
1020             call sc_grad
1021             endif
1022           enddo      ! j
1023         enddo        ! iint
1024       enddo          ! i
1025       return
1026       end
1027 C-----------------------------------------------------------------------------
1028       subroutine egbv(evdw,evdw_t)
1029 C
1030 C This subroutine calculates the interaction energy of nonbonded side chains
1031 C assuming the Gay-Berne-Vorobjev potential of interaction.
1032 C
1033       implicit real*8 (a-h,o-z)
1034       include 'DIMENSIONS'
1035       include 'DIMENSIONS.ZSCOPT'
1036       include "DIMENSIONS.COMPAR"
1037       include 'COMMON.GEO'
1038       include 'COMMON.VAR'
1039       include 'COMMON.LOCAL'
1040       include 'COMMON.CHAIN'
1041       include 'COMMON.DERIV'
1042       include 'COMMON.NAMES'
1043       include 'COMMON.INTERACT'
1044       include 'COMMON.ENEPS'
1045       include 'COMMON.IOUNITS'
1046       include 'COMMON.CALC'
1047       common /srutu/ icall
1048       logical lprn
1049       integer icant
1050       external icant
1051       do i=1,210
1052         do j=1,2
1053           eneps_temp(j,i)=0.0d0
1054         enddo
1055       enddo
1056       evdw=0.0D0
1057       evdw_t=0.0d0
1058 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1059       evdw=0.0D0
1060       lprn=.false.
1061 c      if (icall.gt.0) lprn=.true.
1062       ind=0
1063       do i=iatsc_s,iatsc_e
1064         itypi=iabs(itype(i))
1065         if (itypi.eq.ntyp1) cycle
1066         itypi1=iabs(itype(i+1))
1067         xi=c(1,nres+i)
1068         yi=c(2,nres+i)
1069         zi=c(3,nres+i)
1070         dxi=dc_norm(1,nres+i)
1071         dyi=dc_norm(2,nres+i)
1072         dzi=dc_norm(3,nres+i)
1073         dsci_inv=vbld_inv(i+nres)
1074 C
1075 C Calculate SC interaction energy.
1076 C
1077         do iint=1,nint_gr(i)
1078           do j=istart(i,iint),iend(i,iint)
1079             ind=ind+1
1080             itypj=iabs(itype(j))
1081             if (itypj.eq.ntyp1) cycle
1082             dscj_inv=vbld_inv(j+nres)
1083             sig0ij=sigma(itypi,itypj)
1084             r0ij=r0(itypi,itypj)
1085             chi1=chi(itypi,itypj)
1086             chi2=chi(itypj,itypi)
1087             chi12=chi1*chi2
1088             chip1=chip(itypi)
1089             chip2=chip(itypj)
1090             chip12=chip1*chip2
1091             alf1=alp(itypi)
1092             alf2=alp(itypj)
1093             alf12=0.5D0*(alf1+alf2)
1094 C For diagnostics only!!!
1095 c           chi1=0.0D0
1096 c           chi2=0.0D0
1097 c           chi12=0.0D0
1098 c           chip1=0.0D0
1099 c           chip2=0.0D0
1100 c           chip12=0.0D0
1101 c           alf1=0.0D0
1102 c           alf2=0.0D0
1103 c           alf12=0.0D0
1104             xj=c(1,nres+j)-xi
1105             yj=c(2,nres+j)-yi
1106             zj=c(3,nres+j)-zi
1107             dxj=dc_norm(1,nres+j)
1108             dyj=dc_norm(2,nres+j)
1109             dzj=dc_norm(3,nres+j)
1110             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1111             rij=dsqrt(rrij)
1112 C Calculate angle-dependent terms of energy and contributions to their
1113 C derivatives.
1114             call sc_angular
1115             sigsq=1.0D0/sigsq
1116             sig=sig0ij*dsqrt(sigsq)
1117             rij_shift=1.0D0/rij-sig+r0ij
1118 C I hate to put IF's in the loops, but here don't have another choice!!!!
1119             if (rij_shift.le.0.0D0) then
1120               evdw=1.0D20
1121               return
1122             endif
1123             sigder=-sig*sigsq
1124 c---------------------------------------------------------------
1125             rij_shift=1.0D0/rij_shift
1126             fac=rij_shift**expon
1127             e1=fac*fac*aa
1128             e2=fac*bb
1129             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1130             eps2der=evdwij*eps3rt
1131             eps3der=evdwij*eps2rt
1132             fac_augm=rrij**expon
1133             e_augm=augm(itypi,itypj)*fac_augm
1134             evdwij=evdwij*eps2rt*eps3rt
1135             if (bb.gt.0.0d0) then
1136               evdw=evdw+evdwij+e_augm
1137             else
1138               evdw_t=evdw_t+evdwij+e_augm
1139             endif
1140             ij=icant(itypi,itypj)
1141             aux=eps1*eps2rt**2*eps3rt**2
1142             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1143      &        /dabs(eps(itypi,itypj))
1144             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1145 c            eneps_temp(ij)=eneps_temp(ij)
1146 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1147 c            if (lprn) then
1148 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1149 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1150 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1151 c     &        restyp(itypi),i,restyp(itypj),j,
1152 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1153 c     &        chi1,chi2,chip1,chip2,
1154 c     &        eps1,eps2rt**2,eps3rt**2,
1155 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1156 c     &        evdwij+e_augm
1157 c            endif
1158             if (calc_grad) then
1159 C Calculate gradient components.
1160             e1=e1*eps1*eps2rt**2*eps3rt**2
1161             fac=-expon*(e1+evdwij)*rij_shift
1162             sigder=fac*sigder
1163             fac=rij*fac-2*expon*rrij*e_augm
1164 C Calculate the radial part of the gradient
1165             gg(1)=xj*fac
1166             gg(2)=yj*fac
1167             gg(3)=zj*fac
1168 C Calculate angular part of the gradient.
1169             call sc_grad
1170             endif
1171           enddo      ! j
1172         enddo        ! iint
1173       enddo          ! i
1174       return
1175       end
1176 C-----------------------------------------------------------------------------
1177       subroutine sc_angular
1178 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1179 C om12. Called by ebp, egb, and egbv.
1180       implicit none
1181       include 'COMMON.CALC'
1182       erij(1)=xj*rij
1183       erij(2)=yj*rij
1184       erij(3)=zj*rij
1185       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1186       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1187       om12=dxi*dxj+dyi*dyj+dzi*dzj
1188       chiom12=chi12*om12
1189 C Calculate eps1(om12) and its derivative in om12
1190       faceps1=1.0D0-om12*chiom12
1191       faceps1_inv=1.0D0/faceps1
1192       eps1=dsqrt(faceps1_inv)
1193 C Following variable is eps1*deps1/dom12
1194       eps1_om12=faceps1_inv*chiom12
1195 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1196 C and om12.
1197       om1om2=om1*om2
1198       chiom1=chi1*om1
1199       chiom2=chi2*om2
1200       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1201       sigsq=1.0D0-facsig*faceps1_inv
1202       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1203       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1204       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1205 C Calculate eps2 and its derivatives in om1, om2, and om12.
1206       chipom1=chip1*om1
1207       chipom2=chip2*om2
1208       chipom12=chip12*om12
1209       facp=1.0D0-om12*chipom12
1210       facp_inv=1.0D0/facp
1211       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1212 C Following variable is the square root of eps2
1213       eps2rt=1.0D0-facp1*facp_inv
1214 C Following three variables are the derivatives of the square root of eps
1215 C in om1, om2, and om12.
1216       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1217       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1218       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1219 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1220       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1221 C Calculate whole angle-dependent part of epsilon and contributions
1222 C to its derivatives
1223       return
1224       end
1225 C----------------------------------------------------------------------------
1226       subroutine sc_grad
1227       implicit real*8 (a-h,o-z)
1228       include 'DIMENSIONS'
1229       include 'DIMENSIONS.ZSCOPT'
1230       include 'COMMON.CHAIN'
1231       include 'COMMON.DERIV'
1232       include 'COMMON.CALC'
1233       double precision dcosom1(3),dcosom2(3)
1234       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1235       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1236       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1237      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1238       do k=1,3
1239         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1240         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1241       enddo
1242       do k=1,3
1243         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1244       enddo
1245       do k=1,3
1246         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1247      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1248      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1249         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1250      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1251      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1252       enddo
1253 C
1254 C Calculate the components of the gradient in DC and X
1255 C
1256       do k=i,j-1
1257         do l=1,3
1258           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1259         enddo
1260       enddo
1261       return
1262       end
1263 c------------------------------------------------------------------------------
1264       subroutine vec_and_deriv
1265       implicit real*8 (a-h,o-z)
1266       include 'DIMENSIONS'
1267       include 'DIMENSIONS.ZSCOPT'
1268       include 'COMMON.IOUNITS'
1269       include 'COMMON.GEO'
1270       include 'COMMON.VAR'
1271       include 'COMMON.LOCAL'
1272       include 'COMMON.CHAIN'
1273       include 'COMMON.VECTORS'
1274       include 'COMMON.DERIV'
1275       include 'COMMON.INTERACT'
1276       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1277 C Compute the local reference systems. For reference system (i), the
1278 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1279 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1280       do i=1,nres-1
1281 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1282           if (i.eq.nres-1) then
1283 C Case of the last full residue
1284 C Compute the Z-axis
1285             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1286             costh=dcos(pi-theta(nres))
1287             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1288             do k=1,3
1289               uz(k,i)=fac*uz(k,i)
1290             enddo
1291             if (calc_grad) then
1292 C Compute the derivatives of uz
1293             uzder(1,1,1)= 0.0d0
1294             uzder(2,1,1)=-dc_norm(3,i-1)
1295             uzder(3,1,1)= dc_norm(2,i-1)
1296             uzder(1,2,1)= dc_norm(3,i-1)
1297             uzder(2,2,1)= 0.0d0
1298             uzder(3,2,1)=-dc_norm(1,i-1)
1299             uzder(1,3,1)=-dc_norm(2,i-1)
1300             uzder(2,3,1)= dc_norm(1,i-1)
1301             uzder(3,3,1)= 0.0d0
1302             uzder(1,1,2)= 0.0d0
1303             uzder(2,1,2)= dc_norm(3,i)
1304             uzder(3,1,2)=-dc_norm(2,i)
1305             uzder(1,2,2)=-dc_norm(3,i)
1306             uzder(2,2,2)= 0.0d0
1307             uzder(3,2,2)= dc_norm(1,i)
1308             uzder(1,3,2)= dc_norm(2,i)
1309             uzder(2,3,2)=-dc_norm(1,i)
1310             uzder(3,3,2)= 0.0d0
1311             endif
1312 C Compute the Y-axis
1313             facy=fac
1314             do k=1,3
1315               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1316             enddo
1317             if (calc_grad) then
1318 C Compute the derivatives of uy
1319             do j=1,3
1320               do k=1,3
1321                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1322      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1323                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1324               enddo
1325               uyder(j,j,1)=uyder(j,j,1)-costh
1326               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1327             enddo
1328             do j=1,2
1329               do k=1,3
1330                 do l=1,3
1331                   uygrad(l,k,j,i)=uyder(l,k,j)
1332                   uzgrad(l,k,j,i)=uzder(l,k,j)
1333                 enddo
1334               enddo
1335             enddo
1336             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1337             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1338             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1339             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1340             endif
1341           else
1342 C Other residues
1343 C Compute the Z-axis
1344             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1345             costh=dcos(pi-theta(i+2))
1346             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1347             do k=1,3
1348               uz(k,i)=fac*uz(k,i)
1349             enddo
1350             if (calc_grad) then
1351 C Compute the derivatives of uz
1352             uzder(1,1,1)= 0.0d0
1353             uzder(2,1,1)=-dc_norm(3,i+1)
1354             uzder(3,1,1)= dc_norm(2,i+1)
1355             uzder(1,2,1)= dc_norm(3,i+1)
1356             uzder(2,2,1)= 0.0d0
1357             uzder(3,2,1)=-dc_norm(1,i+1)
1358             uzder(1,3,1)=-dc_norm(2,i+1)
1359             uzder(2,3,1)= dc_norm(1,i+1)
1360             uzder(3,3,1)= 0.0d0
1361             uzder(1,1,2)= 0.0d0
1362             uzder(2,1,2)= dc_norm(3,i)
1363             uzder(3,1,2)=-dc_norm(2,i)
1364             uzder(1,2,2)=-dc_norm(3,i)
1365             uzder(2,2,2)= 0.0d0
1366             uzder(3,2,2)= dc_norm(1,i)
1367             uzder(1,3,2)= dc_norm(2,i)
1368             uzder(2,3,2)=-dc_norm(1,i)
1369             uzder(3,3,2)= 0.0d0
1370             endif
1371 C Compute the Y-axis
1372             facy=fac
1373             do k=1,3
1374               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1375             enddo
1376             if (calc_grad) then
1377 C Compute the derivatives of uy
1378             do j=1,3
1379               do k=1,3
1380                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1381      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1382                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1383               enddo
1384               uyder(j,j,1)=uyder(j,j,1)-costh
1385               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1386             enddo
1387             do j=1,2
1388               do k=1,3
1389                 do l=1,3
1390                   uygrad(l,k,j,i)=uyder(l,k,j)
1391                   uzgrad(l,k,j,i)=uzder(l,k,j)
1392                 enddo
1393               enddo
1394             enddo
1395             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1396             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1397             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1398             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1399           endif
1400           endif
1401       enddo
1402       if (calc_grad) then
1403       do i=1,nres-1
1404         vbld_inv_temp(1)=vbld_inv(i+1)
1405         if (i.lt.nres-1) then
1406           vbld_inv_temp(2)=vbld_inv(i+2)
1407         else
1408           vbld_inv_temp(2)=vbld_inv(i)
1409         endif
1410         do j=1,2
1411           do k=1,3
1412             do l=1,3
1413               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1414               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1415             enddo
1416           enddo
1417         enddo
1418       enddo
1419       endif
1420       return
1421       end
1422 C-----------------------------------------------------------------------------
1423       subroutine vec_and_deriv_test
1424       implicit real*8 (a-h,o-z)
1425       include 'DIMENSIONS'
1426       include 'DIMENSIONS.ZSCOPT'
1427       include 'COMMON.IOUNITS'
1428       include 'COMMON.GEO'
1429       include 'COMMON.VAR'
1430       include 'COMMON.LOCAL'
1431       include 'COMMON.CHAIN'
1432       include 'COMMON.VECTORS'
1433       dimension uyder(3,3,2),uzder(3,3,2)
1434 C Compute the local reference systems. For reference system (i), the
1435 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1436 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1437       do i=1,nres-1
1438           if (i.eq.nres-1) then
1439 C Case of the last full residue
1440 C Compute the Z-axis
1441             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1442             costh=dcos(pi-theta(nres))
1443             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1444 c            write (iout,*) 'fac',fac,
1445 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1446             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1447             do k=1,3
1448               uz(k,i)=fac*uz(k,i)
1449             enddo
1450 C Compute the derivatives of uz
1451             uzder(1,1,1)= 0.0d0
1452             uzder(2,1,1)=-dc_norm(3,i-1)
1453             uzder(3,1,1)= dc_norm(2,i-1)
1454             uzder(1,2,1)= dc_norm(3,i-1)
1455             uzder(2,2,1)= 0.0d0
1456             uzder(3,2,1)=-dc_norm(1,i-1)
1457             uzder(1,3,1)=-dc_norm(2,i-1)
1458             uzder(2,3,1)= dc_norm(1,i-1)
1459             uzder(3,3,1)= 0.0d0
1460             uzder(1,1,2)= 0.0d0
1461             uzder(2,1,2)= dc_norm(3,i)
1462             uzder(3,1,2)=-dc_norm(2,i)
1463             uzder(1,2,2)=-dc_norm(3,i)
1464             uzder(2,2,2)= 0.0d0
1465             uzder(3,2,2)= dc_norm(1,i)
1466             uzder(1,3,2)= dc_norm(2,i)
1467             uzder(2,3,2)=-dc_norm(1,i)
1468             uzder(3,3,2)= 0.0d0
1469 C Compute the Y-axis
1470             do k=1,3
1471               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1472             enddo
1473             facy=fac
1474             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1475      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1476      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1477             do k=1,3
1478 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1479               uy(k,i)=
1480 c     &        facy*(
1481      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1482      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1483 c     &        )
1484             enddo
1485 c            write (iout,*) 'facy',facy,
1486 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1487             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1488             do k=1,3
1489               uy(k,i)=facy*uy(k,i)
1490             enddo
1491 C Compute the derivatives of uy
1492             do j=1,3
1493               do k=1,3
1494                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1495      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1496                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1497               enddo
1498 c              uyder(j,j,1)=uyder(j,j,1)-costh
1499 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1500               uyder(j,j,1)=uyder(j,j,1)
1501      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1502               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1503      &          +uyder(j,j,2)
1504             enddo
1505             do j=1,2
1506               do k=1,3
1507                 do l=1,3
1508                   uygrad(l,k,j,i)=uyder(l,k,j)
1509                   uzgrad(l,k,j,i)=uzder(l,k,j)
1510                 enddo
1511               enddo
1512             enddo
1513             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1514             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1515             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1516             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1517           else
1518 C Other residues
1519 C Compute the Z-axis
1520             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1521             costh=dcos(pi-theta(i+2))
1522             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1523             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1524             do k=1,3
1525               uz(k,i)=fac*uz(k,i)
1526             enddo
1527 C Compute the derivatives of uz
1528             uzder(1,1,1)= 0.0d0
1529             uzder(2,1,1)=-dc_norm(3,i+1)
1530             uzder(3,1,1)= dc_norm(2,i+1)
1531             uzder(1,2,1)= dc_norm(3,i+1)
1532             uzder(2,2,1)= 0.0d0
1533             uzder(3,2,1)=-dc_norm(1,i+1)
1534             uzder(1,3,1)=-dc_norm(2,i+1)
1535             uzder(2,3,1)= dc_norm(1,i+1)
1536             uzder(3,3,1)= 0.0d0
1537             uzder(1,1,2)= 0.0d0
1538             uzder(2,1,2)= dc_norm(3,i)
1539             uzder(3,1,2)=-dc_norm(2,i)
1540             uzder(1,2,2)=-dc_norm(3,i)
1541             uzder(2,2,2)= 0.0d0
1542             uzder(3,2,2)= dc_norm(1,i)
1543             uzder(1,3,2)= dc_norm(2,i)
1544             uzder(2,3,2)=-dc_norm(1,i)
1545             uzder(3,3,2)= 0.0d0
1546 C Compute the Y-axis
1547             facy=fac
1548             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1549      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1550      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1551             do k=1,3
1552 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1553               uy(k,i)=
1554 c     &        facy*(
1555      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1556      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1557 c     &        )
1558             enddo
1559 c            write (iout,*) 'facy',facy,
1560 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1561             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1562             do k=1,3
1563               uy(k,i)=facy*uy(k,i)
1564             enddo
1565 C Compute the derivatives of uy
1566             do j=1,3
1567               do k=1,3
1568                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1569      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1570                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1571               enddo
1572 c              uyder(j,j,1)=uyder(j,j,1)-costh
1573 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1574               uyder(j,j,1)=uyder(j,j,1)
1575      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1576               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1577      &          +uyder(j,j,2)
1578             enddo
1579             do j=1,2
1580               do k=1,3
1581                 do l=1,3
1582                   uygrad(l,k,j,i)=uyder(l,k,j)
1583                   uzgrad(l,k,j,i)=uzder(l,k,j)
1584                 enddo
1585               enddo
1586             enddo
1587             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1588             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1589             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1590             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1591           endif
1592       enddo
1593       do i=1,nres-1
1594         do j=1,2
1595           do k=1,3
1596             do l=1,3
1597               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1598               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1599             enddo
1600           enddo
1601         enddo
1602       enddo
1603       return
1604       end
1605 C-----------------------------------------------------------------------------
1606       subroutine check_vecgrad
1607       implicit real*8 (a-h,o-z)
1608       include 'DIMENSIONS'
1609       include 'DIMENSIONS.ZSCOPT'
1610       include 'COMMON.IOUNITS'
1611       include 'COMMON.GEO'
1612       include 'COMMON.VAR'
1613       include 'COMMON.LOCAL'
1614       include 'COMMON.CHAIN'
1615       include 'COMMON.VECTORS'
1616       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1617       dimension uyt(3,maxres),uzt(3,maxres)
1618       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1619       double precision delta /1.0d-7/
1620       call vec_and_deriv
1621 cd      do i=1,nres
1622 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1623 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1624 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1625 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1626 cd     &     (dc_norm(if90,i),if90=1,3)
1627 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1628 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1629 cd          write(iout,'(a)')
1630 cd      enddo
1631       do i=1,nres
1632         do j=1,2
1633           do k=1,3
1634             do l=1,3
1635               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1636               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1637             enddo
1638           enddo
1639         enddo
1640       enddo
1641       call vec_and_deriv
1642       do i=1,nres
1643         do j=1,3
1644           uyt(j,i)=uy(j,i)
1645           uzt(j,i)=uz(j,i)
1646         enddo
1647       enddo
1648       do i=1,nres
1649 cd        write (iout,*) 'i=',i
1650         do k=1,3
1651           erij(k)=dc_norm(k,i)
1652         enddo
1653         do j=1,3
1654           do k=1,3
1655             dc_norm(k,i)=erij(k)
1656           enddo
1657           dc_norm(j,i)=dc_norm(j,i)+delta
1658 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1659 c          do k=1,3
1660 c            dc_norm(k,i)=dc_norm(k,i)/fac
1661 c          enddo
1662 c          write (iout,*) (dc_norm(k,i),k=1,3)
1663 c          write (iout,*) (erij(k),k=1,3)
1664           call vec_and_deriv
1665           do k=1,3
1666             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1667             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1668             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1669             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1670           enddo
1671 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1672 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1673 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1674         enddo
1675         do k=1,3
1676           dc_norm(k,i)=erij(k)
1677         enddo
1678 cd        do k=1,3
1679 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1680 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1681 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1682 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1683 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1684 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1685 cd          write (iout,'(a)')
1686 cd        enddo
1687       enddo
1688       return
1689       end
1690 C--------------------------------------------------------------------------
1691       subroutine set_matrices
1692       implicit real*8 (a-h,o-z)
1693       include 'DIMENSIONS'
1694       include 'DIMENSIONS.ZSCOPT'
1695       include 'COMMON.IOUNITS'
1696       include 'COMMON.GEO'
1697       include 'COMMON.VAR'
1698       include 'COMMON.LOCAL'
1699       include 'COMMON.CHAIN'
1700       include 'COMMON.DERIV'
1701       include 'COMMON.INTERACT'
1702       include 'COMMON.CONTACTS'
1703       include 'COMMON.TORSION'
1704       include 'COMMON.VECTORS'
1705       include 'COMMON.FFIELD'
1706       double precision auxvec(2),auxmat(2,2)
1707 C
1708 C Compute the virtual-bond-torsional-angle dependent quantities needed
1709 C to calculate the el-loc multibody terms of various order.
1710 C
1711       do i=3,nres+1
1712         if (i .lt. nres+1) then
1713           sin1=dsin(phi(i))
1714           cos1=dcos(phi(i))
1715           sintab(i-2)=sin1
1716           costab(i-2)=cos1
1717           obrot(1,i-2)=cos1
1718           obrot(2,i-2)=sin1
1719           sin2=dsin(2*phi(i))
1720           cos2=dcos(2*phi(i))
1721           sintab2(i-2)=sin2
1722           costab2(i-2)=cos2
1723           obrot2(1,i-2)=cos2
1724           obrot2(2,i-2)=sin2
1725           Ug(1,1,i-2)=-cos1
1726           Ug(1,2,i-2)=-sin1
1727           Ug(2,1,i-2)=-sin1
1728           Ug(2,2,i-2)= cos1
1729           Ug2(1,1,i-2)=-cos2
1730           Ug2(1,2,i-2)=-sin2
1731           Ug2(2,1,i-2)=-sin2
1732           Ug2(2,2,i-2)= cos2
1733         else
1734           costab(i-2)=1.0d0
1735           sintab(i-2)=0.0d0
1736           obrot(1,i-2)=1.0d0
1737           obrot(2,i-2)=0.0d0
1738           obrot2(1,i-2)=0.0d0
1739           obrot2(2,i-2)=0.0d0
1740           Ug(1,1,i-2)=1.0d0
1741           Ug(1,2,i-2)=0.0d0
1742           Ug(2,1,i-2)=0.0d0
1743           Ug(2,2,i-2)=1.0d0
1744           Ug2(1,1,i-2)=0.0d0
1745           Ug2(1,2,i-2)=0.0d0
1746           Ug2(2,1,i-2)=0.0d0
1747           Ug2(2,2,i-2)=0.0d0
1748         endif
1749         if (i .gt. 3 .and. i .lt. nres+1) then
1750           obrot_der(1,i-2)=-sin1
1751           obrot_der(2,i-2)= cos1
1752           Ugder(1,1,i-2)= sin1
1753           Ugder(1,2,i-2)=-cos1
1754           Ugder(2,1,i-2)=-cos1
1755           Ugder(2,2,i-2)=-sin1
1756           dwacos2=cos2+cos2
1757           dwasin2=sin2+sin2
1758           obrot2_der(1,i-2)=-dwasin2
1759           obrot2_der(2,i-2)= dwacos2
1760           Ug2der(1,1,i-2)= dwasin2
1761           Ug2der(1,2,i-2)=-dwacos2
1762           Ug2der(2,1,i-2)=-dwacos2
1763           Ug2der(2,2,i-2)=-dwasin2
1764         else
1765           obrot_der(1,i-2)=0.0d0
1766           obrot_der(2,i-2)=0.0d0
1767           Ugder(1,1,i-2)=0.0d0
1768           Ugder(1,2,i-2)=0.0d0
1769           Ugder(2,1,i-2)=0.0d0
1770           Ugder(2,2,i-2)=0.0d0
1771           obrot2_der(1,i-2)=0.0d0
1772           obrot2_der(2,i-2)=0.0d0
1773           Ug2der(1,1,i-2)=0.0d0
1774           Ug2der(1,2,i-2)=0.0d0
1775           Ug2der(2,1,i-2)=0.0d0
1776           Ug2der(2,2,i-2)=0.0d0
1777         endif
1778         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1779           if (itype(i-2).le.ntyp) then
1780             iti = itortyp(itype(i-2))
1781           else
1782             iti=ntortyp+1
1783           endif
1784         else
1785           iti=ntortyp+1
1786         endif
1787         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1788           if (itype(i-1).le.ntyp) then
1789             iti1 = itortyp(itype(i-1))
1790           else
1791             iti1=ntortyp+1
1792           endif
1793         else
1794           iti1=ntortyp+1
1795         endif
1796 cd        write (iout,*) '*******i',i,' iti1',iti
1797 cd        write (iout,*) 'b1',b1(:,iti)
1798 cd        write (iout,*) 'b2',b2(:,iti)
1799 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1800 c        print *,"itilde1 i iti iti1",i,iti,iti1
1801         if (i .gt. iatel_s+2) then
1802           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1803           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1804           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1805           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1806           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1807           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1808           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1809         else
1810           do k=1,2
1811             Ub2(k,i-2)=0.0d0
1812             Ctobr(k,i-2)=0.0d0
1813             Dtobr2(k,i-2)=0.0d0
1814             do l=1,2
1815               EUg(l,k,i-2)=0.0d0
1816               CUg(l,k,i-2)=0.0d0
1817               DUg(l,k,i-2)=0.0d0
1818               DtUg2(l,k,i-2)=0.0d0
1819             enddo
1820           enddo
1821         endif
1822 c        print *,"itilde2 i iti iti1",i,iti,iti1
1823         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1824         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1825         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1826         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1827         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1828         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1829         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1830 c        print *,"itilde3 i iti iti1",i,iti,iti1
1831         do k=1,2
1832           muder(k,i-2)=Ub2der(k,i-2)
1833         enddo
1834         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1835           if (itype(i-1).le.ntyp) then
1836             iti1 = itortyp(itype(i-1))
1837           else
1838             iti1=ntortyp+1
1839           endif
1840         else
1841           iti1=ntortyp+1
1842         endif
1843         do k=1,2
1844           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1845         enddo
1846 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
1847
1848 C Vectors and matrices dependent on a single virtual-bond dihedral.
1849         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1850         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1851         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1852         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1853         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1854         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1855         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1856         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1857         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1858 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1859 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1860       enddo
1861 C Matrices dependent on two consecutive virtual-bond dihedrals.
1862 C The order of matrices is from left to right.
1863       do i=2,nres-1
1864         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1865         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1866         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1867         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1868         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1869         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1870         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1871         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1872       enddo
1873 cd      do i=1,nres
1874 cd        iti = itortyp(itype(i))
1875 cd        write (iout,*) i
1876 cd        do j=1,2
1877 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1878 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1879 cd        enddo
1880 cd      enddo
1881       return
1882       end
1883 C--------------------------------------------------------------------------
1884       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1885 C
1886 C This subroutine calculates the average interaction energy and its gradient
1887 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1888 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1889 C The potential depends both on the distance of peptide-group centers and on
1890 C the orientation of the CA-CA virtual bonds.
1891 C
1892       implicit real*8 (a-h,o-z)
1893       include 'DIMENSIONS'
1894       include 'DIMENSIONS.ZSCOPT'
1895       include 'COMMON.CONTROL'
1896       include 'COMMON.IOUNITS'
1897       include 'COMMON.GEO'
1898       include 'COMMON.VAR'
1899       include 'COMMON.LOCAL'
1900       include 'COMMON.CHAIN'
1901       include 'COMMON.DERIV'
1902       include 'COMMON.INTERACT'
1903       include 'COMMON.CONTACTS'
1904       include 'COMMON.TORSION'
1905       include 'COMMON.VECTORS'
1906       include 'COMMON.FFIELD'
1907       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1908      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1909       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1910      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1911       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1912 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1913       double precision scal_el /0.5d0/
1914 C 12/13/98
1915 C 13-go grudnia roku pamietnego...
1916       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1917      &                   0.0d0,1.0d0,0.0d0,
1918      &                   0.0d0,0.0d0,1.0d0/
1919 cd      write(iout,*) 'In EELEC'
1920 cd      do i=1,nloctyp
1921 cd        write(iout,*) 'Type',i
1922 cd        write(iout,*) 'B1',B1(:,i)
1923 cd        write(iout,*) 'B2',B2(:,i)
1924 cd        write(iout,*) 'CC',CC(:,:,i)
1925 cd        write(iout,*) 'DD',DD(:,:,i)
1926 cd        write(iout,*) 'EE',EE(:,:,i)
1927 cd      enddo
1928 cd      call check_vecgrad
1929 cd      stop
1930       if (icheckgrad.eq.1) then
1931         do i=1,nres-1
1932           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1933           do k=1,3
1934             dc_norm(k,i)=dc(k,i)*fac
1935           enddo
1936 c          write (iout,*) 'i',i,' fac',fac
1937         enddo
1938       endif
1939       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1940      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1941      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1942 cd      if (wel_loc.gt.0.0d0) then
1943         if (icheckgrad.eq.1) then
1944         call vec_and_deriv_test
1945         else
1946         call vec_and_deriv
1947         endif
1948         call set_matrices
1949       endif
1950 cd      do i=1,nres-1
1951 cd        write (iout,*) 'i=',i
1952 cd        do k=1,3
1953 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1954 cd        enddo
1955 cd        do k=1,3
1956 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1957 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1958 cd        enddo
1959 cd      enddo
1960       num_conti_hb=0
1961       ees=0.0D0
1962       evdw1=0.0D0
1963       eel_loc=0.0d0
1964       eello_turn3=0.0d0
1965       eello_turn4=0.0d0
1966       ind=0
1967       do i=1,nres
1968         num_cont_hb(i)=0
1969       enddo
1970 C      print '(a)','Enter EELEC'
1971 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1972       do i=1,nres
1973         gel_loc_loc(i)=0.0d0
1974         gcorr_loc(i)=0.0d0
1975       enddo
1976       do i=iatel_s,iatel_e
1977           if (i.eq.1) then
1978            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
1979      &  .or. itype(i+2).eq.ntyp1) cycle
1980           else
1981         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
1982      &  .or. itype(i+2).eq.ntyp1
1983      &  .or. itype(i-1).eq.ntyp1
1984      &) cycle
1985          endif
1986         if (itel(i).eq.0) goto 1215
1987         dxi=dc(1,i)
1988         dyi=dc(2,i)
1989         dzi=dc(3,i)
1990         dx_normi=dc_norm(1,i)
1991         dy_normi=dc_norm(2,i)
1992         dz_normi=dc_norm(3,i)
1993         xmedi=c(1,i)+0.5d0*dxi
1994         ymedi=c(2,i)+0.5d0*dyi
1995         zmedi=c(3,i)+0.5d0*dzi
1996           xmedi=mod(xmedi,boxxsize)
1997           if (xmedi.lt.0) xmedi=xmedi+boxxsize
1998           ymedi=mod(ymedi,boxysize)
1999           if (ymedi.lt.0) ymedi=ymedi+boxysize
2000           zmedi=mod(zmedi,boxzsize)
2001           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2002         num_conti=0
2003 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2004         do j=ielstart(i),ielend(i)
2005           if (j.eq.1) then
2006            if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2007      & .or.itype(j+2).eq.ntyp1
2008      &) cycle
2009           else
2010           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2011      & .or.itype(j+2).eq.ntyp1
2012      & .or.itype(j-1).eq.ntyp1
2013      &) cycle
2014          endif
2015 C
2016 C) cycle
2017           if (itel(j).eq.0) goto 1216
2018           ind=ind+1
2019           iteli=itel(i)
2020           itelj=itel(j)
2021           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2022           aaa=app(iteli,itelj)
2023           bbb=bpp(iteli,itelj)
2024 C Diagnostics only!!!
2025 c         aaa=0.0D0
2026 c         bbb=0.0D0
2027 c         ael6i=0.0D0
2028 c         ael3i=0.0D0
2029 C End diagnostics
2030           ael6i=ael6(iteli,itelj)
2031           ael3i=ael3(iteli,itelj)
2032           dxj=dc(1,j)
2033           dyj=dc(2,j)
2034           dzj=dc(3,j)
2035           dx_normj=dc_norm(1,j)
2036           dy_normj=dc_norm(2,j)
2037           dz_normj=dc_norm(3,j)
2038           xj=c(1,j)+0.5D0*dxj
2039           yj=c(2,j)+0.5D0*dyj
2040           zj=c(3,j)+0.5D0*dzj
2041          xj=mod(xj,boxxsize)
2042           if (xj.lt.0) xj=xj+boxxsize
2043           yj=mod(yj,boxysize)
2044           if (yj.lt.0) yj=yj+boxysize
2045           zj=mod(zj,boxzsize)
2046           if (zj.lt.0) zj=zj+boxzsize
2047       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2048       xj_safe=xj
2049       yj_safe=yj
2050       zj_safe=zj
2051       isubchap=0
2052       do xshift=-1,1
2053       do yshift=-1,1
2054       do zshift=-1,1
2055           xj=xj_safe+xshift*boxxsize
2056           yj=yj_safe+yshift*boxysize
2057           zj=zj_safe+zshift*boxzsize
2058           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2059           if(dist_temp.lt.dist_init) then
2060             dist_init=dist_temp
2061             xj_temp=xj
2062             yj_temp=yj
2063             zj_temp=zj
2064             isubchap=1
2065           endif
2066        enddo
2067        enddo
2068        enddo
2069        if (isubchap.eq.1) then
2070           xj=xj_temp-xmedi
2071           yj=yj_temp-ymedi
2072           zj=zj_temp-zmedi
2073        else
2074           xj=xj_safe-xmedi
2075           yj=yj_safe-ymedi
2076           zj=zj_safe-zmedi
2077        endif
2078           rij=xj*xj+yj*yj+zj*zj
2079             sss=sscale(sqrt(rij))
2080             sssgrad=sscagrad(sqrt(rij))
2081           rrmij=1.0D0/rij
2082           rij=dsqrt(rij)
2083           rmij=1.0D0/rij
2084           r3ij=rrmij*rmij
2085           r6ij=r3ij*r3ij
2086           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2087           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2088           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2089           fac=cosa-3.0D0*cosb*cosg
2090           ev1=aaa*r6ij*r6ij
2091 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2092           if (j.eq.i+2) ev1=scal_el*ev1
2093           ev2=bbb*r6ij
2094           fac3=ael6i*r6ij
2095           fac4=ael3i*r3ij
2096           evdwij=ev1+ev2
2097           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2098           el2=fac4*fac
2099           eesij=el1+el2
2100 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2101 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2102           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2103           ees=ees+eesij
2104           evdw1=evdw1+evdwij*sss
2105 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2106 c     &'evdw1',i,j,evdwij
2107 c     &,iteli,itelj,aaa,evdw1
2108
2109 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2110 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2111 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2112 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2113 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2114 C
2115 C Calculate contributions to the Cartesian gradient.
2116 C
2117 #ifdef SPLITELE
2118           facvdw=-6*rrmij*(ev1+evdwij)*sss
2119           facel=-3*rrmij*(el1+eesij)
2120           fac1=fac
2121           erij(1)=xj*rmij
2122           erij(2)=yj*rmij
2123           erij(3)=zj*rmij
2124           if (calc_grad) then
2125 *
2126 * Radial derivatives. First process both termini of the fragment (i,j)
2127 *
2128           ggg(1)=facel*xj
2129           ggg(2)=facel*yj
2130           ggg(3)=facel*zj
2131           do k=1,3
2132             ghalf=0.5D0*ggg(k)
2133             gelc(k,i)=gelc(k,i)+ghalf
2134             gelc(k,j)=gelc(k,j)+ghalf
2135           enddo
2136 *
2137 * Loop over residues i+1 thru j-1.
2138 *
2139           do k=i+1,j-1
2140             do l=1,3
2141               gelc(l,k)=gelc(l,k)+ggg(l)
2142             enddo
2143           enddo
2144 C          ggg(1)=facvdw*xj
2145 C          ggg(2)=facvdw*yj
2146 C          ggg(3)=facvdw*zj
2147           if (sss.gt.0.0) then
2148           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2149           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2150           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2151           else
2152           ggg(1)=0.0
2153           ggg(2)=0.0
2154           ggg(3)=0.0
2155           endif
2156           do k=1,3
2157             ghalf=0.5D0*ggg(k)
2158             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2159             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2160           enddo
2161 *
2162 * Loop over residues i+1 thru j-1.
2163 *
2164           do k=i+1,j-1
2165             do l=1,3
2166               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2167             enddo
2168           enddo
2169 #else
2170           facvdw=(ev1+evdwij)*sss
2171           facel=el1+eesij
2172           fac1=fac
2173           fac=-3*rrmij*(facvdw+facvdw+facel)
2174           erij(1)=xj*rmij
2175           erij(2)=yj*rmij
2176           erij(3)=zj*rmij
2177           if (calc_grad) then
2178 *
2179 * Radial derivatives. First process both termini of the fragment (i,j)
2180 *
2181           ggg(1)=fac*xj
2182           ggg(2)=fac*yj
2183           ggg(3)=fac*zj
2184           do k=1,3
2185             ghalf=0.5D0*ggg(k)
2186             gelc(k,i)=gelc(k,i)+ghalf
2187             gelc(k,j)=gelc(k,j)+ghalf
2188           enddo
2189 *
2190 * Loop over residues i+1 thru j-1.
2191 *
2192           do k=i+1,j-1
2193             do l=1,3
2194               gelc(l,k)=gelc(l,k)+ggg(l)
2195             enddo
2196           enddo
2197 #endif
2198 *
2199 * Angular part
2200 *
2201           ecosa=2.0D0*fac3*fac1+fac4
2202           fac4=-3.0D0*fac4
2203           fac3=-6.0D0*fac3
2204           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2205           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2206           do k=1,3
2207             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2208             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2209           enddo
2210 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2211 cd   &          (dcosg(k),k=1,3)
2212           do k=1,3
2213             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2214           enddo
2215           do k=1,3
2216             ghalf=0.5D0*ggg(k)
2217             gelc(k,i)=gelc(k,i)+ghalf
2218      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2219      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2220             gelc(k,j)=gelc(k,j)+ghalf
2221      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2222      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2223           enddo
2224           do k=i+1,j-1
2225             do l=1,3
2226               gelc(l,k)=gelc(l,k)+ggg(l)
2227             enddo
2228           enddo
2229           endif
2230
2231           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2232      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2233      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2234 C
2235 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2236 C   energy of a peptide unit is assumed in the form of a second-order
2237 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2238 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2239 C   are computed for EVERY pair of non-contiguous peptide groups.
2240 C
2241           if (j.lt.nres-1) then
2242             j1=j+1
2243             j2=j-1
2244           else
2245             j1=j-1
2246             j2=j-2
2247           endif
2248           kkk=0
2249           do k=1,2
2250             do l=1,2
2251               kkk=kkk+1
2252               muij(kkk)=mu(k,i)*mu(l,j)
2253             enddo
2254           enddo
2255 cd         write (iout,*) 'EELEC: i',i,' j',j
2256 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2257 cd          write(iout,*) 'muij',muij
2258           ury=scalar(uy(1,i),erij)
2259           urz=scalar(uz(1,i),erij)
2260           vry=scalar(uy(1,j),erij)
2261           vrz=scalar(uz(1,j),erij)
2262           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2263           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2264           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2265           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2266 C For diagnostics only
2267 cd          a22=1.0d0
2268 cd          a23=1.0d0
2269 cd          a32=1.0d0
2270 cd          a33=1.0d0
2271           fac=dsqrt(-ael6i)*r3ij
2272 cd          write (2,*) 'fac=',fac
2273 C For diagnostics only
2274 cd          fac=1.0d0
2275           a22=a22*fac
2276           a23=a23*fac
2277           a32=a32*fac
2278           a33=a33*fac
2279 cd          write (iout,'(4i5,4f10.5)')
2280 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2281 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2282 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2283 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2284 cd          write (iout,'(4f10.5)')
2285 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2286 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2287 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2288 cd           write (iout,'(2i3,9f10.5/)') i,j,
2289 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2290           if (calc_grad) then
2291 C Derivatives of the elements of A in virtual-bond vectors
2292           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2293 cd          do k=1,3
2294 cd            do l=1,3
2295 cd              erder(k,l)=0.0d0
2296 cd            enddo
2297 cd          enddo
2298           do k=1,3
2299             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2300             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2301             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2302             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2303             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2304             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2305             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2306             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2307             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2308             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2309             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2310             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2311           enddo
2312 cd          do k=1,3
2313 cd            do l=1,3
2314 cd              uryg(k,l)=0.0d0
2315 cd              urzg(k,l)=0.0d0
2316 cd              vryg(k,l)=0.0d0
2317 cd              vrzg(k,l)=0.0d0
2318 cd            enddo
2319 cd          enddo
2320 C Compute radial contributions to the gradient
2321           facr=-3.0d0*rrmij
2322           a22der=a22*facr
2323           a23der=a23*facr
2324           a32der=a32*facr
2325           a33der=a33*facr
2326 cd          a22der=0.0d0
2327 cd          a23der=0.0d0
2328 cd          a32der=0.0d0
2329 cd          a33der=0.0d0
2330           agg(1,1)=a22der*xj
2331           agg(2,1)=a22der*yj
2332           agg(3,1)=a22der*zj
2333           agg(1,2)=a23der*xj
2334           agg(2,2)=a23der*yj
2335           agg(3,2)=a23der*zj
2336           agg(1,3)=a32der*xj
2337           agg(2,3)=a32der*yj
2338           agg(3,3)=a32der*zj
2339           agg(1,4)=a33der*xj
2340           agg(2,4)=a33der*yj
2341           agg(3,4)=a33der*zj
2342 C Add the contributions coming from er
2343           fac3=-3.0d0*fac
2344           do k=1,3
2345             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2346             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2347             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2348             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2349           enddo
2350           do k=1,3
2351 C Derivatives in DC(i)
2352             ghalf1=0.5d0*agg(k,1)
2353             ghalf2=0.5d0*agg(k,2)
2354             ghalf3=0.5d0*agg(k,3)
2355             ghalf4=0.5d0*agg(k,4)
2356             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2357      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2358             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2359      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2360             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2361      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2362             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2363      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2364 C Derivatives in DC(i+1)
2365             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2366      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2367             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2368      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2369             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2370      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2371             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2372      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2373 C Derivatives in DC(j)
2374             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2375      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2376             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2377      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2378             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2379      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2380             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2381      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2382 C Derivatives in DC(j+1) or DC(nres-1)
2383             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2384      &      -3.0d0*vryg(k,3)*ury)
2385             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2386      &      -3.0d0*vrzg(k,3)*ury)
2387             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2388      &      -3.0d0*vryg(k,3)*urz)
2389             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2390      &      -3.0d0*vrzg(k,3)*urz)
2391 cd            aggi(k,1)=ghalf1
2392 cd            aggi(k,2)=ghalf2
2393 cd            aggi(k,3)=ghalf3
2394 cd            aggi(k,4)=ghalf4
2395 C Derivatives in DC(i+1)
2396 cd            aggi1(k,1)=agg(k,1)
2397 cd            aggi1(k,2)=agg(k,2)
2398 cd            aggi1(k,3)=agg(k,3)
2399 cd            aggi1(k,4)=agg(k,4)
2400 C Derivatives in DC(j)
2401 cd            aggj(k,1)=ghalf1
2402 cd            aggj(k,2)=ghalf2
2403 cd            aggj(k,3)=ghalf3
2404 cd            aggj(k,4)=ghalf4
2405 C Derivatives in DC(j+1)
2406 cd            aggj1(k,1)=0.0d0
2407 cd            aggj1(k,2)=0.0d0
2408 cd            aggj1(k,3)=0.0d0
2409 cd            aggj1(k,4)=0.0d0
2410             if (j.eq.nres-1 .and. i.lt.j-2) then
2411               do l=1,4
2412                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2413 cd                aggj1(k,l)=agg(k,l)
2414               enddo
2415             endif
2416           enddo
2417           endif
2418 c          goto 11111
2419 C Check the loc-el terms by numerical integration
2420           acipa(1,1)=a22
2421           acipa(1,2)=a23
2422           acipa(2,1)=a32
2423           acipa(2,2)=a33
2424           a22=-a22
2425           a23=-a23
2426           do l=1,2
2427             do k=1,3
2428               agg(k,l)=-agg(k,l)
2429               aggi(k,l)=-aggi(k,l)
2430               aggi1(k,l)=-aggi1(k,l)
2431               aggj(k,l)=-aggj(k,l)
2432               aggj1(k,l)=-aggj1(k,l)
2433             enddo
2434           enddo
2435           if (j.lt.nres-1) then
2436             a22=-a22
2437             a32=-a32
2438             do l=1,3,2
2439               do k=1,3
2440                 agg(k,l)=-agg(k,l)
2441                 aggi(k,l)=-aggi(k,l)
2442                 aggi1(k,l)=-aggi1(k,l)
2443                 aggj(k,l)=-aggj(k,l)
2444                 aggj1(k,l)=-aggj1(k,l)
2445               enddo
2446             enddo
2447           else
2448             a22=-a22
2449             a23=-a23
2450             a32=-a32
2451             a33=-a33
2452             do l=1,4
2453               do k=1,3
2454                 agg(k,l)=-agg(k,l)
2455                 aggi(k,l)=-aggi(k,l)
2456                 aggi1(k,l)=-aggi1(k,l)
2457                 aggj(k,l)=-aggj(k,l)
2458                 aggj1(k,l)=-aggj1(k,l)
2459               enddo
2460             enddo
2461           endif
2462           ENDIF ! WCORR
2463 11111     continue
2464           IF (wel_loc.gt.0.0d0) THEN
2465 C Contribution to the local-electrostatic energy coming from the i-j pair
2466           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2467      &     +a33*muij(4)
2468 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2469 C          write (iout,'(a6,2i5,0pf7.3)')
2470 C     &            'eelloc',i,j,eel_loc_ij
2471 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2472 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2473           eel_loc=eel_loc+eel_loc_ij
2474 C Partial derivatives in virtual-bond dihedral angles gamma
2475           if (calc_grad) then
2476           if (i.gt.1)
2477      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2478      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2479      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2480           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2481      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2482      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2483 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2484 cd          write(iout,*) 'agg  ',agg
2485 cd          write(iout,*) 'aggi ',aggi
2486 cd          write(iout,*) 'aggi1',aggi1
2487 cd          write(iout,*) 'aggj ',aggj
2488 cd          write(iout,*) 'aggj1',aggj1
2489
2490 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2491           do l=1,3
2492             ggg(l)=agg(l,1)*muij(1)+
2493      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2494           enddo
2495           do k=i+2,j2
2496             do l=1,3
2497               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2498             enddo
2499           enddo
2500 C Remaining derivatives of eello
2501           do l=1,3
2502             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2503      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2504             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2505      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2506             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2507      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2508             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2509      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2510           enddo
2511           endif
2512           ENDIF
2513           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2514 C Contributions from turns
2515             a_temp(1,1)=a22
2516             a_temp(1,2)=a23
2517             a_temp(2,1)=a32
2518             a_temp(2,2)=a33
2519             call eturn34(i,j,eello_turn3,eello_turn4)
2520           endif
2521 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2522           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2523 C
2524 C Calculate the contact function. The ith column of the array JCONT will
2525 C contain the numbers of atoms that make contacts with the atom I (of numbers
2526 C greater than I). The arrays FACONT and GACONT will contain the values of
2527 C the contact function and its derivative.
2528 c           r0ij=1.02D0*rpp(iteli,itelj)
2529 c           r0ij=1.11D0*rpp(iteli,itelj)
2530             r0ij=2.20D0*rpp(iteli,itelj)
2531 c           r0ij=1.55D0*rpp(iteli,itelj)
2532             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2533             if (fcont.gt.0.0D0) then
2534               num_conti=num_conti+1
2535               if (num_conti.gt.maxconts) then
2536                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2537      &                         ' will skip next contacts for this conf.'
2538               else
2539                 jcont_hb(num_conti,i)=j
2540                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2541      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2542 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2543 C  terms.
2544                 d_cont(num_conti,i)=rij
2545 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2546 C     --- Electrostatic-interaction matrix ---
2547                 a_chuj(1,1,num_conti,i)=a22
2548                 a_chuj(1,2,num_conti,i)=a23
2549                 a_chuj(2,1,num_conti,i)=a32
2550                 a_chuj(2,2,num_conti,i)=a33
2551 C     --- Gradient of rij
2552                 do kkk=1,3
2553                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2554                 enddo
2555 c             if (i.eq.1) then
2556 c                a_chuj(1,1,num_conti,i)=-0.61d0
2557 c                a_chuj(1,2,num_conti,i)= 0.4d0
2558 c                a_chuj(2,1,num_conti,i)= 0.65d0
2559 c                a_chuj(2,2,num_conti,i)= 0.50d0
2560 c             else if (i.eq.2) then
2561 c                a_chuj(1,1,num_conti,i)= 0.0d0
2562 c                a_chuj(1,2,num_conti,i)= 0.0d0
2563 c                a_chuj(2,1,num_conti,i)= 0.0d0
2564 c                a_chuj(2,2,num_conti,i)= 0.0d0
2565 c             endif
2566 C     --- and its gradients
2567 cd                write (iout,*) 'i',i,' j',j
2568 cd                do kkk=1,3
2569 cd                write (iout,*) 'iii 1 kkk',kkk
2570 cd                write (iout,*) agg(kkk,:)
2571 cd                enddo
2572 cd                do kkk=1,3
2573 cd                write (iout,*) 'iii 2 kkk',kkk
2574 cd                write (iout,*) aggi(kkk,:)
2575 cd                enddo
2576 cd                do kkk=1,3
2577 cd                write (iout,*) 'iii 3 kkk',kkk
2578 cd                write (iout,*) aggi1(kkk,:)
2579 cd                enddo
2580 cd                do kkk=1,3
2581 cd                write (iout,*) 'iii 4 kkk',kkk
2582 cd                write (iout,*) aggj(kkk,:)
2583 cd                enddo
2584 cd                do kkk=1,3
2585 cd                write (iout,*) 'iii 5 kkk',kkk
2586 cd                write (iout,*) aggj1(kkk,:)
2587 cd                enddo
2588                 kkll=0
2589                 do k=1,2
2590                   do l=1,2
2591                     kkll=kkll+1
2592                     do m=1,3
2593                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2594                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2595                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2596                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2597                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2598 c                      do mm=1,5
2599 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2600 c                      enddo
2601                     enddo
2602                   enddo
2603                 enddo
2604                 ENDIF
2605                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2606 C Calculate contact energies
2607                 cosa4=4.0D0*cosa
2608                 wij=cosa-3.0D0*cosb*cosg
2609                 cosbg1=cosb+cosg
2610                 cosbg2=cosb-cosg
2611 c               fac3=dsqrt(-ael6i)/r0ij**3
2612                 fac3=dsqrt(-ael6i)*r3ij
2613                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2614                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2615 c               ees0mij=0.0D0
2616                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2617                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2618 C Diagnostics. Comment out or remove after debugging!
2619 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2620 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2621 c               ees0m(num_conti,i)=0.0D0
2622 C End diagnostics.
2623 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2624 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2625                 facont_hb(num_conti,i)=fcont
2626                 if (calc_grad) then
2627 C Angular derivatives of the contact function
2628                 ees0pij1=fac3/ees0pij
2629                 ees0mij1=fac3/ees0mij
2630                 fac3p=-3.0D0*fac3*rrmij
2631                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2632                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2633 c               ees0mij1=0.0D0
2634                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2635                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2636                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2637                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2638                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2639                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2640                 ecosap=ecosa1+ecosa2
2641                 ecosbp=ecosb1+ecosb2
2642                 ecosgp=ecosg1+ecosg2
2643                 ecosam=ecosa1-ecosa2
2644                 ecosbm=ecosb1-ecosb2
2645                 ecosgm=ecosg1-ecosg2
2646 C Diagnostics
2647 c               ecosap=ecosa1
2648 c               ecosbp=ecosb1
2649 c               ecosgp=ecosg1
2650 c               ecosam=0.0D0
2651 c               ecosbm=0.0D0
2652 c               ecosgm=0.0D0
2653 C End diagnostics
2654                 fprimcont=fprimcont/rij
2655 cd              facont_hb(num_conti,i)=1.0D0
2656 C Following line is for diagnostics.
2657 cd              fprimcont=0.0D0
2658                 do k=1,3
2659                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2660                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2661                 enddo
2662                 do k=1,3
2663                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2664                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2665                 enddo
2666                 gggp(1)=gggp(1)+ees0pijp*xj
2667                 gggp(2)=gggp(2)+ees0pijp*yj
2668                 gggp(3)=gggp(3)+ees0pijp*zj
2669                 gggm(1)=gggm(1)+ees0mijp*xj
2670                 gggm(2)=gggm(2)+ees0mijp*yj
2671                 gggm(3)=gggm(3)+ees0mijp*zj
2672 C Derivatives due to the contact function
2673                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2674                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2675                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2676                 do k=1,3
2677                   ghalfp=0.5D0*gggp(k)
2678                   ghalfm=0.5D0*gggm(k)
2679                   gacontp_hb1(k,num_conti,i)=ghalfp
2680      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2681      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2682                   gacontp_hb2(k,num_conti,i)=ghalfp
2683      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2684      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2685                   gacontp_hb3(k,num_conti,i)=gggp(k)
2686                   gacontm_hb1(k,num_conti,i)=ghalfm
2687      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2688      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2689                   gacontm_hb2(k,num_conti,i)=ghalfm
2690      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2691      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2692                   gacontm_hb3(k,num_conti,i)=gggm(k)
2693                 enddo
2694                 endif
2695 C Diagnostics. Comment out or remove after debugging!
2696 cdiag           do k=1,3
2697 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2698 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2699 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2700 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2701 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2702 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2703 cdiag           enddo
2704               ENDIF ! wcorr
2705               endif  ! num_conti.le.maxconts
2706             endif  ! fcont.gt.0
2707           endif    ! j.gt.i+1
2708  1216     continue
2709         enddo ! j
2710         num_cont_hb(i)=num_conti
2711  1215   continue
2712       enddo   ! i
2713 cd      do i=1,nres
2714 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2715 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2716 cd      enddo
2717 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2718 ccc      eel_loc=eel_loc+eello_turn3
2719       return
2720       end
2721 C-----------------------------------------------------------------------------
2722       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2723 C Third- and fourth-order contributions from turns
2724       implicit real*8 (a-h,o-z)
2725       include 'DIMENSIONS'
2726       include 'DIMENSIONS.ZSCOPT'
2727       include 'COMMON.IOUNITS'
2728       include 'COMMON.GEO'
2729       include 'COMMON.VAR'
2730       include 'COMMON.LOCAL'
2731       include 'COMMON.CHAIN'
2732       include 'COMMON.DERIV'
2733       include 'COMMON.INTERACT'
2734       include 'COMMON.CONTACTS'
2735       include 'COMMON.TORSION'
2736       include 'COMMON.VECTORS'
2737       include 'COMMON.FFIELD'
2738       dimension ggg(3)
2739       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2740      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2741      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2742       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2743      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2744       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2745       if (j.eq.i+2) then
2746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2747 C
2748 C               Third-order contributions
2749 C
2750 C                 (i+2)o----(i+3)
2751 C                      | |
2752 C                      | |
2753 C                 (i+1)o----i
2754 C
2755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2756 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2757         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2758         call transpose2(auxmat(1,1),auxmat1(1,1))
2759         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2760         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2761 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2762 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2763 cd     &    ' eello_turn3_num',4*eello_turn3_num
2764         if (calc_grad) then
2765 C Derivatives in gamma(i)
2766         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2767         call transpose2(auxmat2(1,1),pizda(1,1))
2768         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2769         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2770 C Derivatives in gamma(i+1)
2771         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2772         call transpose2(auxmat2(1,1),pizda(1,1))
2773         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2774         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2775      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2776 C Cartesian derivatives
2777         do l=1,3
2778           a_temp(1,1)=aggi(l,1)
2779           a_temp(1,2)=aggi(l,2)
2780           a_temp(2,1)=aggi(l,3)
2781           a_temp(2,2)=aggi(l,4)
2782           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2783           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2784      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2785           a_temp(1,1)=aggi1(l,1)
2786           a_temp(1,2)=aggi1(l,2)
2787           a_temp(2,1)=aggi1(l,3)
2788           a_temp(2,2)=aggi1(l,4)
2789           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2790           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2791      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2792           a_temp(1,1)=aggj(l,1)
2793           a_temp(1,2)=aggj(l,2)
2794           a_temp(2,1)=aggj(l,3)
2795           a_temp(2,2)=aggj(l,4)
2796           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2797           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2798      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2799           a_temp(1,1)=aggj1(l,1)
2800           a_temp(1,2)=aggj1(l,2)
2801           a_temp(2,1)=aggj1(l,3)
2802           a_temp(2,2)=aggj1(l,4)
2803           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2804           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2805      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2806         enddo
2807         endif
2808       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2809       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2810 C changes suggested by Ana to avoid out of bounds
2811      & .or.((i+5).gt.nres)
2812      & .or.((i-1).le.0)
2813 C end of changes suggested by Ana
2814      &    .or. itype(i+3).eq.ntyp1
2815      &    .or. itype(i+4).eq.ntyp1
2816      &    .or. itype(i+5).eq.ntyp1
2817      &    .or. itype(i).eq.ntyp1
2818      &    .or. itype(i-1).eq.ntyp1) goto 178
2819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2820 C
2821 C               Fourth-order contributions
2822 C
2823 C                 (i+3)o----(i+4)
2824 C                     /  |
2825 C               (i+2)o   |
2826 C                     \  |
2827 C                 (i+1)o----i
2828 C
2829 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2830 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2831         iti1=itortyp(itype(i+1))
2832         iti2=itortyp(itype(i+2))
2833         iti3=itortyp(itype(i+3))
2834         call transpose2(EUg(1,1,i+1),e1t(1,1))
2835         call transpose2(Eug(1,1,i+2),e2t(1,1))
2836         call transpose2(Eug(1,1,i+3),e3t(1,1))
2837         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2838         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2839         s1=scalar2(b1(1,iti2),auxvec(1))
2840         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2841         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2842         s2=scalar2(b1(1,iti1),auxvec(1))
2843         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2844         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2845         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2846         eello_turn4=eello_turn4-(s1+s2+s3)
2847 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2848 cd     &    ' eello_turn4_num',8*eello_turn4_num
2849 C Derivatives in gamma(i)
2850         if (calc_grad) then
2851         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2852         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2853         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2854         s1=scalar2(b1(1,iti2),auxvec(1))
2855         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2856         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2857         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2858 C Derivatives in gamma(i+1)
2859         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2860         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2861         s2=scalar2(b1(1,iti1),auxvec(1))
2862         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2863         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2864         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2865         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2866 C Derivatives in gamma(i+2)
2867         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2868         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2869         s1=scalar2(b1(1,iti2),auxvec(1))
2870         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2871         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2872         s2=scalar2(b1(1,iti1),auxvec(1))
2873         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2874         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2875         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2876         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2877 C Cartesian derivatives
2878 C Derivatives of this turn contributions in DC(i+2)
2879         if (j.lt.nres-1) then
2880           do l=1,3
2881             a_temp(1,1)=agg(l,1)
2882             a_temp(1,2)=agg(l,2)
2883             a_temp(2,1)=agg(l,3)
2884             a_temp(2,2)=agg(l,4)
2885             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2886             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2887             s1=scalar2(b1(1,iti2),auxvec(1))
2888             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2889             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2890             s2=scalar2(b1(1,iti1),auxvec(1))
2891             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2892             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2893             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2894             ggg(l)=-(s1+s2+s3)
2895             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2896           enddo
2897         endif
2898 C Remaining derivatives of this turn contribution
2899         do l=1,3
2900           a_temp(1,1)=aggi(l,1)
2901           a_temp(1,2)=aggi(l,2)
2902           a_temp(2,1)=aggi(l,3)
2903           a_temp(2,2)=aggi(l,4)
2904           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2905           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2906           s1=scalar2(b1(1,iti2),auxvec(1))
2907           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2908           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2909           s2=scalar2(b1(1,iti1),auxvec(1))
2910           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2911           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2912           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2913           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2914           a_temp(1,1)=aggi1(l,1)
2915           a_temp(1,2)=aggi1(l,2)
2916           a_temp(2,1)=aggi1(l,3)
2917           a_temp(2,2)=aggi1(l,4)
2918           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2919           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2920           s1=scalar2(b1(1,iti2),auxvec(1))
2921           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2922           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2923           s2=scalar2(b1(1,iti1),auxvec(1))
2924           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2925           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2926           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2927           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2928           a_temp(1,1)=aggj(l,1)
2929           a_temp(1,2)=aggj(l,2)
2930           a_temp(2,1)=aggj(l,3)
2931           a_temp(2,2)=aggj(l,4)
2932           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2933           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2934           s1=scalar2(b1(1,iti2),auxvec(1))
2935           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2936           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2937           s2=scalar2(b1(1,iti1),auxvec(1))
2938           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2939           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2940           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2941           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2942           a_temp(1,1)=aggj1(l,1)
2943           a_temp(1,2)=aggj1(l,2)
2944           a_temp(2,1)=aggj1(l,3)
2945           a_temp(2,2)=aggj1(l,4)
2946           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2947           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2948           s1=scalar2(b1(1,iti2),auxvec(1))
2949           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2950           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2951           s2=scalar2(b1(1,iti1),auxvec(1))
2952           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2953           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2954           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2955           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2956         enddo
2957         endif
2958  178  continue
2959       endif
2960       return
2961       end
2962 C-----------------------------------------------------------------------------
2963       subroutine vecpr(u,v,w)
2964       implicit real*8(a-h,o-z)
2965       dimension u(3),v(3),w(3)
2966       w(1)=u(2)*v(3)-u(3)*v(2)
2967       w(2)=-u(1)*v(3)+u(3)*v(1)
2968       w(3)=u(1)*v(2)-u(2)*v(1)
2969       return
2970       end
2971 C-----------------------------------------------------------------------------
2972       subroutine unormderiv(u,ugrad,unorm,ungrad)
2973 C This subroutine computes the derivatives of a normalized vector u, given
2974 C the derivatives computed without normalization conditions, ugrad. Returns
2975 C ungrad.
2976       implicit none
2977       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2978       double precision vec(3)
2979       double precision scalar
2980       integer i,j
2981 c      write (2,*) 'ugrad',ugrad
2982 c      write (2,*) 'u',u
2983       do i=1,3
2984         vec(i)=scalar(ugrad(1,i),u(1))
2985       enddo
2986 c      write (2,*) 'vec',vec
2987       do i=1,3
2988         do j=1,3
2989           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2990         enddo
2991       enddo
2992 c      write (2,*) 'ungrad',ungrad
2993       return
2994       end
2995 C-----------------------------------------------------------------------------
2996       subroutine escp(evdw2,evdw2_14)
2997 C
2998 C This subroutine calculates the excluded-volume interaction energy between
2999 C peptide-group centers and side chains and its gradient in virtual-bond and
3000 C side-chain vectors.
3001 C
3002       implicit real*8 (a-h,o-z)
3003       include 'DIMENSIONS'
3004       include 'DIMENSIONS.ZSCOPT'
3005       include 'COMMON.GEO'
3006       include 'COMMON.VAR'
3007       include 'COMMON.LOCAL'
3008       include 'COMMON.CHAIN'
3009       include 'COMMON.DERIV'
3010       include 'COMMON.INTERACT'
3011       include 'COMMON.FFIELD'
3012       include 'COMMON.IOUNITS'
3013       dimension ggg(3)
3014       evdw2=0.0D0
3015       evdw2_14=0.0d0
3016 cd    print '(a)','Enter ESCP'
3017 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3018 c     &  ' scal14',scal14
3019       do i=iatscp_s,iatscp_e
3020         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3021         iteli=itel(i)
3022 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3023 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3024         if (iteli.eq.0) goto 1225
3025         xi=0.5D0*(c(1,i)+c(1,i+1))
3026         yi=0.5D0*(c(2,i)+c(2,i+1))
3027         zi=0.5D0*(c(3,i)+c(3,i+1))
3028 C Returning the ith atom to box
3029           xi=mod(xi,boxxsize)
3030           if (xi.lt.0) xi=xi+boxxsize
3031           yi=mod(yi,boxysize)
3032           if (yi.lt.0) yi=yi+boxysize
3033           zi=mod(zi,boxzsize)
3034           if (zi.lt.0) zi=zi+boxzsize
3035         do iint=1,nscp_gr(i)
3036
3037         do j=iscpstart(i,iint),iscpend(i,iint)
3038           itypj=iabs(itype(j))
3039           if (itypj.eq.ntyp1) cycle
3040 C Uncomment following three lines for SC-p interactions
3041 c         xj=c(1,nres+j)-xi
3042 c         yj=c(2,nres+j)-yi
3043 c         zj=c(3,nres+j)-zi
3044 C Uncomment following three lines for Ca-p interactions
3045           xj=c(1,j)
3046           yj=c(2,j)
3047           zj=c(3,j)
3048 C returning the jth atom to box
3049           xj=mod(xj,boxxsize)
3050           if (xj.lt.0) xj=xj+boxxsize
3051           yj=mod(yj,boxysize)
3052           if (yj.lt.0) yj=yj+boxysize
3053           zj=mod(zj,boxzsize)
3054           if (zj.lt.0) zj=zj+boxzsize
3055       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3056       xj_safe=xj
3057       yj_safe=yj
3058       zj_safe=zj
3059       subchap=0
3060 C Finding the closest jth atom
3061       do xshift=-1,1
3062       do yshift=-1,1
3063       do zshift=-1,1
3064           xj=xj_safe+xshift*boxxsize
3065           yj=yj_safe+yshift*boxysize
3066           zj=zj_safe+zshift*boxzsize
3067           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3068           if(dist_temp.lt.dist_init) then
3069             dist_init=dist_temp
3070             xj_temp=xj
3071             yj_temp=yj
3072             zj_temp=zj
3073             subchap=1
3074           endif
3075        enddo
3076        enddo
3077        enddo
3078        if (subchap.eq.1) then
3079           xj=xj_temp-xi
3080           yj=yj_temp-yi
3081           zj=zj_temp-zi
3082        else
3083           xj=xj_safe-xi
3084           yj=yj_safe-yi
3085           zj=zj_safe-zi
3086        endif
3087           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3088 C sss is scaling function for smoothing the cutoff gradient otherwise
3089 C the gradient would not be continuouse
3090           sss=sscale(1.0d0/(dsqrt(rrij)))
3091           if (sss.le.0.0d0) cycle
3092           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3093           fac=rrij**expon2
3094           e1=fac*fac*aad(itypj,iteli)
3095           e2=fac*bad(itypj,iteli)
3096           if (iabs(j-i) .le. 2) then
3097             e1=scal14*e1
3098             e2=scal14*e2
3099             evdw2_14=evdw2_14+(e1+e2)*sss
3100           endif
3101           evdwij=e1+e2
3102 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3103 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3104 c     &       bad(itypj,iteli)
3105           evdw2=evdw2+evdwij*sss
3106           if (calc_grad) then
3107 C
3108 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3109 C
3110           fac=-(evdwij+e1)*rrij*sss
3111           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3112           ggg(1)=xj*fac
3113           ggg(2)=yj*fac
3114           ggg(3)=zj*fac
3115           if (j.lt.i) then
3116 cd          write (iout,*) 'j<i'
3117 C Uncomment following three lines for SC-p interactions
3118 c           do k=1,3
3119 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3120 c           enddo
3121           else
3122 cd          write (iout,*) 'j>i'
3123             do k=1,3
3124               ggg(k)=-ggg(k)
3125 C Uncomment following line for SC-p interactions
3126 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3127             enddo
3128           endif
3129           do k=1,3
3130             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3131           enddo
3132           kstart=min0(i+1,j)
3133           kend=max0(i-1,j-1)
3134 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3135 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3136           do k=kstart,kend
3137             do l=1,3
3138               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3139             enddo
3140           enddo
3141           endif
3142         enddo
3143         enddo ! iint
3144  1225   continue
3145       enddo ! i
3146       do i=1,nct
3147         do j=1,3
3148           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3149           gradx_scp(j,i)=expon*gradx_scp(j,i)
3150         enddo
3151       enddo
3152 C******************************************************************************
3153 C
3154 C                              N O T E !!!
3155 C
3156 C To save time the factor EXPON has been extracted from ALL components
3157 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3158 C use!
3159 C
3160 C******************************************************************************
3161       return
3162       end
3163 C--------------------------------------------------------------------------
3164       subroutine edis(ehpb)
3165 C
3166 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3167 C
3168       implicit real*8 (a-h,o-z)
3169       include 'DIMENSIONS'
3170       include 'DIMENSIONS.ZSCOPT'
3171       include 'COMMON.SBRIDGE'
3172       include 'COMMON.CHAIN'
3173       include 'COMMON.DERIV'
3174       include 'COMMON.VAR'
3175       include 'COMMON.INTERACT'
3176       dimension ggg(3)
3177       ehpb=0.0D0
3178 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3179 cd    print *,'link_start=',link_start,' link_end=',link_end
3180       if (link_end.eq.0) return
3181       do i=link_start,link_end
3182 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3183 C CA-CA distance used in regularization of structure.
3184         ii=ihpb(i)
3185         jj=jhpb(i)
3186 C iii and jjj point to the residues for which the distance is assigned.
3187         if (ii.gt.nres) then
3188           iii=ii-nres
3189           jjj=jj-nres
3190         else
3191           iii=ii
3192           jjj=jj
3193         endif
3194 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3195 C    distance and angle dependent SS bond potential.
3196         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3197      & iabs(itype(jjj)).eq.1) then
3198           call ssbond_ene(iii,jjj,eij)
3199           ehpb=ehpb+2*eij
3200         else
3201 C Calculate the distance between the two points and its difference from the
3202 C target distance.
3203         dd=dist(ii,jj)
3204         rdis=dd-dhpb(i)
3205 C Get the force constant corresponding to this distance.
3206         waga=forcon(i)
3207 C Calculate the contribution to energy.
3208         ehpb=ehpb+waga*rdis*rdis
3209 C
3210 C Evaluate gradient.
3211 C
3212         fac=waga*rdis/dd
3213 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3214 cd   &   ' waga=',waga,' fac=',fac
3215         do j=1,3
3216           ggg(j)=fac*(c(j,jj)-c(j,ii))
3217         enddo
3218 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3219 C If this is a SC-SC distance, we need to calculate the contributions to the
3220 C Cartesian gradient in the SC vectors (ghpbx).
3221         if (iii.lt.ii) then
3222           do j=1,3
3223             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3224             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3225           enddo
3226         endif
3227         do j=iii,jjj-1
3228           do k=1,3
3229             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3230           enddo
3231         enddo
3232         endif
3233       enddo
3234       ehpb=0.5D0*ehpb
3235       return
3236       end
3237 C--------------------------------------------------------------------------
3238       subroutine ssbond_ene(i,j,eij)
3239 C
3240 C Calculate the distance and angle dependent SS-bond potential energy
3241 C using a free-energy function derived based on RHF/6-31G** ab initio
3242 C calculations of diethyl disulfide.
3243 C
3244 C A. Liwo and U. Kozlowska, 11/24/03
3245 C
3246       implicit real*8 (a-h,o-z)
3247       include 'DIMENSIONS'
3248       include 'DIMENSIONS.ZSCOPT'
3249       include 'COMMON.SBRIDGE'
3250       include 'COMMON.CHAIN'
3251       include 'COMMON.DERIV'
3252       include 'COMMON.LOCAL'
3253       include 'COMMON.INTERACT'
3254       include 'COMMON.VAR'
3255       include 'COMMON.IOUNITS'
3256       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3257       itypi=iabs(itype(i))
3258       xi=c(1,nres+i)
3259       yi=c(2,nres+i)
3260       zi=c(3,nres+i)
3261       dxi=dc_norm(1,nres+i)
3262       dyi=dc_norm(2,nres+i)
3263       dzi=dc_norm(3,nres+i)
3264       dsci_inv=dsc_inv(itypi)
3265       itypj=iabs(itype(j))
3266       dscj_inv=dsc_inv(itypj)
3267       xj=c(1,nres+j)-xi
3268       yj=c(2,nres+j)-yi
3269       zj=c(3,nres+j)-zi
3270       dxj=dc_norm(1,nres+j)
3271       dyj=dc_norm(2,nres+j)
3272       dzj=dc_norm(3,nres+j)
3273       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3274       rij=dsqrt(rrij)
3275       erij(1)=xj*rij
3276       erij(2)=yj*rij
3277       erij(3)=zj*rij
3278       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3279       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3280       om12=dxi*dxj+dyi*dyj+dzi*dzj
3281       do k=1,3
3282         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3283         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3284       enddo
3285       rij=1.0d0/rij
3286       deltad=rij-d0cm
3287       deltat1=1.0d0-om1
3288       deltat2=1.0d0+om2
3289       deltat12=om2-om1+2.0d0
3290       cosphi=om12-om1*om2
3291       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3292      &  +akct*deltad*deltat12
3293      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3294 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3295 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3296 c     &  " deltat12",deltat12," eij",eij
3297       ed=2*akcm*deltad+akct*deltat12
3298       pom1=akct*deltad
3299       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3300       eom1=-2*akth*deltat1-pom1-om2*pom2
3301       eom2= 2*akth*deltat2+pom1-om1*pom2
3302       eom12=pom2
3303       do k=1,3
3304         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3305       enddo
3306       do k=1,3
3307         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3308      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3309         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3310      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3311       enddo
3312 C
3313 C Calculate the components of the gradient in DC and X
3314 C
3315       do k=i,j-1
3316         do l=1,3
3317           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3318         enddo
3319       enddo
3320       return
3321       end
3322 C--------------------------------------------------------------------------
3323       subroutine ebond(estr)
3324 c
3325 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3326 c
3327       implicit real*8 (a-h,o-z)
3328       include 'DIMENSIONS'
3329       include 'DIMENSIONS.ZSCOPT'
3330       include 'COMMON.LOCAL'
3331       include 'COMMON.GEO'
3332       include 'COMMON.INTERACT'
3333       include 'COMMON.DERIV'
3334       include 'COMMON.VAR'
3335       include 'COMMON.CHAIN'
3336       include 'COMMON.IOUNITS'
3337       include 'COMMON.NAMES'
3338       include 'COMMON.FFIELD'
3339       include 'COMMON.CONTROL'
3340       logical energy_dec /.false./
3341       double precision u(3),ud(3)
3342       estr=0.0d0
3343       estr1=0.0d0
3344 c      write (iout,*) "distchainmax",distchainmax
3345       do i=nnt+1,nct
3346         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3347 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3348 C          do j=1,3
3349 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3350 C     &      *dc(j,i-1)/vbld(i)
3351 C          enddo
3352 C          if (energy_dec) write(iout,*)
3353 C     &       "estr1",i,vbld(i),distchainmax,
3354 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3355 C        else
3356          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3357         diff = vbld(i)-vbldpDUM
3358          else
3359           diff = vbld(i)-vbldp0
3360 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3361          endif
3362           estr=estr+diff*diff
3363           do j=1,3
3364             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3365           enddo
3366 C        endif
3367 C        write (iout,'(a7,i5,4f7.3)')
3368 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3369       enddo
3370       estr=0.5d0*AKP*estr+estr1
3371 c
3372 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3373 c
3374       do i=nnt,nct
3375         iti=iabs(itype(i))
3376         if (iti.ne.10 .and. iti.ne.ntyp1) then
3377           nbi=nbondterm(iti)
3378           if (nbi.eq.1) then
3379             diff=vbld(i+nres)-vbldsc0(1,iti)
3380 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3381 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3382             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3383             do j=1,3
3384               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3385             enddo
3386           else
3387             do j=1,nbi
3388               diff=vbld(i+nres)-vbldsc0(j,iti)
3389               ud(j)=aksc(j,iti)*diff
3390               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3391             enddo
3392             uprod=u(1)
3393             do j=2,nbi
3394               uprod=uprod*u(j)
3395             enddo
3396             usum=0.0d0
3397             usumsqder=0.0d0
3398             do j=1,nbi
3399               uprod1=1.0d0
3400               uprod2=1.0d0
3401               do k=1,nbi
3402                 if (k.ne.j) then
3403                   uprod1=uprod1*u(k)
3404                   uprod2=uprod2*u(k)*u(k)
3405                 endif
3406               enddo
3407               usum=usum+uprod1
3408               usumsqder=usumsqder+ud(j)*uprod2
3409             enddo
3410 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3411 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3412             estr=estr+uprod/usum
3413             do j=1,3
3414              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3415             enddo
3416           endif
3417         endif
3418       enddo
3419       return
3420       end
3421 #ifdef CRYST_THETA
3422 C--------------------------------------------------------------------------
3423       subroutine ebend(etheta)
3424 C
3425 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3426 C angles gamma and its derivatives in consecutive thetas and gammas.
3427 C
3428       implicit real*8 (a-h,o-z)
3429       include 'DIMENSIONS'
3430       include 'DIMENSIONS.ZSCOPT'
3431       include 'COMMON.LOCAL'
3432       include 'COMMON.GEO'
3433       include 'COMMON.INTERACT'
3434       include 'COMMON.DERIV'
3435       include 'COMMON.VAR'
3436       include 'COMMON.CHAIN'
3437       include 'COMMON.IOUNITS'
3438       include 'COMMON.NAMES'
3439       include 'COMMON.FFIELD'
3440       common /calcthet/ term1,term2,termm,diffak,ratak,
3441      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3442      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3443       double precision y(2),z(2)
3444       delta=0.02d0*pi
3445       time11=dexp(-2*time)
3446       time12=1.0d0
3447       etheta=0.0D0
3448 c      write (iout,*) "nres",nres
3449 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3450 c      write (iout,*) ithet_start,ithet_end
3451       do i=ithet_start,ithet_end
3452 C        if (itype(i-1).eq.ntyp1) cycle
3453         if (i.le.2) cycle
3454         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3455      &  .or.itype(i).eq.ntyp1) cycle
3456 C Zero the energy function and its derivative at 0 or pi.
3457         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3458         it=itype(i-1)
3459         ichir1=isign(1,itype(i-2))
3460         ichir2=isign(1,itype(i))
3461          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3462          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3463          if (itype(i-1).eq.10) then
3464           itype1=isign(10,itype(i-2))
3465           ichir11=isign(1,itype(i-2))
3466           ichir12=isign(1,itype(i-2))
3467           itype2=isign(10,itype(i))
3468           ichir21=isign(1,itype(i))
3469           ichir22=isign(1,itype(i))
3470          endif
3471          if (i.eq.3) then
3472           y(1)=0.0D0
3473           y(2)=0.0D0
3474           else
3475
3476         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3477 #ifdef OSF
3478           phii=phi(i)
3479           icrc=0
3480           call proc_proc(phii,icrc)
3481           if (icrc.eq.1) phii=150.0
3482 #else
3483           phii=phi(i)
3484 #endif
3485           y(1)=dcos(phii)
3486           y(2)=dsin(phii)
3487         else
3488           y(1)=0.0D0
3489           y(2)=0.0D0
3490         endif
3491         endif
3492         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3493 #ifdef OSF
3494           phii1=phi(i+1)
3495           icrc=0
3496           call proc_proc(phii1,icrc)
3497           if (icrc.eq.1) phii1=150.0
3498           phii1=pinorm(phii1)
3499           z(1)=cos(phii1)
3500 #else
3501           phii1=phi(i+1)
3502           z(1)=dcos(phii1)
3503 #endif
3504           z(2)=dsin(phii1)
3505         else
3506           z(1)=0.0D0
3507           z(2)=0.0D0
3508         endif
3509 C Calculate the "mean" value of theta from the part of the distribution
3510 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3511 C In following comments this theta will be referred to as t_c.
3512         thet_pred_mean=0.0d0
3513         do k=1,2
3514             athetk=athet(k,it,ichir1,ichir2)
3515             bthetk=bthet(k,it,ichir1,ichir2)
3516           if (it.eq.10) then
3517              athetk=athet(k,itype1,ichir11,ichir12)
3518              bthetk=bthet(k,itype2,ichir21,ichir22)
3519           endif
3520           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3521         enddo
3522 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3523         dthett=thet_pred_mean*ssd
3524         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3525 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3526 C Derivatives of the "mean" values in gamma1 and gamma2.
3527         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3528      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3529          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3530      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3531          if (it.eq.10) then
3532       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3533      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3534         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3535      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3536          endif
3537         if (theta(i).gt.pi-delta) then
3538           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3539      &         E_tc0)
3540           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3541           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3542           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3543      &        E_theta)
3544           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3545      &        E_tc)
3546         else if (theta(i).lt.delta) then
3547           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3548           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3549           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3550      &        E_theta)
3551           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3552           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3553      &        E_tc)
3554         else
3555           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3556      &        E_theta,E_tc)
3557         endif
3558         etheta=etheta+ethetai
3559 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
3560 c     &      'ebend',i,ethetai,theta(i),itype(i)
3561 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3562 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3563         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3564         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3565         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3566  1215   continue
3567       enddo
3568 C Ufff.... We've done all this!!!
3569       return
3570       end
3571 C---------------------------------------------------------------------------
3572       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3573      &     E_tc)
3574       implicit real*8 (a-h,o-z)
3575       include 'DIMENSIONS'
3576       include 'COMMON.LOCAL'
3577       include 'COMMON.IOUNITS'
3578       common /calcthet/ term1,term2,termm,diffak,ratak,
3579      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3580      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3581 C Calculate the contributions to both Gaussian lobes.
3582 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3583 C The "polynomial part" of the "standard deviation" of this part of
3584 C the distribution.
3585         sig=polthet(3,it)
3586         do j=2,0,-1
3587           sig=sig*thet_pred_mean+polthet(j,it)
3588         enddo
3589 C Derivative of the "interior part" of the "standard deviation of the"
3590 C gamma-dependent Gaussian lobe in t_c.
3591         sigtc=3*polthet(3,it)
3592         do j=2,1,-1
3593           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3594         enddo
3595         sigtc=sig*sigtc
3596 C Set the parameters of both Gaussian lobes of the distribution.
3597 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3598         fac=sig*sig+sigc0(it)
3599         sigcsq=fac+fac
3600         sigc=1.0D0/sigcsq
3601 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3602         sigsqtc=-4.0D0*sigcsq*sigtc
3603 c       print *,i,sig,sigtc,sigsqtc
3604 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3605         sigtc=-sigtc/(fac*fac)
3606 C Following variable is sigma(t_c)**(-2)
3607         sigcsq=sigcsq*sigcsq
3608         sig0i=sig0(it)
3609         sig0inv=1.0D0/sig0i**2
3610         delthec=thetai-thet_pred_mean
3611         delthe0=thetai-theta0i
3612         term1=-0.5D0*sigcsq*delthec*delthec
3613         term2=-0.5D0*sig0inv*delthe0*delthe0
3614 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3615 C NaNs in taking the logarithm. We extract the largest exponent which is added
3616 C to the energy (this being the log of the distribution) at the end of energy
3617 C term evaluation for this virtual-bond angle.
3618         if (term1.gt.term2) then
3619           termm=term1
3620           term2=dexp(term2-termm)
3621           term1=1.0d0
3622         else
3623           termm=term2
3624           term1=dexp(term1-termm)
3625           term2=1.0d0
3626         endif
3627 C The ratio between the gamma-independent and gamma-dependent lobes of
3628 C the distribution is a Gaussian function of thet_pred_mean too.
3629         diffak=gthet(2,it)-thet_pred_mean
3630         ratak=diffak/gthet(3,it)**2
3631         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3632 C Let's differentiate it in thet_pred_mean NOW.
3633         aktc=ak*ratak
3634 C Now put together the distribution terms to make complete distribution.
3635         termexp=term1+ak*term2
3636         termpre=sigc+ak*sig0i
3637 C Contribution of the bending energy from this theta is just the -log of
3638 C the sum of the contributions from the two lobes and the pre-exponential
3639 C factor. Simple enough, isn't it?
3640         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3641 C NOW the derivatives!!!
3642 C 6/6/97 Take into account the deformation.
3643         E_theta=(delthec*sigcsq*term1
3644      &       +ak*delthe0*sig0inv*term2)/termexp
3645         E_tc=((sigtc+aktc*sig0i)/termpre
3646      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3647      &       aktc*term2)/termexp)
3648       return
3649       end
3650 c-----------------------------------------------------------------------------
3651       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3652       implicit real*8 (a-h,o-z)
3653       include 'DIMENSIONS'
3654       include 'COMMON.LOCAL'
3655       include 'COMMON.IOUNITS'
3656       common /calcthet/ term1,term2,termm,diffak,ratak,
3657      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3658      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3659       delthec=thetai-thet_pred_mean
3660       delthe0=thetai-theta0i
3661 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3662       t3 = thetai-thet_pred_mean
3663       t6 = t3**2
3664       t9 = term1
3665       t12 = t3*sigcsq
3666       t14 = t12+t6*sigsqtc
3667       t16 = 1.0d0
3668       t21 = thetai-theta0i
3669       t23 = t21**2
3670       t26 = term2
3671       t27 = t21*t26
3672       t32 = termexp
3673       t40 = t32**2
3674       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3675      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3676      & *(-t12*t9-ak*sig0inv*t27)
3677       return
3678       end
3679 #else
3680 C--------------------------------------------------------------------------
3681       subroutine ebend(etheta)
3682 C
3683 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3684 C angles gamma and its derivatives in consecutive thetas and gammas.
3685 C ab initio-derived potentials from
3686 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3687 C
3688       implicit real*8 (a-h,o-z)
3689       include 'DIMENSIONS'
3690       include 'DIMENSIONS.ZSCOPT'
3691       include 'COMMON.LOCAL'
3692       include 'COMMON.GEO'
3693       include 'COMMON.INTERACT'
3694       include 'COMMON.DERIV'
3695       include 'COMMON.VAR'
3696       include 'COMMON.CHAIN'
3697       include 'COMMON.IOUNITS'
3698       include 'COMMON.NAMES'
3699       include 'COMMON.FFIELD'
3700       include 'COMMON.CONTROL'
3701       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3702      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3703      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3704      & sinph1ph2(maxdouble,maxdouble)
3705       logical lprn /.false./, lprn1 /.false./
3706       etheta=0.0D0
3707 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3708       do i=ithet_start,ithet_end
3709 C         if (i.eq.2) cycle
3710 C        if (itype(i-1).eq.ntyp1) cycle
3711         if (i.le.2) cycle
3712         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3713      &  .or.itype(i).eq.ntyp1) cycle
3714         if (iabs(itype(i+1)).eq.20) iblock=2
3715         if (iabs(itype(i+1)).ne.20) iblock=1
3716         dethetai=0.0d0
3717         dephii=0.0d0
3718         dephii1=0.0d0
3719         theti2=0.5d0*theta(i)
3720         ityp2=ithetyp((itype(i-1)))
3721         do k=1,nntheterm
3722           coskt(k)=dcos(k*theti2)
3723           sinkt(k)=dsin(k*theti2)
3724         enddo
3725         if (i.eq.3) then
3726           phii=0.0d0
3727           ityp1=nthetyp+1
3728           do k=1,nsingle
3729             cosph1(k)=0.0d0
3730             sinph1(k)=0.0d0
3731           enddo
3732         else
3733         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3734 #ifdef OSF
3735           phii=phi(i)
3736           if (phii.ne.phii) phii=150.0
3737 #else
3738           phii=phi(i)
3739 #endif
3740           ityp1=ithetyp((itype(i-2)))
3741           do k=1,nsingle
3742             cosph1(k)=dcos(k*phii)
3743             sinph1(k)=dsin(k*phii)
3744           enddo
3745         else
3746           phii=0.0d0
3747           ityp1=nthetyp+1
3748           do k=1,nsingle
3749             cosph1(k)=0.0d0
3750             sinph1(k)=0.0d0
3751           enddo
3752         endif
3753         endif
3754         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3755 #ifdef OSF
3756           phii1=phi(i+1)
3757           if (phii1.ne.phii1) phii1=150.0
3758           phii1=pinorm(phii1)
3759 #else
3760           phii1=phi(i+1)
3761 #endif
3762           ityp3=ithetyp((itype(i)))
3763           do k=1,nsingle
3764             cosph2(k)=dcos(k*phii1)
3765             sinph2(k)=dsin(k*phii1)
3766           enddo
3767         else
3768           phii1=0.0d0
3769           ityp3=nthetyp+1
3770           do k=1,nsingle
3771             cosph2(k)=0.0d0
3772             sinph2(k)=0.0d0
3773           enddo
3774         endif
3775 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3776 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3777 c        call flush(iout)
3778         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
3779         do k=1,ndouble
3780           do l=1,k-1
3781             ccl=cosph1(l)*cosph2(k-l)
3782             ssl=sinph1(l)*sinph2(k-l)
3783             scl=sinph1(l)*cosph2(k-l)
3784             csl=cosph1(l)*sinph2(k-l)
3785             cosph1ph2(l,k)=ccl-ssl
3786             cosph1ph2(k,l)=ccl+ssl
3787             sinph1ph2(l,k)=scl+csl
3788             sinph1ph2(k,l)=scl-csl
3789           enddo
3790         enddo
3791         if (lprn) then
3792         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3793      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3794         write (iout,*) "coskt and sinkt"
3795         do k=1,nntheterm
3796           write (iout,*) k,coskt(k),sinkt(k)
3797         enddo
3798         endif
3799         do k=1,ntheterm
3800           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
3801           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
3802      &      *coskt(k)
3803           if (lprn)
3804      &    write (iout,*) "k",k,"
3805      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
3806      &     " ethetai",ethetai
3807         enddo
3808         if (lprn) then
3809         write (iout,*) "cosph and sinph"
3810         do k=1,nsingle
3811           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3812         enddo
3813         write (iout,*) "cosph1ph2 and sinph2ph2"
3814         do k=2,ndouble
3815           do l=1,k-1
3816             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3817      &         sinph1ph2(l,k),sinph1ph2(k,l)
3818           enddo
3819         enddo
3820         write(iout,*) "ethetai",ethetai
3821         endif
3822         do m=1,ntheterm2
3823           do k=1,nsingle
3824             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
3825      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
3826      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
3827      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
3828             ethetai=ethetai+sinkt(m)*aux
3829             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3830             dephii=dephii+k*sinkt(m)*(
3831      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
3832      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
3833             dephii1=dephii1+k*sinkt(m)*(
3834      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
3835      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
3836             if (lprn)
3837      &      write (iout,*) "m",m," k",k," bbthet",
3838      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
3839      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
3840      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
3841      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
3842           enddo
3843         enddo
3844         if (lprn)
3845      &  write(iout,*) "ethetai",ethetai
3846         do m=1,ntheterm3
3847           do k=2,ndouble
3848             do l=1,k-1
3849               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3850      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
3851      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3852      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
3853               ethetai=ethetai+sinkt(m)*aux
3854               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3855               dephii=dephii+l*sinkt(m)*(
3856      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
3857      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3858      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3859      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3860               dephii1=dephii1+(k-l)*sinkt(m)*(
3861      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3862      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3863      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
3864      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3865               if (lprn) then
3866               write (iout,*) "m",m," k",k," l",l," ffthet",
3867      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3868      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
3869      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3870      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
3871      &            " ethetai",ethetai
3872               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3873      &            cosph1ph2(k,l)*sinkt(m),
3874      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3875               endif
3876             enddo
3877           enddo
3878         enddo
3879 10      continue
3880         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3881      &   i,theta(i)*rad2deg,phii*rad2deg,
3882      &   phii1*rad2deg,ethetai
3883         etheta=etheta+ethetai
3884         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3885         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3886         gloc(nphi+i-2,icg)=wang*dethetai
3887       enddo
3888       return
3889       end
3890 #endif
3891 #ifdef CRYST_SC
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.
3897       implicit real*8 (a-h,o-z)
3898       include 'DIMENSIONS'
3899       include 'DIMENSIONS.ZSCOPT'
3900       include 'COMMON.GEO'
3901       include 'COMMON.LOCAL'
3902       include 'COMMON.VAR'
3903       include 'COMMON.INTERACT'
3904       include 'COMMON.DERIV'
3905       include 'COMMON.CHAIN'
3906       include 'COMMON.IOUNITS'
3907       include 'COMMON.NAMES'
3908       include 'COMMON.FFIELD'
3909       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3910      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3911       common /sccalc/ time11,time12,time112,theti,it,nlobit
3912       delta=0.02d0*pi
3913       escloc=0.0D0
3914 C      write (iout,*) 'ESC'
3915       do i=loc_start,loc_end
3916         it=itype(i)
3917         if (it.eq.ntyp1) cycle
3918         if (it.eq.10) goto 1
3919         nlobit=nlob(iabs(it))
3920 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3921 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3922         theti=theta(i+1)-pipol
3923         x(1)=dtan(theti)
3924         x(2)=alph(i)
3925         x(3)=omeg(i)
3926 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3927
3928         if (x(2).gt.pi-delta) then
3929           xtemp(1)=x(1)
3930           xtemp(2)=pi-delta
3931           xtemp(3)=x(3)
3932           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3933           xtemp(2)=pi
3934           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3935           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3936      &        escloci,dersc(2))
3937           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3938      &        ddersc0(1),dersc(1))
3939           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3940      &        ddersc0(3),dersc(3))
3941           xtemp(2)=pi-delta
3942           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3943           xtemp(2)=pi
3944           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3945           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3946      &            dersc0(2),esclocbi,dersc02)
3947           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3948      &            dersc12,dersc01)
3949           call splinthet(x(2),0.5d0*delta,ss,ssd)
3950           dersc0(1)=dersc01
3951           dersc0(2)=dersc02
3952           dersc0(3)=0.0d0
3953           do k=1,3
3954             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3955           enddo
3956           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3957           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3958      &             esclocbi,ss,ssd
3959           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3960 c         escloci=esclocbi
3961 c         write (iout,*) escloci
3962         else if (x(2).lt.delta) then
3963           xtemp(1)=x(1)
3964           xtemp(2)=delta
3965           xtemp(3)=x(3)
3966           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3967           xtemp(2)=0.0d0
3968           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3969           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3970      &        escloci,dersc(2))
3971           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3972      &        ddersc0(1),dersc(1))
3973           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3974      &        ddersc0(3),dersc(3))
3975           xtemp(2)=delta
3976           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3977           xtemp(2)=0.0d0
3978           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3979           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3980      &            dersc0(2),esclocbi,dersc02)
3981           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3982      &            dersc12,dersc01)
3983           dersc0(1)=dersc01
3984           dersc0(2)=dersc02
3985           dersc0(3)=0.0d0
3986           call splinthet(x(2),0.5d0*delta,ss,ssd)
3987           do k=1,3
3988             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3989           enddo
3990           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3991 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3992 c     &             esclocbi,ss,ssd
3993           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3994 C         write (iout,*) 'i=',i, escloci
3995         else
3996           call enesc(x,escloci,dersc,ddummy,.false.)
3997         endif
3998
3999         escloc=escloc+escloci
4000 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4001             write (iout,'(a6,i5,0pf7.3)')
4002      &     'escloc',i,escloci
4003
4004         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4005      &   wscloc*dersc(1)
4006         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4007         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4008     1   continue
4009       enddo
4010       return
4011       end
4012 C---------------------------------------------------------------------------
4013       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4014       implicit real*8 (a-h,o-z)
4015       include 'DIMENSIONS'
4016       include 'COMMON.GEO'
4017       include 'COMMON.LOCAL'
4018       include 'COMMON.IOUNITS'
4019       common /sccalc/ time11,time12,time112,theti,it,nlobit
4020       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4021       double precision contr(maxlob,-1:1)
4022       logical mixed
4023 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4024         escloc_i=0.0D0
4025         do j=1,3
4026           dersc(j)=0.0D0
4027           if (mixed) ddersc(j)=0.0d0
4028         enddo
4029         x3=x(3)
4030
4031 C Because of periodicity of the dependence of the SC energy in omega we have
4032 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4033 C To avoid underflows, first compute & store the exponents.
4034
4035         do iii=-1,1
4036
4037           x(3)=x3+iii*dwapi
4038
4039           do j=1,nlobit
4040             do k=1,3
4041               z(k)=x(k)-censc(k,j,it)
4042             enddo
4043             do k=1,3
4044               Axk=0.0D0
4045               do l=1,3
4046                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4047               enddo
4048               Ax(k,j,iii)=Axk
4049             enddo
4050             expfac=0.0D0
4051             do k=1,3
4052               expfac=expfac+Ax(k,j,iii)*z(k)
4053             enddo
4054             contr(j,iii)=expfac
4055           enddo ! j
4056
4057         enddo ! iii
4058
4059         x(3)=x3
4060 C As in the case of ebend, we want to avoid underflows in exponentiation and
4061 C subsequent NaNs and INFs in energy calculation.
4062 C Find the largest exponent
4063         emin=contr(1,-1)
4064         do iii=-1,1
4065           do j=1,nlobit
4066             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4067           enddo
4068         enddo
4069         emin=0.5D0*emin
4070 cd      print *,'it=',it,' emin=',emin
4071
4072 C Compute the contribution to SC energy and derivatives
4073         do iii=-1,1
4074
4075           do j=1,nlobit
4076             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4077 cd          print *,'j=',j,' expfac=',expfac
4078             escloc_i=escloc_i+expfac
4079             do k=1,3
4080               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4081             enddo
4082             if (mixed) then
4083               do k=1,3,2
4084                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4085      &            +gaussc(k,2,j,it))*expfac
4086               enddo
4087             endif
4088           enddo
4089
4090         enddo ! iii
4091
4092         dersc(1)=dersc(1)/cos(theti)**2
4093         ddersc(1)=ddersc(1)/cos(theti)**2
4094         ddersc(3)=ddersc(3)
4095
4096         escloci=-(dlog(escloc_i)-emin)
4097         do j=1,3
4098           dersc(j)=dersc(j)/escloc_i
4099         enddo
4100         if (mixed) then
4101           do j=1,3,2
4102             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4103           enddo
4104         endif
4105       return
4106       end
4107 C------------------------------------------------------------------------------
4108       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4109       implicit real*8 (a-h,o-z)
4110       include 'DIMENSIONS'
4111       include 'COMMON.GEO'
4112       include 'COMMON.LOCAL'
4113       include 'COMMON.IOUNITS'
4114       common /sccalc/ time11,time12,time112,theti,it,nlobit
4115       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4116       double precision contr(maxlob)
4117       logical mixed
4118
4119       escloc_i=0.0D0
4120
4121       do j=1,3
4122         dersc(j)=0.0D0
4123       enddo
4124
4125       do j=1,nlobit
4126         do k=1,2
4127           z(k)=x(k)-censc(k,j,it)
4128         enddo
4129         z(3)=dwapi
4130         do k=1,3
4131           Axk=0.0D0
4132           do l=1,3
4133             Axk=Axk+gaussc(l,k,j,it)*z(l)
4134           enddo
4135           Ax(k,j)=Axk
4136         enddo
4137         expfac=0.0D0
4138         do k=1,3
4139           expfac=expfac+Ax(k,j)*z(k)
4140         enddo
4141         contr(j)=expfac
4142       enddo ! j
4143
4144 C As in the case of ebend, we want to avoid underflows in exponentiation and
4145 C subsequent NaNs and INFs in energy calculation.
4146 C Find the largest exponent
4147       emin=contr(1)
4148       do j=1,nlobit
4149         if (emin.gt.contr(j)) emin=contr(j)
4150       enddo
4151       emin=0.5D0*emin
4152
4153 C Compute the contribution to SC energy and derivatives
4154
4155       dersc12=0.0d0
4156       do j=1,nlobit
4157         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4158         escloc_i=escloc_i+expfac
4159         do k=1,2
4160           dersc(k)=dersc(k)+Ax(k,j)*expfac
4161         enddo
4162         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4163      &            +gaussc(1,2,j,it))*expfac
4164         dersc(3)=0.0d0
4165       enddo
4166
4167       dersc(1)=dersc(1)/cos(theti)**2
4168       dersc12=dersc12/cos(theti)**2
4169       escloci=-(dlog(escloc_i)-emin)
4170       do j=1,2
4171         dersc(j)=dersc(j)/escloc_i
4172       enddo
4173       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4174       return
4175       end
4176 #else
4177 c----------------------------------------------------------------------------------
4178       subroutine esc(escloc)
4179 C Calculate the local energy of a side chain and its derivatives in the
4180 C corresponding virtual-bond valence angles THETA and the spherical angles
4181 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4182 C added by Urszula Kozlowska. 07/11/2007
4183 C
4184       implicit real*8 (a-h,o-z)
4185       include 'DIMENSIONS'
4186       include 'DIMENSIONS.ZSCOPT'
4187       include 'COMMON.GEO'
4188       include 'COMMON.LOCAL'
4189       include 'COMMON.VAR'
4190       include 'COMMON.SCROT'
4191       include 'COMMON.INTERACT'
4192       include 'COMMON.DERIV'
4193       include 'COMMON.CHAIN'
4194       include 'COMMON.IOUNITS'
4195       include 'COMMON.NAMES'
4196       include 'COMMON.FFIELD'
4197       include 'COMMON.CONTROL'
4198       include 'COMMON.VECTORS'
4199       double precision x_prime(3),y_prime(3),z_prime(3)
4200      &    , sumene,dsc_i,dp2_i,x(65),
4201      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4202      &    de_dxx,de_dyy,de_dzz,de_dt
4203       double precision s1_t,s1_6_t,s2_t,s2_6_t
4204       double precision
4205      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4206      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4207      & dt_dCi(3),dt_dCi1(3)
4208       common /sccalc/ time11,time12,time112,theti,it,nlobit
4209       delta=0.02d0*pi
4210       escloc=0.0D0
4211       do i=loc_start,loc_end
4212         if (itype(i).eq.ntyp1) cycle
4213         costtab(i+1) =dcos(theta(i+1))
4214         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4215         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4216         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4217         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4218         cosfac=dsqrt(cosfac2)
4219         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4220         sinfac=dsqrt(sinfac2)
4221         it=iabs(itype(i))
4222         if (it.eq.10) goto 1
4223 c
4224 C  Compute the axes of tghe local cartesian coordinates system; store in
4225 c   x_prime, y_prime and z_prime
4226 c
4227         do j=1,3
4228           x_prime(j) = 0.00
4229           y_prime(j) = 0.00
4230           z_prime(j) = 0.00
4231         enddo
4232 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4233 C     &   dc_norm(3,i+nres)
4234         do j = 1,3
4235           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4236           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4237         enddo
4238         do j = 1,3
4239           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4240         enddo
4241 c       write (2,*) "i",i
4242 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4243 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4244 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4245 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4246 c      & " xy",scalar(x_prime(1),y_prime(1)),
4247 c      & " xz",scalar(x_prime(1),z_prime(1)),
4248 c      & " yy",scalar(y_prime(1),y_prime(1)),
4249 c      & " yz",scalar(y_prime(1),z_prime(1)),
4250 c      & " zz",scalar(z_prime(1),z_prime(1))
4251 c
4252 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4253 C to local coordinate system. Store in xx, yy, zz.
4254 c
4255         xx=0.0d0
4256         yy=0.0d0
4257         zz=0.0d0
4258         do j = 1,3
4259           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4260           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4261           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4262         enddo
4263
4264         xxtab(i)=xx
4265         yytab(i)=yy
4266         zztab(i)=zz
4267 C
4268 C Compute the energy of the ith side cbain
4269 C
4270 c        write (2,*) "xx",xx," yy",yy," zz",zz
4271         it=iabs(itype(i))
4272         do j = 1,65
4273           x(j) = sc_parmin(j,it)
4274         enddo
4275 #ifdef CHECK_COORD
4276 Cc diagnostics - remove later
4277         xx1 = dcos(alph(2))
4278         yy1 = dsin(alph(2))*dcos(omeg(2))
4279         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4280         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4281      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4282      &    xx1,yy1,zz1
4283 C,"  --- ", xx_w,yy_w,zz_w
4284 c end diagnostics
4285 #endif
4286         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4287      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4288      &   + x(10)*yy*zz
4289         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4290      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4291      & + x(20)*yy*zz
4292         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4293      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4294      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4295      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4296      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4297      &  +x(40)*xx*yy*zz
4298         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4299      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4300      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4301      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4302      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4303      &  +x(60)*xx*yy*zz
4304         dsc_i   = 0.743d0+x(61)
4305         dp2_i   = 1.9d0+x(62)
4306         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4307      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4308         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4309      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4310         s1=(1+x(63))/(0.1d0 + dscp1)
4311         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4312         s2=(1+x(65))/(0.1d0 + dscp2)
4313         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4314         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4315      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4316 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4317 c     &   sumene4,
4318 c     &   dscp1,dscp2,sumene
4319 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4320         escloc = escloc + sumene
4321 c        write (2,*) "escloc",escloc
4322 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4323 c     &  zz,xx,yy
4324         if (.not. calc_grad) goto 1
4325 #ifdef DEBUG
4326 C
4327 C This section to check the numerical derivatives of the energy of ith side
4328 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4329 C #define DEBUG in the code to turn it on.
4330 C
4331         write (2,*) "sumene               =",sumene
4332         aincr=1.0d-7
4333         xxsave=xx
4334         xx=xx+aincr
4335         write (2,*) xx,yy,zz
4336         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4337         de_dxx_num=(sumenep-sumene)/aincr
4338         xx=xxsave
4339         write (2,*) "xx+ sumene from enesc=",sumenep
4340         yysave=yy
4341         yy=yy+aincr
4342         write (2,*) xx,yy,zz
4343         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4344         de_dyy_num=(sumenep-sumene)/aincr
4345         yy=yysave
4346         write (2,*) "yy+ sumene from enesc=",sumenep
4347         zzsave=zz
4348         zz=zz+aincr
4349         write (2,*) xx,yy,zz
4350         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4351         de_dzz_num=(sumenep-sumene)/aincr
4352         zz=zzsave
4353         write (2,*) "zz+ sumene from enesc=",sumenep
4354         costsave=cost2tab(i+1)
4355         sintsave=sint2tab(i+1)
4356         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4357         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4358         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4359         de_dt_num=(sumenep-sumene)/aincr
4360         write (2,*) " t+ sumene from enesc=",sumenep
4361         cost2tab(i+1)=costsave
4362         sint2tab(i+1)=sintsave
4363 C End of diagnostics section.
4364 #endif
4365 C
4366 C Compute the gradient of esc
4367 C
4368         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4369         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4370         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4371         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4372         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4373         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4374         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4375         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4376         pom1=(sumene3*sint2tab(i+1)+sumene1)
4377      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4378         pom2=(sumene4*cost2tab(i+1)+sumene2)
4379      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4380         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4381         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4382      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4383      &  +x(40)*yy*zz
4384         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4385         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4386      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4387      &  +x(60)*yy*zz
4388         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4389      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4390      &        +(pom1+pom2)*pom_dx
4391 #ifdef DEBUG
4392         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4393 #endif
4394 C
4395         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4396         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4397      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4398      &  +x(40)*xx*zz
4399         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4400         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4401      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4402      &  +x(59)*zz**2 +x(60)*xx*zz
4403         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4404      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4405      &        +(pom1-pom2)*pom_dy
4406 #ifdef DEBUG
4407         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4408 #endif
4409 C
4410         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4411      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4412      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4413      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4414      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4415      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4416      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4417      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4418 #ifdef DEBUG
4419         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4420 #endif
4421 C
4422         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4423      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4424      &  +pom1*pom_dt1+pom2*pom_dt2
4425 #ifdef DEBUG
4426         write(2,*), "de_dt = ", de_dt,de_dt_num
4427 #endif
4428 c
4429 C
4430        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4431        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4432        cosfac2xx=cosfac2*xx
4433        sinfac2yy=sinfac2*yy
4434        do k = 1,3
4435          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4436      &      vbld_inv(i+1)
4437          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4438      &      vbld_inv(i)
4439          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4440          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4441 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4442 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4443 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4444 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4445          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4446          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4447          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4448          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4449          dZZ_Ci1(k)=0.0d0
4450          dZZ_Ci(k)=0.0d0
4451          do j=1,3
4452            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4453      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4454            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4455      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4456          enddo
4457
4458          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4459          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4460          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4461 c
4462          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4463          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4464        enddo
4465
4466        do k=1,3
4467          dXX_Ctab(k,i)=dXX_Ci(k)
4468          dXX_C1tab(k,i)=dXX_Ci1(k)
4469          dYY_Ctab(k,i)=dYY_Ci(k)
4470          dYY_C1tab(k,i)=dYY_Ci1(k)
4471          dZZ_Ctab(k,i)=dZZ_Ci(k)
4472          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4473          dXX_XYZtab(k,i)=dXX_XYZ(k)
4474          dYY_XYZtab(k,i)=dYY_XYZ(k)
4475          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4476        enddo
4477
4478        do k = 1,3
4479 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4480 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4481 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4482 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4483 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4484 c     &    dt_dci(k)
4485 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4486 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4487          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4488      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4489          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4490      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4491          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4492      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4493        enddo
4494 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4495 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4496
4497 C to check gradient call subroutine check_grad
4498
4499     1 continue
4500       enddo
4501       return
4502       end
4503 #endif
4504 c------------------------------------------------------------------------------
4505       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4506 C
4507 C This procedure calculates two-body contact function g(rij) and its derivative:
4508 C
4509 C           eps0ij                                     !       x < -1
4510 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4511 C            0                                         !       x > 1
4512 C
4513 C where x=(rij-r0ij)/delta
4514 C
4515 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4516 C
4517       implicit none
4518       double precision rij,r0ij,eps0ij,fcont,fprimcont
4519       double precision x,x2,x4,delta
4520 c     delta=0.02D0*r0ij
4521 c      delta=0.2D0*r0ij
4522       x=(rij-r0ij)/delta
4523       if (x.lt.-1.0D0) then
4524         fcont=eps0ij
4525         fprimcont=0.0D0
4526       else if (x.le.1.0D0) then
4527         x2=x*x
4528         x4=x2*x2
4529         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4530         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4531       else
4532         fcont=0.0D0
4533         fprimcont=0.0D0
4534       endif
4535       return
4536       end
4537 c------------------------------------------------------------------------------
4538       subroutine splinthet(theti,delta,ss,ssder)
4539       implicit real*8 (a-h,o-z)
4540       include 'DIMENSIONS'
4541       include 'DIMENSIONS.ZSCOPT'
4542       include 'COMMON.VAR'
4543       include 'COMMON.GEO'
4544       thetup=pi-delta
4545       thetlow=delta
4546       if (theti.gt.pipol) then
4547         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4548       else
4549         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4550         ssder=-ssder
4551       endif
4552       return
4553       end
4554 c------------------------------------------------------------------------------
4555       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4556       implicit none
4557       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4558       double precision ksi,ksi2,ksi3,a1,a2,a3
4559       a1=fprim0*delta/(f1-f0)
4560       a2=3.0d0-2.0d0*a1
4561       a3=a1-2.0d0
4562       ksi=(x-x0)/delta
4563       ksi2=ksi*ksi
4564       ksi3=ksi2*ksi
4565       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4566       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4567       return
4568       end
4569 c------------------------------------------------------------------------------
4570       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4571       implicit none
4572       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4573       double precision ksi,ksi2,ksi3,a1,a2,a3
4574       ksi=(x-x0)/delta
4575       ksi2=ksi*ksi
4576       ksi3=ksi2*ksi
4577       a1=fprim0x*delta
4578       a2=3*(f1x-f0x)-2*fprim0x*delta
4579       a3=fprim0x*delta-2*(f1x-f0x)
4580       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4581       return
4582       end
4583 C-----------------------------------------------------------------------------
4584 #ifdef CRYST_TOR
4585 C-----------------------------------------------------------------------------
4586       subroutine etor(etors,edihcnstr,fact)
4587       implicit real*8 (a-h,o-z)
4588       include 'DIMENSIONS'
4589       include 'DIMENSIONS.ZSCOPT'
4590       include 'COMMON.VAR'
4591       include 'COMMON.GEO'
4592       include 'COMMON.LOCAL'
4593       include 'COMMON.TORSION'
4594       include 'COMMON.INTERACT'
4595       include 'COMMON.DERIV'
4596       include 'COMMON.CHAIN'
4597       include 'COMMON.NAMES'
4598       include 'COMMON.IOUNITS'
4599       include 'COMMON.FFIELD'
4600       include 'COMMON.TORCNSTR'
4601       logical lprn
4602 C Set lprn=.true. for debugging
4603       lprn=.false.
4604 c      lprn=.true.
4605       etors=0.0D0
4606       do i=iphi_start,iphi_end
4607         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4608      &      .or. itype(i).eq.ntyp1) cycle
4609         itori=itortyp(itype(i-2))
4610         itori1=itortyp(itype(i-1))
4611         phii=phi(i)
4612         gloci=0.0D0
4613 C Proline-Proline pair is a special case...
4614         if (itori.eq.3 .and. itori1.eq.3) then
4615           if (phii.gt.-dwapi3) then
4616             cosphi=dcos(3*phii)
4617             fac=1.0D0/(1.0D0-cosphi)
4618             etorsi=v1(1,3,3)*fac
4619             etorsi=etorsi+etorsi
4620             etors=etors+etorsi-v1(1,3,3)
4621             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4622           endif
4623           do j=1,3
4624             v1ij=v1(j+1,itori,itori1)
4625             v2ij=v2(j+1,itori,itori1)
4626             cosphi=dcos(j*phii)
4627             sinphi=dsin(j*phii)
4628             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4629             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4630           enddo
4631         else
4632           do j=1,nterm_old
4633             v1ij=v1(j,itori,itori1)
4634             v2ij=v2(j,itori,itori1)
4635             cosphi=dcos(j*phii)
4636             sinphi=dsin(j*phii)
4637             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4638             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4639           enddo
4640         endif
4641         if (lprn)
4642      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4643      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4644      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4645         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4646 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4647       enddo
4648 ! 6/20/98 - dihedral angle constraints
4649       edihcnstr=0.0d0
4650       do i=1,ndih_constr
4651         itori=idih_constr(i)
4652         phii=phi(itori)
4653         difi=phii-phi0(i)
4654         if (difi.gt.drange(i)) then
4655           difi=difi-drange(i)
4656           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4657           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4658         else if (difi.lt.-drange(i)) then
4659           difi=difi+drange(i)
4660           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4661           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4662         endif
4663 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4664 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4665       enddo
4666 !      write (iout,*) 'edihcnstr',edihcnstr
4667       return
4668       end
4669 c------------------------------------------------------------------------------
4670 #else
4671       subroutine etor(etors,edihcnstr,fact)
4672       implicit real*8 (a-h,o-z)
4673       include 'DIMENSIONS'
4674       include 'DIMENSIONS.ZSCOPT'
4675       include 'COMMON.VAR'
4676       include 'COMMON.GEO'
4677       include 'COMMON.LOCAL'
4678       include 'COMMON.TORSION'
4679       include 'COMMON.INTERACT'
4680       include 'COMMON.DERIV'
4681       include 'COMMON.CHAIN'
4682       include 'COMMON.NAMES'
4683       include 'COMMON.IOUNITS'
4684       include 'COMMON.FFIELD'
4685       include 'COMMON.TORCNSTR'
4686       logical lprn
4687 C Set lprn=.true. for debugging
4688       lprn=.false.
4689 c      lprn=.true.
4690       etors=0.0D0
4691       do i=iphi_start,iphi_end
4692         if (i.le.2) cycle
4693         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4694      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
4695 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4696 C     &       .or. itype(i).eq.ntyp1) cycle
4697         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4698          if (iabs(itype(i)).eq.20) then
4699          iblock=2
4700          else
4701          iblock=1
4702          endif
4703         itori=itortyp(itype(i-2))
4704         itori1=itortyp(itype(i-1))
4705         phii=phi(i)
4706         gloci=0.0D0
4707 C Regular cosine and sine terms
4708         do j=1,nterm(itori,itori1,iblock)
4709           v1ij=v1(j,itori,itori1,iblock)
4710           v2ij=v2(j,itori,itori1,iblock)
4711           cosphi=dcos(j*phii)
4712           sinphi=dsin(j*phii)
4713           etors=etors+v1ij*cosphi+v2ij*sinphi
4714           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4715         enddo
4716 C Lorentz terms
4717 C                         v1
4718 C  E = SUM ----------------------------------- - v1
4719 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4720 C
4721         cosphi=dcos(0.5d0*phii)
4722         sinphi=dsin(0.5d0*phii)
4723         do j=1,nlor(itori,itori1,iblock)
4724           vl1ij=vlor1(j,itori,itori1)
4725           vl2ij=vlor2(j,itori,itori1)
4726           vl3ij=vlor3(j,itori,itori1)
4727           pom=vl2ij*cosphi+vl3ij*sinphi
4728           pom1=1.0d0/(pom*pom+1.0d0)
4729           etors=etors+vl1ij*pom1
4730 c          if (energy_dec) etors_ii=etors_ii+
4731 c     &                vl1ij*pom1
4732           pom=-pom*pom1*pom1
4733           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4734         enddo
4735 C Subtract the constant term
4736         etors=etors-v0(itori,itori1,iblock)
4737         if (lprn)
4738      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4739      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4740      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4741         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4742 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4743  1215   continue
4744       enddo
4745 ! 6/20/98 - dihedral angle constraints
4746       edihcnstr=0.0d0
4747       do i=1,ndih_constr
4748         itori=idih_constr(i)
4749         phii=phi(itori)
4750         difi=pinorm(phii-phi0(i))
4751         edihi=0.0d0
4752         if (difi.gt.drange(i)) then
4753           difi=difi-drange(i)
4754           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4755           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4756           edihi=0.25d0*ftors*difi**4
4757         else if (difi.lt.-drange(i)) then
4758           difi=difi+drange(i)
4759           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4760           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4761           edihi=0.25d0*ftors*difi**4
4762         else
4763           difi=0.0d0
4764         endif
4765 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4766 c     &    drange(i),edihi
4767 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4768 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4769       enddo
4770 !      write (iout,*) 'edihcnstr',edihcnstr
4771       return
4772       end
4773 c----------------------------------------------------------------------------
4774       subroutine etor_d(etors_d,fact2)
4775 C 6/23/01 Compute double torsional energy
4776       implicit real*8 (a-h,o-z)
4777       include 'DIMENSIONS'
4778       include 'DIMENSIONS.ZSCOPT'
4779       include 'COMMON.VAR'
4780       include 'COMMON.GEO'
4781       include 'COMMON.LOCAL'
4782       include 'COMMON.TORSION'
4783       include 'COMMON.INTERACT'
4784       include 'COMMON.DERIV'
4785       include 'COMMON.CHAIN'
4786       include 'COMMON.NAMES'
4787       include 'COMMON.IOUNITS'
4788       include 'COMMON.FFIELD'
4789       include 'COMMON.TORCNSTR'
4790       logical lprn
4791 C Set lprn=.true. for debugging
4792       lprn=.false.
4793 c     lprn=.true.
4794       etors_d=0.0D0
4795       do i=iphi_start,iphi_end-1
4796         if (i.le.3) cycle
4797 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4798 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4799          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
4800      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
4801      &  (itype(i+1).eq.ntyp1)) cycle
4802         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4803      &     goto 1215
4804         itori=itortyp(itype(i-2))
4805         itori1=itortyp(itype(i-1))
4806         itori2=itortyp(itype(i))
4807         phii=phi(i)
4808         phii1=phi(i+1)
4809         gloci1=0.0D0
4810         gloci2=0.0D0
4811         iblock=1
4812         if (iabs(itype(i+1)).eq.20) iblock=2
4813 C Regular cosine and sine terms
4814         do j=1,ntermd_1(itori,itori1,itori2,iblock)
4815           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4816           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4817           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4818           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4819           cosphi1=dcos(j*phii)
4820           sinphi1=dsin(j*phii)
4821           cosphi2=dcos(j*phii1)
4822           sinphi2=dsin(j*phii1)
4823           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4824      &     v2cij*cosphi2+v2sij*sinphi2
4825           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4826           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4827         enddo
4828         do k=2,ntermd_2(itori,itori1,itori2,iblock)
4829           do l=1,k-1
4830             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
4831             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
4832             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
4833             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
4834             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4835             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4836             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4837             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4838             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4839      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4840             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4841      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4842             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4843      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4844           enddo
4845         enddo
4846         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4847         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4848  1215   continue
4849       enddo
4850       return
4851       end
4852 #endif
4853 c------------------------------------------------------------------------------
4854       subroutine eback_sc_corr(esccor)
4855 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4856 c        conformational states; temporarily implemented as differences
4857 c        between UNRES torsional potentials (dependent on three types of
4858 c        residues) and the torsional potentials dependent on all 20 types
4859 c        of residues computed from AM1 energy surfaces of terminally-blocked
4860 c        amino-acid residues.
4861       implicit real*8 (a-h,o-z)
4862       include 'DIMENSIONS'
4863       include 'DIMENSIONS.ZSCOPT'
4864       include 'COMMON.VAR'
4865       include 'COMMON.GEO'
4866       include 'COMMON.LOCAL'
4867       include 'COMMON.TORSION'
4868       include 'COMMON.SCCOR'
4869       include 'COMMON.INTERACT'
4870       include 'COMMON.DERIV'
4871       include 'COMMON.CHAIN'
4872       include 'COMMON.NAMES'
4873       include 'COMMON.IOUNITS'
4874       include 'COMMON.FFIELD'
4875       include 'COMMON.CONTROL'
4876       logical lprn
4877 C Set lprn=.true. for debugging
4878       lprn=.false.
4879 c      lprn=.true.
4880 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4881       esccor=0.0D0
4882       do i=itau_start,itau_end
4883         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
4884         esccor_ii=0.0D0
4885         isccori=isccortyp(itype(i-2))
4886         isccori1=isccortyp(itype(i-1))
4887         phii=phi(i)
4888         do intertyp=1,3 !intertyp
4889 cc Added 09 May 2012 (Adasko)
4890 cc  Intertyp means interaction type of backbone mainchain correlation:
4891 c   1 = SC...Ca...Ca...Ca
4892 c   2 = Ca...Ca...Ca...SC
4893 c   3 = SC...Ca...Ca...SCi
4894         gloci=0.0D0
4895         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4896      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4897      &      (itype(i-1).eq.ntyp1)))
4898      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4899      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4900      &     .or.(itype(i).eq.ntyp1)))
4901      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4902      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4903      &      (itype(i-3).eq.ntyp1)))) cycle
4904         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
4905         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
4906      & cycle
4907        do j=1,nterm_sccor(isccori,isccori1)
4908           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4909           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4910           cosphi=dcos(j*tauangle(intertyp,i))
4911           sinphi=dsin(j*tauangle(intertyp,i))
4912            esccor=esccor+v1ij*cosphi+v2ij*sinphi
4913            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4914          enddo
4915 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
4916 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
4917 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4918         if (lprn)
4919      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4920      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4921      &  (v1sccor(j,1,itori,itori1),j=1,6)
4922      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
4923 c        gsccor_loc(i-3)=gloci
4924        enddo !intertyp
4925       enddo
4926       return
4927       end
4928 c------------------------------------------------------------------------------
4929       subroutine multibody(ecorr)
4930 C This subroutine calculates multi-body contributions to energy following
4931 C the idea of Skolnick et al. If side chains I and J make a contact and
4932 C at the same time side chains I+1 and J+1 make a contact, an extra
4933 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4934       implicit real*8 (a-h,o-z)
4935       include 'DIMENSIONS'
4936       include 'COMMON.IOUNITS'
4937       include 'COMMON.DERIV'
4938       include 'COMMON.INTERACT'
4939       include 'COMMON.CONTACTS'
4940       double precision gx(3),gx1(3)
4941       logical lprn
4942
4943 C Set lprn=.true. for debugging
4944       lprn=.false.
4945
4946       if (lprn) then
4947         write (iout,'(a)') 'Contact function values:'
4948         do i=nnt,nct-2
4949           write (iout,'(i2,20(1x,i2,f10.5))')
4950      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4951         enddo
4952       endif
4953       ecorr=0.0D0
4954       do i=nnt,nct
4955         do j=1,3
4956           gradcorr(j,i)=0.0D0
4957           gradxorr(j,i)=0.0D0
4958         enddo
4959       enddo
4960       do i=nnt,nct-2
4961
4962         DO ISHIFT = 3,4
4963
4964         i1=i+ishift
4965         num_conti=num_cont(i)
4966         num_conti1=num_cont(i1)
4967         do jj=1,num_conti
4968           j=jcont(jj,i)
4969           do kk=1,num_conti1
4970             j1=jcont(kk,i1)
4971             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4972 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4973 cd   &                   ' ishift=',ishift
4974 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4975 C The system gains extra energy.
4976               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4977             endif   ! j1==j+-ishift
4978           enddo     ! kk
4979         enddo       ! jj
4980
4981         ENDDO ! ISHIFT
4982
4983       enddo         ! i
4984       return
4985       end
4986 c------------------------------------------------------------------------------
4987       double precision function esccorr(i,j,k,l,jj,kk)
4988       implicit real*8 (a-h,o-z)
4989       include 'DIMENSIONS'
4990       include 'COMMON.IOUNITS'
4991       include 'COMMON.DERIV'
4992       include 'COMMON.INTERACT'
4993       include 'COMMON.CONTACTS'
4994       double precision gx(3),gx1(3)
4995       logical lprn
4996       lprn=.false.
4997       eij=facont(jj,i)
4998       ekl=facont(kk,k)
4999 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5000 C Calculate the multi-body contribution to energy.
5001 C Calculate multi-body contributions to the gradient.
5002 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5003 cd   & k,l,(gacont(m,kk,k),m=1,3)
5004       do m=1,3
5005         gx(m) =ekl*gacont(m,jj,i)
5006         gx1(m)=eij*gacont(m,kk,k)
5007         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5008         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5009         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5010         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5011       enddo
5012       do m=i,j-1
5013         do ll=1,3
5014           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5015         enddo
5016       enddo
5017       do m=k,l-1
5018         do ll=1,3
5019           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5020         enddo
5021       enddo
5022       esccorr=-eij*ekl
5023       return
5024       end
5025 c------------------------------------------------------------------------------
5026 #ifdef MPL
5027       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5028       implicit real*8 (a-h,o-z)
5029       include 'DIMENSIONS'
5030       integer dimen1,dimen2,atom,indx
5031       double precision buffer(dimen1,dimen2)
5032       double precision zapas
5033       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5034      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5035      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5036       num_kont=num_cont_hb(atom)
5037       do i=1,num_kont
5038         do k=1,7
5039           do j=1,3
5040             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5041           enddo ! j
5042         enddo ! k
5043         buffer(i,indx+22)=facont_hb(i,atom)
5044         buffer(i,indx+23)=ees0p(i,atom)
5045         buffer(i,indx+24)=ees0m(i,atom)
5046         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5047       enddo ! i
5048       buffer(1,indx+26)=dfloat(num_kont)
5049       return
5050       end
5051 c------------------------------------------------------------------------------
5052       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5053       implicit real*8 (a-h,o-z)
5054       include 'DIMENSIONS'
5055       integer dimen1,dimen2,atom,indx
5056       double precision buffer(dimen1,dimen2)
5057       double precision zapas
5058       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5059      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5060      &         ees0m(ntyp,maxres),
5061      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5062       num_kont=buffer(1,indx+26)
5063       num_kont_old=num_cont_hb(atom)
5064       num_cont_hb(atom)=num_kont+num_kont_old
5065       do i=1,num_kont
5066         ii=i+num_kont_old
5067         do k=1,7
5068           do j=1,3
5069             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5070           enddo ! j
5071         enddo ! k
5072         facont_hb(ii,atom)=buffer(i,indx+22)
5073         ees0p(ii,atom)=buffer(i,indx+23)
5074         ees0m(ii,atom)=buffer(i,indx+24)
5075         jcont_hb(ii,atom)=buffer(i,indx+25)
5076       enddo ! i
5077       return
5078       end
5079 c------------------------------------------------------------------------------
5080 #endif
5081       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5082 C This subroutine calculates multi-body contributions to hydrogen-bonding
5083       implicit real*8 (a-h,o-z)
5084       include 'DIMENSIONS'
5085       include 'DIMENSIONS.ZSCOPT'
5086       include 'COMMON.IOUNITS'
5087 #ifdef MPL
5088       include 'COMMON.INFO'
5089 #endif
5090       include 'COMMON.FFIELD'
5091       include 'COMMON.DERIV'
5092       include 'COMMON.INTERACT'
5093       include 'COMMON.CONTACTS'
5094 #ifdef MPL
5095       parameter (max_cont=maxconts)
5096       parameter (max_dim=2*(8*3+2))
5097       parameter (msglen1=max_cont*max_dim*4)
5098       parameter (msglen2=2*msglen1)
5099       integer source,CorrelType,CorrelID,Error
5100       double precision buffer(max_cont,max_dim)
5101 #endif
5102       double precision gx(3),gx1(3)
5103       logical lprn,ldone
5104
5105 C Set lprn=.true. for debugging
5106       lprn=.false.
5107 #ifdef MPL
5108       n_corr=0
5109       n_corr1=0
5110       if (fgProcs.le.1) goto 30
5111       if (lprn) then
5112         write (iout,'(a)') 'Contact function values:'
5113         do i=nnt,nct-2
5114           write (iout,'(2i3,50(1x,i2,f5.2))')
5115      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5116      &    j=1,num_cont_hb(i))
5117         enddo
5118       endif
5119 C Caution! Following code assumes that electrostatic interactions concerning
5120 C a given atom are split among at most two processors!
5121       CorrelType=477
5122       CorrelID=MyID+1
5123       ldone=.false.
5124       do i=1,max_cont
5125         do j=1,max_dim
5126           buffer(i,j)=0.0D0
5127         enddo
5128       enddo
5129       mm=mod(MyRank,2)
5130 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5131       if (mm) 20,20,10
5132    10 continue
5133 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5134       if (MyRank.gt.0) then
5135 C Send correlation contributions to the preceding processor
5136         msglen=msglen1
5137         nn=num_cont_hb(iatel_s)
5138         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5139 cd      write (iout,*) 'The BUFFER array:'
5140 cd      do i=1,nn
5141 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5142 cd      enddo
5143         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5144           msglen=msglen2
5145             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5146 C Clear the contacts of the atom passed to the neighboring processor
5147         nn=num_cont_hb(iatel_s+1)
5148 cd      do i=1,nn
5149 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5150 cd      enddo
5151             num_cont_hb(iatel_s)=0
5152         endif
5153 cd      write (iout,*) 'Processor ',MyID,MyRank,
5154 cd   & ' is sending correlation contribution to processor',MyID-1,
5155 cd   & ' msglen=',msglen
5156 cd      write (*,*) 'Processor ',MyID,MyRank,
5157 cd   & ' is sending correlation contribution to processor',MyID-1,
5158 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5159         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5160 cd      write (iout,*) 'Processor ',MyID,
5161 cd   & ' has sent correlation contribution to processor',MyID-1,
5162 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5163 cd      write (*,*) 'Processor ',MyID,
5164 cd   & ' has sent correlation contribution to processor',MyID-1,
5165 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5166         msglen=msglen1
5167       endif ! (MyRank.gt.0)
5168       if (ldone) goto 30
5169       ldone=.true.
5170    20 continue
5171 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5172       if (MyRank.lt.fgProcs-1) then
5173 C Receive correlation contributions from the next processor
5174         msglen=msglen1
5175         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5176 cd      write (iout,*) 'Processor',MyID,
5177 cd   & ' is receiving correlation contribution from processor',MyID+1,
5178 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5179 cd      write (*,*) 'Processor',MyID,
5180 cd   & ' is receiving correlation contribution from processor',MyID+1,
5181 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5182         nbytes=-1
5183         do while (nbytes.le.0)
5184           call mp_probe(MyID+1,CorrelType,nbytes)
5185         enddo
5186 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5187         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5188 cd      write (iout,*) 'Processor',MyID,
5189 cd   & ' has received correlation contribution from processor',MyID+1,
5190 cd   & ' msglen=',msglen,' nbytes=',nbytes
5191 cd      write (iout,*) 'The received BUFFER array:'
5192 cd      do i=1,max_cont
5193 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5194 cd      enddo
5195         if (msglen.eq.msglen1) then
5196           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5197         else if (msglen.eq.msglen2)  then
5198           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5199           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5200         else
5201           write (iout,*)
5202      & 'ERROR!!!! message length changed while processing correlations.'
5203           write (*,*)
5204      & 'ERROR!!!! message length changed while processing correlations.'
5205           call mp_stopall(Error)
5206         endif ! msglen.eq.msglen1
5207       endif ! MyRank.lt.fgProcs-1
5208       if (ldone) goto 30
5209       ldone=.true.
5210       goto 10
5211    30 continue
5212 #endif
5213       if (lprn) then
5214         write (iout,'(a)') 'Contact function values:'
5215         do i=nnt,nct-2
5216           write (iout,'(2i3,50(1x,i2,f5.2))')
5217      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5218      &    j=1,num_cont_hb(i))
5219         enddo
5220       endif
5221       ecorr=0.0D0
5222 C Remove the loop below after debugging !!!
5223       do i=nnt,nct
5224         do j=1,3
5225           gradcorr(j,i)=0.0D0
5226           gradxorr(j,i)=0.0D0
5227         enddo
5228       enddo
5229 C Calculate the local-electrostatic correlation terms
5230       do i=iatel_s,iatel_e+1
5231         i1=i+1
5232         num_conti=num_cont_hb(i)
5233         num_conti1=num_cont_hb(i+1)
5234         do jj=1,num_conti
5235           j=jcont_hb(jj,i)
5236           do kk=1,num_conti1
5237             j1=jcont_hb(kk,i1)
5238 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5239 c     &         ' jj=',jj,' kk=',kk
5240             if (j1.eq.j+1 .or. j1.eq.j-1) then
5241 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5242 C The system gains extra energy.
5243               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5244               n_corr=n_corr+1
5245             else if (j1.eq.j) then
5246 C Contacts I-J and I-(J+1) occur simultaneously.
5247 C The system loses extra energy.
5248 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5249             endif
5250           enddo ! kk
5251           do kk=1,num_conti
5252             j1=jcont_hb(kk,i)
5253 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5254 c    &         ' jj=',jj,' kk=',kk
5255             if (j1.eq.j+1) then
5256 C Contacts I-J and (I+1)-J occur simultaneously.
5257 C The system loses extra energy.
5258 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5259             endif ! j1==j+1
5260           enddo ! kk
5261         enddo ! jj
5262       enddo ! i
5263       return
5264       end
5265 c------------------------------------------------------------------------------
5266       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5267      &  n_corr1)
5268 C This subroutine calculates multi-body contributions to hydrogen-bonding
5269       implicit real*8 (a-h,o-z)
5270       include 'DIMENSIONS'
5271       include 'DIMENSIONS.ZSCOPT'
5272       include 'COMMON.IOUNITS'
5273 #ifdef MPL
5274       include 'COMMON.INFO'
5275 #endif
5276       include 'COMMON.FFIELD'
5277       include 'COMMON.DERIV'
5278       include 'COMMON.INTERACT'
5279       include 'COMMON.CONTACTS'
5280 #ifdef MPL
5281       parameter (max_cont=maxconts)
5282       parameter (max_dim=2*(8*3+2))
5283       parameter (msglen1=max_cont*max_dim*4)
5284       parameter (msglen2=2*msglen1)
5285       integer source,CorrelType,CorrelID,Error
5286       double precision buffer(max_cont,max_dim)
5287 #endif
5288       double precision gx(3),gx1(3)
5289       logical lprn,ldone
5290
5291 C Set lprn=.true. for debugging
5292       lprn=.false.
5293       eturn6=0.0d0
5294 #ifdef MPL
5295       n_corr=0
5296       n_corr1=0
5297       if (fgProcs.le.1) goto 30
5298       if (lprn) then
5299         write (iout,'(a)') 'Contact function values:'
5300         do i=nnt,nct-2
5301           write (iout,'(2i3,50(1x,i2,f5.2))')
5302      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5303      &    j=1,num_cont_hb(i))
5304         enddo
5305       endif
5306 C Caution! Following code assumes that electrostatic interactions concerning
5307 C a given atom are split among at most two processors!
5308       CorrelType=477
5309       CorrelID=MyID+1
5310       ldone=.false.
5311       do i=1,max_cont
5312         do j=1,max_dim
5313           buffer(i,j)=0.0D0
5314         enddo
5315       enddo
5316       mm=mod(MyRank,2)
5317 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5318       if (mm) 20,20,10
5319    10 continue
5320 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5321       if (MyRank.gt.0) then
5322 C Send correlation contributions to the preceding processor
5323         msglen=msglen1
5324         nn=num_cont_hb(iatel_s)
5325         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5326 cd      write (iout,*) 'The BUFFER array:'
5327 cd      do i=1,nn
5328 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5329 cd      enddo
5330         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5331           msglen=msglen2
5332             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5333 C Clear the contacts of the atom passed to the neighboring processor
5334         nn=num_cont_hb(iatel_s+1)
5335 cd      do i=1,nn
5336 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5337 cd      enddo
5338             num_cont_hb(iatel_s)=0
5339         endif
5340 cd      write (iout,*) 'Processor ',MyID,MyRank,
5341 cd   & ' is sending correlation contribution to processor',MyID-1,
5342 cd   & ' msglen=',msglen
5343 cd      write (*,*) 'Processor ',MyID,MyRank,
5344 cd   & ' is sending correlation contribution to processor',MyID-1,
5345 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5346         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5347 cd      write (iout,*) 'Processor ',MyID,
5348 cd   & ' has sent correlation contribution to processor',MyID-1,
5349 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5350 cd      write (*,*) 'Processor ',MyID,
5351 cd   & ' has sent correlation contribution to processor',MyID-1,
5352 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5353         msglen=msglen1
5354       endif ! (MyRank.gt.0)
5355       if (ldone) goto 30
5356       ldone=.true.
5357    20 continue
5358 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5359       if (MyRank.lt.fgProcs-1) then
5360 C Receive correlation contributions from the next processor
5361         msglen=msglen1
5362         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5363 cd      write (iout,*) 'Processor',MyID,
5364 cd   & ' is receiving correlation contribution from processor',MyID+1,
5365 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5366 cd      write (*,*) 'Processor',MyID,
5367 cd   & ' is receiving correlation contribution from processor',MyID+1,
5368 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5369         nbytes=-1
5370         do while (nbytes.le.0)
5371           call mp_probe(MyID+1,CorrelType,nbytes)
5372         enddo
5373 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5374         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5375 cd      write (iout,*) 'Processor',MyID,
5376 cd   & ' has received correlation contribution from processor',MyID+1,
5377 cd   & ' msglen=',msglen,' nbytes=',nbytes
5378 cd      write (iout,*) 'The received BUFFER array:'
5379 cd      do i=1,max_cont
5380 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5381 cd      enddo
5382         if (msglen.eq.msglen1) then
5383           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5384         else if (msglen.eq.msglen2)  then
5385           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5386           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5387         else
5388           write (iout,*)
5389      & 'ERROR!!!! message length changed while processing correlations.'
5390           write (*,*)
5391      & 'ERROR!!!! message length changed while processing correlations.'
5392           call mp_stopall(Error)
5393         endif ! msglen.eq.msglen1
5394       endif ! MyRank.lt.fgProcs-1
5395       if (ldone) goto 30
5396       ldone=.true.
5397       goto 10
5398    30 continue
5399 #endif
5400       if (lprn) then
5401         write (iout,'(a)') 'Contact function values:'
5402         do i=nnt,nct-2
5403           write (iout,'(2i3,50(1x,i2,f5.2))')
5404      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5405      &    j=1,num_cont_hb(i))
5406         enddo
5407       endif
5408       ecorr=0.0D0
5409       ecorr5=0.0d0
5410       ecorr6=0.0d0
5411 C Remove the loop below after debugging !!!
5412       do i=nnt,nct
5413         do j=1,3
5414           gradcorr(j,i)=0.0D0
5415           gradxorr(j,i)=0.0D0
5416         enddo
5417       enddo
5418 C Calculate the dipole-dipole interaction energies
5419       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5420       do i=iatel_s,iatel_e+1
5421         num_conti=num_cont_hb(i)
5422         do jj=1,num_conti
5423           j=jcont_hb(jj,i)
5424           call dipole(i,j,jj)
5425         enddo
5426       enddo
5427       endif
5428 C Calculate the local-electrostatic correlation terms
5429       do i=iatel_s,iatel_e+1
5430         i1=i+1
5431         num_conti=num_cont_hb(i)
5432         num_conti1=num_cont_hb(i+1)
5433         do jj=1,num_conti
5434           j=jcont_hb(jj,i)
5435           do kk=1,num_conti1
5436             j1=jcont_hb(kk,i1)
5437 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5438 c     &         ' jj=',jj,' kk=',kk
5439             if (j1.eq.j+1 .or. j1.eq.j-1) then
5440 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5441 C The system gains extra energy.
5442               n_corr=n_corr+1
5443               sqd1=dsqrt(d_cont(jj,i))
5444               sqd2=dsqrt(d_cont(kk,i1))
5445               sred_geom = sqd1*sqd2
5446               IF (sred_geom.lt.cutoff_corr) THEN
5447                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5448      &            ekont,fprimcont)
5449 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5450 c     &         ' jj=',jj,' kk=',kk
5451                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5452                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5453                 do l=1,3
5454                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5455                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5456                 enddo
5457                 n_corr1=n_corr1+1
5458 cd               write (iout,*) 'sred_geom=',sred_geom,
5459 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5460                 call calc_eello(i,j,i+1,j1,jj,kk)
5461                 if (wcorr4.gt.0.0d0)
5462      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5463                 if (wcorr5.gt.0.0d0)
5464      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5465 c                print *,"wcorr5",ecorr5
5466 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5467 cd                write(2,*)'ijkl',i,j,i+1,j1
5468                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5469      &               .or. wturn6.eq.0.0d0))then
5470 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5471                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5472 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5473 cd     &            'ecorr6=',ecorr6
5474 cd                write (iout,'(4e15.5)') sred_geom,
5475 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5476 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5477 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5478                 else if (wturn6.gt.0.0d0
5479      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5480 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5481                   eturn6=eturn6+eello_turn6(i,jj,kk)
5482 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5483                 endif
5484               ENDIF
5485 1111          continue
5486             else if (j1.eq.j) then
5487 C Contacts I-J and I-(J+1) occur simultaneously.
5488 C The system loses extra energy.
5489 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5490             endif
5491           enddo ! kk
5492           do kk=1,num_conti
5493             j1=jcont_hb(kk,i)
5494 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5495 c    &         ' jj=',jj,' kk=',kk
5496             if (j1.eq.j+1) then
5497 C Contacts I-J and (I+1)-J occur simultaneously.
5498 C The system loses extra energy.
5499 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5500             endif ! j1==j+1
5501           enddo ! kk
5502         enddo ! jj
5503       enddo ! i
5504       return
5505       end
5506 c------------------------------------------------------------------------------
5507       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5508       implicit real*8 (a-h,o-z)
5509       include 'DIMENSIONS'
5510       include 'COMMON.IOUNITS'
5511       include 'COMMON.DERIV'
5512       include 'COMMON.INTERACT'
5513       include 'COMMON.CONTACTS'
5514       double precision gx(3),gx1(3)
5515       logical lprn
5516       lprn=.false.
5517       eij=facont_hb(jj,i)
5518       ekl=facont_hb(kk,k)
5519       ees0pij=ees0p(jj,i)
5520       ees0pkl=ees0p(kk,k)
5521       ees0mij=ees0m(jj,i)
5522       ees0mkl=ees0m(kk,k)
5523       ekont=eij*ekl
5524       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5525 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5526 C Following 4 lines for diagnostics.
5527 cd    ees0pkl=0.0D0
5528 cd    ees0pij=1.0D0
5529 cd    ees0mkl=0.0D0
5530 cd    ees0mij=1.0D0
5531 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5532 c    &   ' and',k,l
5533 c     write (iout,*)'Contacts have occurred for peptide groups',
5534 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5535 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5536 C Calculate the multi-body contribution to energy.
5537       ecorr=ecorr+ekont*ees
5538       if (calc_grad) then
5539 C Calculate multi-body contributions to the gradient.
5540       do ll=1,3
5541         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5542         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5543      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5544      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5545         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5546      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5547      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5548         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5549         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5550      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5551      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5552         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5553      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5554      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5555       enddo
5556       do m=i+1,j-1
5557         do ll=1,3
5558           gradcorr(ll,m)=gradcorr(ll,m)+
5559      &     ees*ekl*gacont_hbr(ll,jj,i)-
5560      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5561      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5562         enddo
5563       enddo
5564       do m=k+1,l-1
5565         do ll=1,3
5566           gradcorr(ll,m)=gradcorr(ll,m)+
5567      &     ees*eij*gacont_hbr(ll,kk,k)-
5568      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5569      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5570         enddo
5571       enddo
5572       endif
5573       ehbcorr=ekont*ees
5574       return
5575       end
5576 C---------------------------------------------------------------------------
5577       subroutine dipole(i,j,jj)
5578       implicit real*8 (a-h,o-z)
5579       include 'DIMENSIONS'
5580       include 'DIMENSIONS.ZSCOPT'
5581       include 'COMMON.IOUNITS'
5582       include 'COMMON.CHAIN'
5583       include 'COMMON.FFIELD'
5584       include 'COMMON.DERIV'
5585       include 'COMMON.INTERACT'
5586       include 'COMMON.CONTACTS'
5587       include 'COMMON.TORSION'
5588       include 'COMMON.VAR'
5589       include 'COMMON.GEO'
5590       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5591      &  auxmat(2,2)
5592       iti1 = itortyp(itype(i+1))
5593       if (j.lt.nres-1) then
5594         if (itype(j).le.ntyp) then
5595           itj1 = itortyp(itype(j+1))
5596         else
5597           itj=ntortyp+1
5598         endif
5599       else
5600         itj1=ntortyp+1
5601       endif
5602       do iii=1,2
5603         dipi(iii,1)=Ub2(iii,i)
5604         dipderi(iii)=Ub2der(iii,i)
5605         dipi(iii,2)=b1(iii,iti1)
5606         dipj(iii,1)=Ub2(iii,j)
5607         dipderj(iii)=Ub2der(iii,j)
5608         dipj(iii,2)=b1(iii,itj1)
5609       enddo
5610       kkk=0
5611       do iii=1,2
5612         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5613         do jjj=1,2
5614           kkk=kkk+1
5615           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5616         enddo
5617       enddo
5618       if (.not.calc_grad) return
5619       do kkk=1,5
5620         do lll=1,3
5621           mmm=0
5622           do iii=1,2
5623             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5624      &        auxvec(1))
5625             do jjj=1,2
5626               mmm=mmm+1
5627               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5628             enddo
5629           enddo
5630         enddo
5631       enddo
5632       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5633       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5634       do iii=1,2
5635         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5636       enddo
5637       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5638       do iii=1,2
5639         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5640       enddo
5641       return
5642       end
5643 C---------------------------------------------------------------------------
5644       subroutine calc_eello(i,j,k,l,jj,kk)
5645 C
5646 C This subroutine computes matrices and vectors needed to calculate
5647 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5648 C
5649       implicit real*8 (a-h,o-z)
5650       include 'DIMENSIONS'
5651       include 'DIMENSIONS.ZSCOPT'
5652       include 'COMMON.IOUNITS'
5653       include 'COMMON.CHAIN'
5654       include 'COMMON.DERIV'
5655       include 'COMMON.INTERACT'
5656       include 'COMMON.CONTACTS'
5657       include 'COMMON.TORSION'
5658       include 'COMMON.VAR'
5659       include 'COMMON.GEO'
5660       include 'COMMON.FFIELD'
5661       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5662      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5663       logical lprn
5664       common /kutas/ lprn
5665 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5666 cd     & ' jj=',jj,' kk=',kk
5667 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5668       do iii=1,2
5669         do jjj=1,2
5670           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5671           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5672         enddo
5673       enddo
5674       call transpose2(aa1(1,1),aa1t(1,1))
5675       call transpose2(aa2(1,1),aa2t(1,1))
5676       do kkk=1,5
5677         do lll=1,3
5678           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5679      &      aa1tder(1,1,lll,kkk))
5680           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5681      &      aa2tder(1,1,lll,kkk))
5682         enddo
5683       enddo
5684       if (l.eq.j+1) then
5685 C parallel orientation of the two CA-CA-CA frames.
5686         if (i.gt.1 .and. itype(i).le.ntyp) then
5687           iti=itortyp(itype(i))
5688         else
5689           iti=ntortyp+1
5690         endif
5691         itk1=itortyp(itype(k+1))
5692         itj=itortyp(itype(j))
5693         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5694           itl1=itortyp(itype(l+1))
5695         else
5696           itl1=ntortyp+1
5697         endif
5698 C A1 kernel(j+1) A2T
5699 cd        do iii=1,2
5700 cd          write (iout,'(3f10.5,5x,3f10.5)')
5701 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5702 cd        enddo
5703         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5704      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5705      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5706 C Following matrices are needed only for 6-th order cumulants
5707         IF (wcorr6.gt.0.0d0) THEN
5708         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5709      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5710      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5711         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5712      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5713      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5714      &   ADtEAderx(1,1,1,1,1,1))
5715         lprn=.false.
5716         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5717      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5718      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5719      &   ADtEA1derx(1,1,1,1,1,1))
5720         ENDIF
5721 C End 6-th order cumulants
5722 cd        lprn=.false.
5723 cd        if (lprn) then
5724 cd        write (2,*) 'In calc_eello6'
5725 cd        do iii=1,2
5726 cd          write (2,*) 'iii=',iii
5727 cd          do kkk=1,5
5728 cd            write (2,*) 'kkk=',kkk
5729 cd            do jjj=1,2
5730 cd              write (2,'(3(2f10.5),5x)')
5731 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5732 cd            enddo
5733 cd          enddo
5734 cd        enddo
5735 cd        endif
5736         call transpose2(EUgder(1,1,k),auxmat(1,1))
5737         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5738         call transpose2(EUg(1,1,k),auxmat(1,1))
5739         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5740         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5741         do iii=1,2
5742           do kkk=1,5
5743             do lll=1,3
5744               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5745      &          EAEAderx(1,1,lll,kkk,iii,1))
5746             enddo
5747           enddo
5748         enddo
5749 C A1T kernel(i+1) A2
5750         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5751      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5752      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5753 C Following matrices are needed only for 6-th order cumulants
5754         IF (wcorr6.gt.0.0d0) THEN
5755         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5756      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5757      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5758         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5759      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5760      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5761      &   ADtEAderx(1,1,1,1,1,2))
5762         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5763      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5764      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5765      &   ADtEA1derx(1,1,1,1,1,2))
5766         ENDIF
5767 C End 6-th order cumulants
5768         call transpose2(EUgder(1,1,l),auxmat(1,1))
5769         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5770         call transpose2(EUg(1,1,l),auxmat(1,1))
5771         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5772         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5773         do iii=1,2
5774           do kkk=1,5
5775             do lll=1,3
5776               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5777      &          EAEAderx(1,1,lll,kkk,iii,2))
5778             enddo
5779           enddo
5780         enddo
5781 C AEAb1 and AEAb2
5782 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5783 C They are needed only when the fifth- or the sixth-order cumulants are
5784 C indluded.
5785         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5786         call transpose2(AEA(1,1,1),auxmat(1,1))
5787         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5788         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5789         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5790         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5791         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5792         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5793         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5794         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5795         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5796         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5797         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5798         call transpose2(AEA(1,1,2),auxmat(1,1))
5799         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5800         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5801         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5802         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5803         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5804         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5805         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5806         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5807         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5808         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5809         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5810 C Calculate the Cartesian derivatives of the vectors.
5811         do iii=1,2
5812           do kkk=1,5
5813             do lll=1,3
5814               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5815               call matvec2(auxmat(1,1),b1(1,iti),
5816      &          AEAb1derx(1,lll,kkk,iii,1,1))
5817               call matvec2(auxmat(1,1),Ub2(1,i),
5818      &          AEAb2derx(1,lll,kkk,iii,1,1))
5819               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5820      &          AEAb1derx(1,lll,kkk,iii,2,1))
5821               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5822      &          AEAb2derx(1,lll,kkk,iii,2,1))
5823               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5824               call matvec2(auxmat(1,1),b1(1,itj),
5825      &          AEAb1derx(1,lll,kkk,iii,1,2))
5826               call matvec2(auxmat(1,1),Ub2(1,j),
5827      &          AEAb2derx(1,lll,kkk,iii,1,2))
5828               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5829      &          AEAb1derx(1,lll,kkk,iii,2,2))
5830               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5831      &          AEAb2derx(1,lll,kkk,iii,2,2))
5832             enddo
5833           enddo
5834         enddo
5835         ENDIF
5836 C End vectors
5837       else
5838 C Antiparallel orientation of the two CA-CA-CA frames.
5839         if (i.gt.1 .and. itype(i).le.ntyp) then
5840           iti=itortyp(itype(i))
5841         else
5842           iti=ntortyp+1
5843         endif
5844         itk1=itortyp(itype(k+1))
5845         itl=itortyp(itype(l))
5846         itj=itortyp(itype(j))
5847         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
5848           itj1=itortyp(itype(j+1))
5849         else
5850           itj1=ntortyp+1
5851         endif
5852 C A2 kernel(j-1)T A1T
5853         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5854      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5855      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5856 C Following matrices are needed only for 6-th order cumulants
5857         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5858      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5859         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5860      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5861      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5862         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5863      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5864      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5865      &   ADtEAderx(1,1,1,1,1,1))
5866         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5867      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5868      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5869      &   ADtEA1derx(1,1,1,1,1,1))
5870         ENDIF
5871 C End 6-th order cumulants
5872         call transpose2(EUgder(1,1,k),auxmat(1,1))
5873         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5874         call transpose2(EUg(1,1,k),auxmat(1,1))
5875         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5876         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5877         do iii=1,2
5878           do kkk=1,5
5879             do lll=1,3
5880               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5881      &          EAEAderx(1,1,lll,kkk,iii,1))
5882             enddo
5883           enddo
5884         enddo
5885 C A2T kernel(i+1)T A1
5886         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5887      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5888      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5889 C Following matrices are needed only for 6-th order cumulants
5890         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5891      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5892         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5893      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5894      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5895         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5896      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5897      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5898      &   ADtEAderx(1,1,1,1,1,2))
5899         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5900      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5901      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5902      &   ADtEA1derx(1,1,1,1,1,2))
5903         ENDIF
5904 C End 6-th order cumulants
5905         call transpose2(EUgder(1,1,j),auxmat(1,1))
5906         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5907         call transpose2(EUg(1,1,j),auxmat(1,1))
5908         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5909         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5910         do iii=1,2
5911           do kkk=1,5
5912             do lll=1,3
5913               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5914      &          EAEAderx(1,1,lll,kkk,iii,2))
5915             enddo
5916           enddo
5917         enddo
5918 C AEAb1 and AEAb2
5919 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5920 C They are needed only when the fifth- or the sixth-order cumulants are
5921 C indluded.
5922         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5923      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5924         call transpose2(AEA(1,1,1),auxmat(1,1))
5925         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5926         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5927         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5928         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5929         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5930         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5931         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5932         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5933         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5934         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5935         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5936         call transpose2(AEA(1,1,2),auxmat(1,1))
5937         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5938         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5939         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5940         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5941         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5942         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5943         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5944         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5945         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5946         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5947         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5948 C Calculate the Cartesian derivatives of the vectors.
5949         do iii=1,2
5950           do kkk=1,5
5951             do lll=1,3
5952               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5953               call matvec2(auxmat(1,1),b1(1,iti),
5954      &          AEAb1derx(1,lll,kkk,iii,1,1))
5955               call matvec2(auxmat(1,1),Ub2(1,i),
5956      &          AEAb2derx(1,lll,kkk,iii,1,1))
5957               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5958      &          AEAb1derx(1,lll,kkk,iii,2,1))
5959               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5960      &          AEAb2derx(1,lll,kkk,iii,2,1))
5961               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5962               call matvec2(auxmat(1,1),b1(1,itl),
5963      &          AEAb1derx(1,lll,kkk,iii,1,2))
5964               call matvec2(auxmat(1,1),Ub2(1,l),
5965      &          AEAb2derx(1,lll,kkk,iii,1,2))
5966               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5967      &          AEAb1derx(1,lll,kkk,iii,2,2))
5968               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5969      &          AEAb2derx(1,lll,kkk,iii,2,2))
5970             enddo
5971           enddo
5972         enddo
5973         ENDIF
5974 C End vectors
5975       endif
5976       return
5977       end
5978 C---------------------------------------------------------------------------
5979       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5980      &  KK,KKderg,AKA,AKAderg,AKAderx)
5981       implicit none
5982       integer nderg
5983       logical transp
5984       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5985      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5986      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5987       integer iii,kkk,lll
5988       integer jjj,mmm
5989       logical lprn
5990       common /kutas/ lprn
5991       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5992       do iii=1,nderg
5993         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5994      &    AKAderg(1,1,iii))
5995       enddo
5996 cd      if (lprn) write (2,*) 'In kernel'
5997       do kkk=1,5
5998 cd        if (lprn) write (2,*) 'kkk=',kkk
5999         do lll=1,3
6000           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6001      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6002 cd          if (lprn) then
6003 cd            write (2,*) 'lll=',lll
6004 cd            write (2,*) 'iii=1'
6005 cd            do jjj=1,2
6006 cd              write (2,'(3(2f10.5),5x)')
6007 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6008 cd            enddo
6009 cd          endif
6010           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6011      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6012 cd          if (lprn) then
6013 cd            write (2,*) 'lll=',lll
6014 cd            write (2,*) 'iii=2'
6015 cd            do jjj=1,2
6016 cd              write (2,'(3(2f10.5),5x)')
6017 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6018 cd            enddo
6019 cd          endif
6020         enddo
6021       enddo
6022       return
6023       end
6024 C---------------------------------------------------------------------------
6025       double precision function eello4(i,j,k,l,jj,kk)
6026       implicit real*8 (a-h,o-z)
6027       include 'DIMENSIONS'
6028       include 'DIMENSIONS.ZSCOPT'
6029       include 'COMMON.IOUNITS'
6030       include 'COMMON.CHAIN'
6031       include 'COMMON.DERIV'
6032       include 'COMMON.INTERACT'
6033       include 'COMMON.CONTACTS'
6034       include 'COMMON.TORSION'
6035       include 'COMMON.VAR'
6036       include 'COMMON.GEO'
6037       double precision pizda(2,2),ggg1(3),ggg2(3)
6038 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6039 cd        eello4=0.0d0
6040 cd        return
6041 cd      endif
6042 cd      print *,'eello4:',i,j,k,l,jj,kk
6043 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6044 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6045 cold      eij=facont_hb(jj,i)
6046 cold      ekl=facont_hb(kk,k)
6047 cold      ekont=eij*ekl
6048       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6049       if (calc_grad) then
6050 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6051       gcorr_loc(k-1)=gcorr_loc(k-1)
6052      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6053       if (l.eq.j+1) then
6054         gcorr_loc(l-1)=gcorr_loc(l-1)
6055      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6056       else
6057         gcorr_loc(j-1)=gcorr_loc(j-1)
6058      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6059       endif
6060       do iii=1,2
6061         do kkk=1,5
6062           do lll=1,3
6063             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6064      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6065 cd            derx(lll,kkk,iii)=0.0d0
6066           enddo
6067         enddo
6068       enddo
6069 cd      gcorr_loc(l-1)=0.0d0
6070 cd      gcorr_loc(j-1)=0.0d0
6071 cd      gcorr_loc(k-1)=0.0d0
6072 cd      eel4=1.0d0
6073 cd      write (iout,*)'Contacts have occurred for peptide groups',
6074 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6075 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6076       if (j.lt.nres-1) then
6077         j1=j+1
6078         j2=j-1
6079       else
6080         j1=j-1
6081         j2=j-2
6082       endif
6083       if (l.lt.nres-1) then
6084         l1=l+1
6085         l2=l-1
6086       else
6087         l1=l-1
6088         l2=l-2
6089       endif
6090       do ll=1,3
6091 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6092         ggg1(ll)=eel4*g_contij(ll,1)
6093         ggg2(ll)=eel4*g_contij(ll,2)
6094         ghalf=0.5d0*ggg1(ll)
6095 cd        ghalf=0.0d0
6096         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6097         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6098         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6099         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6100 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6101         ghalf=0.5d0*ggg2(ll)
6102 cd        ghalf=0.0d0
6103         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6104         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6105         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6106         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6107       enddo
6108 cd      goto 1112
6109       do m=i+1,j-1
6110         do ll=1,3
6111 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6112           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6113         enddo
6114       enddo
6115       do m=k+1,l-1
6116         do ll=1,3
6117 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6118           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6119         enddo
6120       enddo
6121 1112  continue
6122       do m=i+2,j2
6123         do ll=1,3
6124           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6125         enddo
6126       enddo
6127       do m=k+2,l2
6128         do ll=1,3
6129           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6130         enddo
6131       enddo
6132 cd      do iii=1,nres-3
6133 cd        write (2,*) iii,gcorr_loc(iii)
6134 cd      enddo
6135       endif
6136       eello4=ekont*eel4
6137 cd      write (2,*) 'ekont',ekont
6138 cd      write (iout,*) 'eello4',ekont*eel4
6139       return
6140       end
6141 C---------------------------------------------------------------------------
6142       double precision function eello5(i,j,k,l,jj,kk)
6143       implicit real*8 (a-h,o-z)
6144       include 'DIMENSIONS'
6145       include 'DIMENSIONS.ZSCOPT'
6146       include 'COMMON.IOUNITS'
6147       include 'COMMON.CHAIN'
6148       include 'COMMON.DERIV'
6149       include 'COMMON.INTERACT'
6150       include 'COMMON.CONTACTS'
6151       include 'COMMON.TORSION'
6152       include 'COMMON.VAR'
6153       include 'COMMON.GEO'
6154       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6155       double precision ggg1(3),ggg2(3)
6156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6157 C                                                                              C
6158 C                            Parallel chains                                   C
6159 C                                                                              C
6160 C          o             o                   o             o                   C
6161 C         /l\           / \             \   / \           / \   /              C
6162 C        /   \         /   \             \ /   \         /   \ /               C
6163 C       j| o |l1       | o |              o| o |         | o |o                C
6164 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6165 C      \i/   \         /   \ /             /   \         /   \                 C
6166 C       o    k1             o                                                  C
6167 C         (I)          (II)                (III)          (IV)                 C
6168 C                                                                              C
6169 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6170 C                                                                              C
6171 C                            Antiparallel chains                               C
6172 C                                                                              C
6173 C          o             o                   o             o                   C
6174 C         /j\           / \             \   / \           / \   /              C
6175 C        /   \         /   \             \ /   \         /   \ /               C
6176 C      j1| o |l        | o |              o| o |         | o |o                C
6177 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6178 C      \i/   \         /   \ /             /   \         /   \                 C
6179 C       o     k1            o                                                  C
6180 C         (I)          (II)                (III)          (IV)                 C
6181 C                                                                              C
6182 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6183 C                                                                              C
6184 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6185 C                                                                              C
6186 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6187 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6188 cd        eello5=0.0d0
6189 cd        return
6190 cd      endif
6191 cd      write (iout,*)
6192 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6193 cd     &   ' and',k,l
6194       itk=itortyp(itype(k))
6195       itl=itortyp(itype(l))
6196       itj=itortyp(itype(j))
6197       eello5_1=0.0d0
6198       eello5_2=0.0d0
6199       eello5_3=0.0d0
6200       eello5_4=0.0d0
6201 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6202 cd     &   eel5_3_num,eel5_4_num)
6203       do iii=1,2
6204         do kkk=1,5
6205           do lll=1,3
6206             derx(lll,kkk,iii)=0.0d0
6207           enddo
6208         enddo
6209       enddo
6210 cd      eij=facont_hb(jj,i)
6211 cd      ekl=facont_hb(kk,k)
6212 cd      ekont=eij*ekl
6213 cd      write (iout,*)'Contacts have occurred for peptide groups',
6214 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6215 cd      goto 1111
6216 C Contribution from the graph I.
6217 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6218 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6219       call transpose2(EUg(1,1,k),auxmat(1,1))
6220       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6221       vv(1)=pizda(1,1)-pizda(2,2)
6222       vv(2)=pizda(1,2)+pizda(2,1)
6223       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6224      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6225       if (calc_grad) then
6226 C Explicit gradient in virtual-dihedral angles.
6227       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6228      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6229      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6230       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6231       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6232       vv(1)=pizda(1,1)-pizda(2,2)
6233       vv(2)=pizda(1,2)+pizda(2,1)
6234       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6235      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6236      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6237       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6238       vv(1)=pizda(1,1)-pizda(2,2)
6239       vv(2)=pizda(1,2)+pizda(2,1)
6240       if (l.eq.j+1) then
6241         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6242      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6243      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6244       else
6245         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6246      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6247      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6248       endif
6249 C Cartesian gradient
6250       do iii=1,2
6251         do kkk=1,5
6252           do lll=1,3
6253             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6254      &        pizda(1,1))
6255             vv(1)=pizda(1,1)-pizda(2,2)
6256             vv(2)=pizda(1,2)+pizda(2,1)
6257             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6258      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6259      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6260           enddo
6261         enddo
6262       enddo
6263 c      goto 1112
6264       endif
6265 c1111  continue
6266 C Contribution from graph II
6267       call transpose2(EE(1,1,itk),auxmat(1,1))
6268       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6269       vv(1)=pizda(1,1)+pizda(2,2)
6270       vv(2)=pizda(2,1)-pizda(1,2)
6271       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6272      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6273       if (calc_grad) then
6274 C Explicit gradient in virtual-dihedral angles.
6275       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6276      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6277       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6278       vv(1)=pizda(1,1)+pizda(2,2)
6279       vv(2)=pizda(2,1)-pizda(1,2)
6280       if (l.eq.j+1) then
6281         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6282      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6283      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6284       else
6285         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6286      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6287      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6288       endif
6289 C Cartesian gradient
6290       do iii=1,2
6291         do kkk=1,5
6292           do lll=1,3
6293             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6294      &        pizda(1,1))
6295             vv(1)=pizda(1,1)+pizda(2,2)
6296             vv(2)=pizda(2,1)-pizda(1,2)
6297             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6298      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6299      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6300           enddo
6301         enddo
6302       enddo
6303 cd      goto 1112
6304       endif
6305 cd1111  continue
6306       if (l.eq.j+1) then
6307 cd        goto 1110
6308 C Parallel orientation
6309 C Contribution from graph III
6310         call transpose2(EUg(1,1,l),auxmat(1,1))
6311         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6312         vv(1)=pizda(1,1)-pizda(2,2)
6313         vv(2)=pizda(1,2)+pizda(2,1)
6314         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6315      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6316         if (calc_grad) then
6317 C Explicit gradient in virtual-dihedral angles.
6318         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6319      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6320      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6321         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6322         vv(1)=pizda(1,1)-pizda(2,2)
6323         vv(2)=pizda(1,2)+pizda(2,1)
6324         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6325      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6326      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6327         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6328         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6329         vv(1)=pizda(1,1)-pizda(2,2)
6330         vv(2)=pizda(1,2)+pizda(2,1)
6331         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6332      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6333      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6334 C Cartesian gradient
6335         do iii=1,2
6336           do kkk=1,5
6337             do lll=1,3
6338               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6339      &          pizda(1,1))
6340               vv(1)=pizda(1,1)-pizda(2,2)
6341               vv(2)=pizda(1,2)+pizda(2,1)
6342               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6343      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6344      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6345             enddo
6346           enddo
6347         enddo
6348 cd        goto 1112
6349         endif
6350 C Contribution from graph IV
6351 cd1110    continue
6352         call transpose2(EE(1,1,itl),auxmat(1,1))
6353         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6354         vv(1)=pizda(1,1)+pizda(2,2)
6355         vv(2)=pizda(2,1)-pizda(1,2)
6356         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6357      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6358         if (calc_grad) then
6359 C Explicit gradient in virtual-dihedral angles.
6360         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6361      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6362         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6363         vv(1)=pizda(1,1)+pizda(2,2)
6364         vv(2)=pizda(2,1)-pizda(1,2)
6365         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6366      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6367      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6368 C Cartesian gradient
6369         do iii=1,2
6370           do kkk=1,5
6371             do lll=1,3
6372               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6373      &          pizda(1,1))
6374               vv(1)=pizda(1,1)+pizda(2,2)
6375               vv(2)=pizda(2,1)-pizda(1,2)
6376               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6377      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6378      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6379             enddo
6380           enddo
6381         enddo
6382         endif
6383       else
6384 C Antiparallel orientation
6385 C Contribution from graph III
6386 c        goto 1110
6387         call transpose2(EUg(1,1,j),auxmat(1,1))
6388         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6389         vv(1)=pizda(1,1)-pizda(2,2)
6390         vv(2)=pizda(1,2)+pizda(2,1)
6391         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6392      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6393         if (calc_grad) then
6394 C Explicit gradient in virtual-dihedral angles.
6395         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6396      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6397      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6398         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6399         vv(1)=pizda(1,1)-pizda(2,2)
6400         vv(2)=pizda(1,2)+pizda(2,1)
6401         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6402      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6403      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6404         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6405         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6406         vv(1)=pizda(1,1)-pizda(2,2)
6407         vv(2)=pizda(1,2)+pizda(2,1)
6408         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6409      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6410      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6411 C Cartesian gradient
6412         do iii=1,2
6413           do kkk=1,5
6414             do lll=1,3
6415               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6416      &          pizda(1,1))
6417               vv(1)=pizda(1,1)-pizda(2,2)
6418               vv(2)=pizda(1,2)+pizda(2,1)
6419               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6420      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6421      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6422             enddo
6423           enddo
6424         enddo
6425 cd        goto 1112
6426         endif
6427 C Contribution from graph IV
6428 1110    continue
6429         call transpose2(EE(1,1,itj),auxmat(1,1))
6430         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6431         vv(1)=pizda(1,1)+pizda(2,2)
6432         vv(2)=pizda(2,1)-pizda(1,2)
6433         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6434      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6435         if (calc_grad) then
6436 C Explicit gradient in virtual-dihedral angles.
6437         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6438      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6439         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6440         vv(1)=pizda(1,1)+pizda(2,2)
6441         vv(2)=pizda(2,1)-pizda(1,2)
6442         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6443      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6444      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6445 C Cartesian gradient
6446         do iii=1,2
6447           do kkk=1,5
6448             do lll=1,3
6449               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6450      &          pizda(1,1))
6451               vv(1)=pizda(1,1)+pizda(2,2)
6452               vv(2)=pizda(2,1)-pizda(1,2)
6453               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6454      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6455      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6456             enddo
6457           enddo
6458         enddo
6459       endif
6460       endif
6461 1112  continue
6462       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6463 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6464 cd        write (2,*) 'ijkl',i,j,k,l
6465 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6466 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6467 cd      endif
6468 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6469 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6470 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6471 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6472       if (calc_grad) then
6473       if (j.lt.nres-1) then
6474         j1=j+1
6475         j2=j-1
6476       else
6477         j1=j-1
6478         j2=j-2
6479       endif
6480       if (l.lt.nres-1) then
6481         l1=l+1
6482         l2=l-1
6483       else
6484         l1=l-1
6485         l2=l-2
6486       endif
6487 cd      eij=1.0d0
6488 cd      ekl=1.0d0
6489 cd      ekont=1.0d0
6490 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6491       do ll=1,3
6492         ggg1(ll)=eel5*g_contij(ll,1)
6493         ggg2(ll)=eel5*g_contij(ll,2)
6494 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6495         ghalf=0.5d0*ggg1(ll)
6496 cd        ghalf=0.0d0
6497         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6498         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6499         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6500         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6501 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6502         ghalf=0.5d0*ggg2(ll)
6503 cd        ghalf=0.0d0
6504         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6505         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6506         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6507         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6508       enddo
6509 cd      goto 1112
6510       do m=i+1,j-1
6511         do ll=1,3
6512 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6513           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6514         enddo
6515       enddo
6516       do m=k+1,l-1
6517         do ll=1,3
6518 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6519           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6520         enddo
6521       enddo
6522 c1112  continue
6523       do m=i+2,j2
6524         do ll=1,3
6525           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6526         enddo
6527       enddo
6528       do m=k+2,l2
6529         do ll=1,3
6530           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6531         enddo
6532       enddo
6533 cd      do iii=1,nres-3
6534 cd        write (2,*) iii,g_corr5_loc(iii)
6535 cd      enddo
6536       endif
6537       eello5=ekont*eel5
6538 cd      write (2,*) 'ekont',ekont
6539 cd      write (iout,*) 'eello5',ekont*eel5
6540       return
6541       end
6542 c--------------------------------------------------------------------------
6543       double precision function eello6(i,j,k,l,jj,kk)
6544       implicit real*8 (a-h,o-z)
6545       include 'DIMENSIONS'
6546       include 'DIMENSIONS.ZSCOPT'
6547       include 'COMMON.IOUNITS'
6548       include 'COMMON.CHAIN'
6549       include 'COMMON.DERIV'
6550       include 'COMMON.INTERACT'
6551       include 'COMMON.CONTACTS'
6552       include 'COMMON.TORSION'
6553       include 'COMMON.VAR'
6554       include 'COMMON.GEO'
6555       include 'COMMON.FFIELD'
6556       double precision ggg1(3),ggg2(3)
6557 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6558 cd        eello6=0.0d0
6559 cd        return
6560 cd      endif
6561 cd      write (iout,*)
6562 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6563 cd     &   ' and',k,l
6564       eello6_1=0.0d0
6565       eello6_2=0.0d0
6566       eello6_3=0.0d0
6567       eello6_4=0.0d0
6568       eello6_5=0.0d0
6569       eello6_6=0.0d0
6570 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6571 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6572       do iii=1,2
6573         do kkk=1,5
6574           do lll=1,3
6575             derx(lll,kkk,iii)=0.0d0
6576           enddo
6577         enddo
6578       enddo
6579 cd      eij=facont_hb(jj,i)
6580 cd      ekl=facont_hb(kk,k)
6581 cd      ekont=eij*ekl
6582 cd      eij=1.0d0
6583 cd      ekl=1.0d0
6584 cd      ekont=1.0d0
6585       if (l.eq.j+1) then
6586         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6587         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6588         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6589         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6590         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6591         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6592       else
6593         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6594         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6595         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6596         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6597         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6598           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6599         else
6600           eello6_5=0.0d0
6601         endif
6602         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6603       endif
6604 C If turn contributions are considered, they will be handled separately.
6605       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6606 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6607 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6608 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6609 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6610 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6611 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6612 cd      goto 1112
6613       if (calc_grad) then
6614       if (j.lt.nres-1) then
6615         j1=j+1
6616         j2=j-1
6617       else
6618         j1=j-1
6619         j2=j-2
6620       endif
6621       if (l.lt.nres-1) then
6622         l1=l+1
6623         l2=l-1
6624       else
6625         l1=l-1
6626         l2=l-2
6627       endif
6628       do ll=1,3
6629         ggg1(ll)=eel6*g_contij(ll,1)
6630         ggg2(ll)=eel6*g_contij(ll,2)
6631 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6632         ghalf=0.5d0*ggg1(ll)
6633 cd        ghalf=0.0d0
6634         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6635         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6636         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6637         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6638         ghalf=0.5d0*ggg2(ll)
6639 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6640 cd        ghalf=0.0d0
6641         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6642         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6643         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6644         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6645       enddo
6646 cd      goto 1112
6647       do m=i+1,j-1
6648         do ll=1,3
6649 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6650           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6651         enddo
6652       enddo
6653       do m=k+1,l-1
6654         do ll=1,3
6655 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6656           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6657         enddo
6658       enddo
6659 1112  continue
6660       do m=i+2,j2
6661         do ll=1,3
6662           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6663         enddo
6664       enddo
6665       do m=k+2,l2
6666         do ll=1,3
6667           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6668         enddo
6669       enddo
6670 cd      do iii=1,nres-3
6671 cd        write (2,*) iii,g_corr6_loc(iii)
6672 cd      enddo
6673       endif
6674       eello6=ekont*eel6
6675 cd      write (2,*) 'ekont',ekont
6676 cd      write (iout,*) 'eello6',ekont*eel6
6677       return
6678       end
6679 c--------------------------------------------------------------------------
6680       double precision function eello6_graph1(i,j,k,l,imat,swap)
6681       implicit real*8 (a-h,o-z)
6682       include 'DIMENSIONS'
6683       include 'DIMENSIONS.ZSCOPT'
6684       include 'COMMON.IOUNITS'
6685       include 'COMMON.CHAIN'
6686       include 'COMMON.DERIV'
6687       include 'COMMON.INTERACT'
6688       include 'COMMON.CONTACTS'
6689       include 'COMMON.TORSION'
6690       include 'COMMON.VAR'
6691       include 'COMMON.GEO'
6692       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6693       logical swap
6694       logical lprn
6695       common /kutas/ lprn
6696 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6697 C                                                                              C
6698 C      Parallel       Antiparallel                                             C
6699 C                                                                              C
6700 C          o             o                                                     C
6701 C         /l\           /j\                                                    C
6702 C        /   \         /   \                                                   C
6703 C       /| o |         | o |\                                                  C
6704 C     \ j|/k\|  /   \  |/k\|l /                                                C
6705 C      \ /   \ /     \ /   \ /                                                 C
6706 C       o     o       o     o                                                  C
6707 C       i             i                                                        C
6708 C                                                                              C
6709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6710       itk=itortyp(itype(k))
6711       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6712       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6713       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6714       call transpose2(EUgC(1,1,k),auxmat(1,1))
6715       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6716       vv1(1)=pizda1(1,1)-pizda1(2,2)
6717       vv1(2)=pizda1(1,2)+pizda1(2,1)
6718       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6719       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6720       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6721       s5=scalar2(vv(1),Dtobr2(1,i))
6722 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6723       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6724       if (.not. calc_grad) return
6725       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6726      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6727      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6728      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6729      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6730      & +scalar2(vv(1),Dtobr2der(1,i)))
6731       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6732       vv1(1)=pizda1(1,1)-pizda1(2,2)
6733       vv1(2)=pizda1(1,2)+pizda1(2,1)
6734       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6735       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6736       if (l.eq.j+1) then
6737         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6738      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6739      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6740      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6741      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6742       else
6743         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6744      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6745      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6746      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6747      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6748       endif
6749       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6750       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6751       vv1(1)=pizda1(1,1)-pizda1(2,2)
6752       vv1(2)=pizda1(1,2)+pizda1(2,1)
6753       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6754      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6755      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6756      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6757       do iii=1,2
6758         if (swap) then
6759           ind=3-iii
6760         else
6761           ind=iii
6762         endif
6763         do kkk=1,5
6764           do lll=1,3
6765             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6766             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6767             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6768             call transpose2(EUgC(1,1,k),auxmat(1,1))
6769             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6770      &        pizda1(1,1))
6771             vv1(1)=pizda1(1,1)-pizda1(2,2)
6772             vv1(2)=pizda1(1,2)+pizda1(2,1)
6773             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6774             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6775      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6776             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6777      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6778             s5=scalar2(vv(1),Dtobr2(1,i))
6779             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6780           enddo
6781         enddo
6782       enddo
6783       return
6784       end
6785 c----------------------------------------------------------------------------
6786       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6787       implicit real*8 (a-h,o-z)
6788       include 'DIMENSIONS'
6789       include 'DIMENSIONS.ZSCOPT'
6790       include 'COMMON.IOUNITS'
6791       include 'COMMON.CHAIN'
6792       include 'COMMON.DERIV'
6793       include 'COMMON.INTERACT'
6794       include 'COMMON.CONTACTS'
6795       include 'COMMON.TORSION'
6796       include 'COMMON.VAR'
6797       include 'COMMON.GEO'
6798       logical swap
6799       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6800      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6801       logical lprn
6802       common /kutas/ lprn
6803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6804 C                                                                              C
6805 C      Parallel       Antiparallel                                             C
6806 C                                                                              C
6807 C          o             o                                                     C
6808 C     \   /l\           /j\   /                                                C
6809 C      \ /   \         /   \ /                                                 C
6810 C       o| o |         | o |o                                                  C
6811 C     \ j|/k\|      \  |/k\|l                                                  C
6812 C      \ /   \       \ /   \                                                   C
6813 C       o             o                                                        C
6814 C       i             i                                                        C
6815 C                                                                              C
6816 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6817 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6818 C AL 7/4/01 s1 would occur in the sixth-order moment,
6819 C           but not in a cluster cumulant
6820 #ifdef MOMENT
6821       s1=dip(1,jj,i)*dip(1,kk,k)
6822 #endif
6823       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6824       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6825       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6826       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6827       call transpose2(EUg(1,1,k),auxmat(1,1))
6828       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6829       vv(1)=pizda(1,1)-pizda(2,2)
6830       vv(2)=pizda(1,2)+pizda(2,1)
6831       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6832 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6833 #ifdef MOMENT
6834       eello6_graph2=-(s1+s2+s3+s4)
6835 #else
6836       eello6_graph2=-(s2+s3+s4)
6837 #endif
6838 c      eello6_graph2=-s3
6839       if (.not. calc_grad) return
6840 C Derivatives in gamma(i-1)
6841       if (i.gt.1) then
6842 #ifdef MOMENT
6843         s1=dipderg(1,jj,i)*dip(1,kk,k)
6844 #endif
6845         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6846         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6847         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6848         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6849 #ifdef MOMENT
6850         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6851 #else
6852         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6853 #endif
6854 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6855       endif
6856 C Derivatives in gamma(k-1)
6857 #ifdef MOMENT
6858       s1=dip(1,jj,i)*dipderg(1,kk,k)
6859 #endif
6860       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6861       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6862       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6863       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6864       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6865       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6866       vv(1)=pizda(1,1)-pizda(2,2)
6867       vv(2)=pizda(1,2)+pizda(2,1)
6868       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6869 #ifdef MOMENT
6870       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6871 #else
6872       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6873 #endif
6874 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6875 C Derivatives in gamma(j-1) or gamma(l-1)
6876       if (j.gt.1) then
6877 #ifdef MOMENT
6878         s1=dipderg(3,jj,i)*dip(1,kk,k)
6879 #endif
6880         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6881         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6882         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6883         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6884         vv(1)=pizda(1,1)-pizda(2,2)
6885         vv(2)=pizda(1,2)+pizda(2,1)
6886         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6887 #ifdef MOMENT
6888         if (swap) then
6889           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6890         else
6891           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6892         endif
6893 #endif
6894         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6895 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6896       endif
6897 C Derivatives in gamma(l-1) or gamma(j-1)
6898       if (l.gt.1) then
6899 #ifdef MOMENT
6900         s1=dip(1,jj,i)*dipderg(3,kk,k)
6901 #endif
6902         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6903         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6904         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6905         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6906         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6907         vv(1)=pizda(1,1)-pizda(2,2)
6908         vv(2)=pizda(1,2)+pizda(2,1)
6909         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6910 #ifdef MOMENT
6911         if (swap) then
6912           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6913         else
6914           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6915         endif
6916 #endif
6917         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6918 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6919       endif
6920 C Cartesian derivatives.
6921       if (lprn) then
6922         write (2,*) 'In eello6_graph2'
6923         do iii=1,2
6924           write (2,*) 'iii=',iii
6925           do kkk=1,5
6926             write (2,*) 'kkk=',kkk
6927             do jjj=1,2
6928               write (2,'(3(2f10.5),5x)')
6929      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6930             enddo
6931           enddo
6932         enddo
6933       endif
6934       do iii=1,2
6935         do kkk=1,5
6936           do lll=1,3
6937 #ifdef MOMENT
6938             if (iii.eq.1) then
6939               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6940             else
6941               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6942             endif
6943 #endif
6944             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6945      &        auxvec(1))
6946             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6947             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6948      &        auxvec(1))
6949             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6950             call transpose2(EUg(1,1,k),auxmat(1,1))
6951             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6952      &        pizda(1,1))
6953             vv(1)=pizda(1,1)-pizda(2,2)
6954             vv(2)=pizda(1,2)+pizda(2,1)
6955             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6956 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6957 #ifdef MOMENT
6958             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6959 #else
6960             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6961 #endif
6962             if (swap) then
6963               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6964             else
6965               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6966             endif
6967           enddo
6968         enddo
6969       enddo
6970       return
6971       end
6972 c----------------------------------------------------------------------------
6973       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6974       implicit real*8 (a-h,o-z)
6975       include 'DIMENSIONS'
6976       include 'DIMENSIONS.ZSCOPT'
6977       include 'COMMON.IOUNITS'
6978       include 'COMMON.CHAIN'
6979       include 'COMMON.DERIV'
6980       include 'COMMON.INTERACT'
6981       include 'COMMON.CONTACTS'
6982       include 'COMMON.TORSION'
6983       include 'COMMON.VAR'
6984       include 'COMMON.GEO'
6985       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6986       logical swap
6987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6988 C                                                                              C
6989 C      Parallel       Antiparallel                                             C
6990 C                                                                              C
6991 C          o             o                                                     C
6992 C         /l\   /   \   /j\                                                    C
6993 C        /   \ /     \ /   \                                                   C
6994 C       /| o |o       o| o |\                                                  C
6995 C       j|/k\|  /      |/k\|l /                                                C
6996 C        /   \ /       /   \ /                                                 C
6997 C       /     o       /     o                                                  C
6998 C       i             i                                                        C
6999 C                                                                              C
7000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7001 C
7002 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7003 C           energy moment and not to the cluster cumulant.
7004       iti=itortyp(itype(i))
7005       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7006         itj1=itortyp(itype(j+1))
7007       else
7008         itj1=ntortyp+1
7009       endif
7010       itk=itortyp(itype(k))
7011       itk1=itortyp(itype(k+1))
7012       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7013         itl1=itortyp(itype(l+1))
7014       else
7015         itl1=ntortyp+1
7016       endif
7017 #ifdef MOMENT
7018       s1=dip(4,jj,i)*dip(4,kk,k)
7019 #endif
7020       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7021       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7022       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7023       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7024       call transpose2(EE(1,1,itk),auxmat(1,1))
7025       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7026       vv(1)=pizda(1,1)+pizda(2,2)
7027       vv(2)=pizda(2,1)-pizda(1,2)
7028       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7029 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7030 #ifdef MOMENT
7031       eello6_graph3=-(s1+s2+s3+s4)
7032 #else
7033       eello6_graph3=-(s2+s3+s4)
7034 #endif
7035 c      eello6_graph3=-s4
7036       if (.not. calc_grad) return
7037 C Derivatives in gamma(k-1)
7038       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7039       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7040       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7041       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7042 C Derivatives in gamma(l-1)
7043       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7044       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7045       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7046       vv(1)=pizda(1,1)+pizda(2,2)
7047       vv(2)=pizda(2,1)-pizda(1,2)
7048       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7049       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7050 C Cartesian derivatives.
7051       do iii=1,2
7052         do kkk=1,5
7053           do lll=1,3
7054 #ifdef MOMENT
7055             if (iii.eq.1) then
7056               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7057             else
7058               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7059             endif
7060 #endif
7061             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7062      &        auxvec(1))
7063             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7064             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7065      &        auxvec(1))
7066             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7067             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7068      &        pizda(1,1))
7069             vv(1)=pizda(1,1)+pizda(2,2)
7070             vv(2)=pizda(2,1)-pizda(1,2)
7071             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7072 #ifdef MOMENT
7073             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7074 #else
7075             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7076 #endif
7077             if (swap) then
7078               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7079             else
7080               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7081             endif
7082 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7083           enddo
7084         enddo
7085       enddo
7086       return
7087       end
7088 c----------------------------------------------------------------------------
7089       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7090       implicit real*8 (a-h,o-z)
7091       include 'DIMENSIONS'
7092       include 'DIMENSIONS.ZSCOPT'
7093       include 'COMMON.IOUNITS'
7094       include 'COMMON.CHAIN'
7095       include 'COMMON.DERIV'
7096       include 'COMMON.INTERACT'
7097       include 'COMMON.CONTACTS'
7098       include 'COMMON.TORSION'
7099       include 'COMMON.VAR'
7100       include 'COMMON.GEO'
7101       include 'COMMON.FFIELD'
7102       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7103      & auxvec1(2),auxmat1(2,2)
7104       logical swap
7105 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7106 C                                                                              C
7107 C      Parallel       Antiparallel                                             C
7108 C                                                                              C
7109 C          o             o                                                     C
7110 C         /l\   /   \   /j\                                                    C
7111 C        /   \ /     \ /   \                                                   C
7112 C       /| o |o       o| o |\                                                  C
7113 C     \ j|/k\|      \  |/k\|l                                                  C
7114 C      \ /   \       \ /   \                                                   C
7115 C       o     \       o     \                                                  C
7116 C       i             i                                                        C
7117 C                                                                              C
7118 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7119 C
7120 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7121 C           energy moment and not to the cluster cumulant.
7122 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7123       iti=itortyp(itype(i))
7124       itj=itortyp(itype(j))
7125       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7126         itj1=itortyp(itype(j+1))
7127       else
7128         itj1=ntortyp+1
7129       endif
7130       itk=itortyp(itype(k))
7131       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7132         itk1=itortyp(itype(k+1))
7133       else
7134         itk1=ntortyp+1
7135       endif
7136       itl=itortyp(itype(l))
7137       if (l.lt.nres-1) then
7138         itl1=itortyp(itype(l+1))
7139       else
7140         itl1=ntortyp+1
7141       endif
7142 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7143 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7144 cd     & ' itl',itl,' itl1',itl1
7145 #ifdef MOMENT
7146       if (imat.eq.1) then
7147         s1=dip(3,jj,i)*dip(3,kk,k)
7148       else
7149         s1=dip(2,jj,j)*dip(2,kk,l)
7150       endif
7151 #endif
7152       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7153       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7154       if (j.eq.l+1) then
7155         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7156         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7157       else
7158         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7159         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7160       endif
7161       call transpose2(EUg(1,1,k),auxmat(1,1))
7162       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7163       vv(1)=pizda(1,1)-pizda(2,2)
7164       vv(2)=pizda(2,1)+pizda(1,2)
7165       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7166 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7167 #ifdef MOMENT
7168       eello6_graph4=-(s1+s2+s3+s4)
7169 #else
7170       eello6_graph4=-(s2+s3+s4)
7171 #endif
7172       if (.not. calc_grad) return
7173 C Derivatives in gamma(i-1)
7174       if (i.gt.1) then
7175 #ifdef MOMENT
7176         if (imat.eq.1) then
7177           s1=dipderg(2,jj,i)*dip(3,kk,k)
7178         else
7179           s1=dipderg(4,jj,j)*dip(2,kk,l)
7180         endif
7181 #endif
7182         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7183         if (j.eq.l+1) then
7184           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7185           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7186         else
7187           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7188           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7189         endif
7190         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7191         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7192 cd          write (2,*) 'turn6 derivatives'
7193 #ifdef MOMENT
7194           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7195 #else
7196           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7197 #endif
7198         else
7199 #ifdef MOMENT
7200           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7201 #else
7202           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7203 #endif
7204         endif
7205       endif
7206 C Derivatives in gamma(k-1)
7207 #ifdef MOMENT
7208       if (imat.eq.1) then
7209         s1=dip(3,jj,i)*dipderg(2,kk,k)
7210       else
7211         s1=dip(2,jj,j)*dipderg(4,kk,l)
7212       endif
7213 #endif
7214       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7215       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7216       if (j.eq.l+1) then
7217         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7218         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7219       else
7220         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7221         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7222       endif
7223       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7224       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7225       vv(1)=pizda(1,1)-pizda(2,2)
7226       vv(2)=pizda(2,1)+pizda(1,2)
7227       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7228       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7229 #ifdef MOMENT
7230         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7231 #else
7232         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7233 #endif
7234       else
7235 #ifdef MOMENT
7236         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7237 #else
7238         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7239 #endif
7240       endif
7241 C Derivatives in gamma(j-1) or gamma(l-1)
7242       if (l.eq.j+1 .and. l.gt.1) then
7243         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7244         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7245         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7246         vv(1)=pizda(1,1)-pizda(2,2)
7247         vv(2)=pizda(2,1)+pizda(1,2)
7248         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7249         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7250       else if (j.gt.1) then
7251         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7252         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7253         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7254         vv(1)=pizda(1,1)-pizda(2,2)
7255         vv(2)=pizda(2,1)+pizda(1,2)
7256         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7257         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7258           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7259         else
7260           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7261         endif
7262       endif
7263 C Cartesian derivatives.
7264       do iii=1,2
7265         do kkk=1,5
7266           do lll=1,3
7267 #ifdef MOMENT
7268             if (iii.eq.1) then
7269               if (imat.eq.1) then
7270                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7271               else
7272                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7273               endif
7274             else
7275               if (imat.eq.1) then
7276                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7277               else
7278                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7279               endif
7280             endif
7281 #endif
7282             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7283      &        auxvec(1))
7284             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7285             if (j.eq.l+1) then
7286               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7287      &          b1(1,itj1),auxvec(1))
7288               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7289             else
7290               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7291      &          b1(1,itl1),auxvec(1))
7292               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7293             endif
7294             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7295      &        pizda(1,1))
7296             vv(1)=pizda(1,1)-pizda(2,2)
7297             vv(2)=pizda(2,1)+pizda(1,2)
7298             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7299             if (swap) then
7300               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7301 #ifdef MOMENT
7302                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7303      &             -(s1+s2+s4)
7304 #else
7305                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7306      &             -(s2+s4)
7307 #endif
7308                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7309               else
7310 #ifdef MOMENT
7311                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7312 #else
7313                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7314 #endif
7315                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7316               endif
7317             else
7318 #ifdef MOMENT
7319               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7320 #else
7321               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7322 #endif
7323               if (l.eq.j+1) then
7324                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7325               else
7326                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7327               endif
7328             endif
7329           enddo
7330         enddo
7331       enddo
7332       return
7333       end
7334 c----------------------------------------------------------------------------
7335       double precision function eello_turn6(i,jj,kk)
7336       implicit real*8 (a-h,o-z)
7337       include 'DIMENSIONS'
7338       include 'DIMENSIONS.ZSCOPT'
7339       include 'COMMON.IOUNITS'
7340       include 'COMMON.CHAIN'
7341       include 'COMMON.DERIV'
7342       include 'COMMON.INTERACT'
7343       include 'COMMON.CONTACTS'
7344       include 'COMMON.TORSION'
7345       include 'COMMON.VAR'
7346       include 'COMMON.GEO'
7347       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7348      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7349      &  ggg1(3),ggg2(3)
7350       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7351      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7352 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7353 C           the respective energy moment and not to the cluster cumulant.
7354       eello_turn6=0.0d0
7355       j=i+4
7356       k=i+1
7357       l=i+3
7358       iti=itortyp(itype(i))
7359       itk=itortyp(itype(k))
7360       itk1=itortyp(itype(k+1))
7361       itl=itortyp(itype(l))
7362       itj=itortyp(itype(j))
7363 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7364 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7365 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7366 cd        eello6=0.0d0
7367 cd        return
7368 cd      endif
7369 cd      write (iout,*)
7370 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7371 cd     &   ' and',k,l
7372 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7373       do iii=1,2
7374         do kkk=1,5
7375           do lll=1,3
7376             derx_turn(lll,kkk,iii)=0.0d0
7377           enddo
7378         enddo
7379       enddo
7380 cd      eij=1.0d0
7381 cd      ekl=1.0d0
7382 cd      ekont=1.0d0
7383       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7384 cd      eello6_5=0.0d0
7385 cd      write (2,*) 'eello6_5',eello6_5
7386 #ifdef MOMENT
7387       call transpose2(AEA(1,1,1),auxmat(1,1))
7388       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7389       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7390       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7391 #else
7392       s1 = 0.0d0
7393 #endif
7394       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7395       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7396       s2 = scalar2(b1(1,itk),vtemp1(1))
7397 #ifdef MOMENT
7398       call transpose2(AEA(1,1,2),atemp(1,1))
7399       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7400       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7401       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7402 #else
7403       s8=0.0d0
7404 #endif
7405       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7406       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7407       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7408 #ifdef MOMENT
7409       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7410       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7411       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7412       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7413       ss13 = scalar2(b1(1,itk),vtemp4(1))
7414       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7415 #else
7416       s13=0.0d0
7417 #endif
7418 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7419 c      s1=0.0d0
7420 c      s2=0.0d0
7421 c      s8=0.0d0
7422 c      s12=0.0d0
7423 c      s13=0.0d0
7424       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7425       if (calc_grad) then
7426 C Derivatives in gamma(i+2)
7427 #ifdef MOMENT
7428       call transpose2(AEA(1,1,1),auxmatd(1,1))
7429       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7430       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7431       call transpose2(AEAderg(1,1,2),atempd(1,1))
7432       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7433       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7434 #else
7435       s8d=0.0d0
7436 #endif
7437       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7438       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7439       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7440 c      s1d=0.0d0
7441 c      s2d=0.0d0
7442 c      s8d=0.0d0
7443 c      s12d=0.0d0
7444 c      s13d=0.0d0
7445       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7446 C Derivatives in gamma(i+3)
7447 #ifdef MOMENT
7448       call transpose2(AEA(1,1,1),auxmatd(1,1))
7449       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7450       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7451       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7452 #else
7453       s1d=0.0d0
7454 #endif
7455       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7456       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7457       s2d = scalar2(b1(1,itk),vtemp1d(1))
7458 #ifdef MOMENT
7459       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7460       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7461 #endif
7462       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7463 #ifdef MOMENT
7464       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7465       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7466       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7467 #else
7468       s13d=0.0d0
7469 #endif
7470 c      s1d=0.0d0
7471 c      s2d=0.0d0
7472 c      s8d=0.0d0
7473 c      s12d=0.0d0
7474 c      s13d=0.0d0
7475 #ifdef MOMENT
7476       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7477      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7478 #else
7479       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7480      &               -0.5d0*ekont*(s2d+s12d)
7481 #endif
7482 C Derivatives in gamma(i+4)
7483       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7484       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7485       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7486 #ifdef MOMENT
7487       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7488       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7489       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7490 #else
7491       s13d = 0.0d0
7492 #endif
7493 c      s1d=0.0d0
7494 c      s2d=0.0d0
7495 c      s8d=0.0d0
7496 C      s12d=0.0d0
7497 c      s13d=0.0d0
7498 #ifdef MOMENT
7499       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7500 #else
7501       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7502 #endif
7503 C Derivatives in gamma(i+5)
7504 #ifdef MOMENT
7505       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7506       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7507       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7508 #else
7509       s1d = 0.0d0
7510 #endif
7511       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7512       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7513       s2d = scalar2(b1(1,itk),vtemp1d(1))
7514 #ifdef MOMENT
7515       call transpose2(AEA(1,1,2),atempd(1,1))
7516       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7517       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7518 #else
7519       s8d = 0.0d0
7520 #endif
7521       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7522       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7523 #ifdef MOMENT
7524       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7525       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7526       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7527 #else
7528       s13d = 0.0d0
7529 #endif
7530 c      s1d=0.0d0
7531 c      s2d=0.0d0
7532 c      s8d=0.0d0
7533 c      s12d=0.0d0
7534 c      s13d=0.0d0
7535 #ifdef MOMENT
7536       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7537      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7538 #else
7539       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7540      &               -0.5d0*ekont*(s2d+s12d)
7541 #endif
7542 C Cartesian derivatives
7543       do iii=1,2
7544         do kkk=1,5
7545           do lll=1,3
7546 #ifdef MOMENT
7547             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7548             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7549             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7550 #else
7551             s1d = 0.0d0
7552 #endif
7553             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7554             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7555      &          vtemp1d(1))
7556             s2d = scalar2(b1(1,itk),vtemp1d(1))
7557 #ifdef MOMENT
7558             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7559             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7560             s8d = -(atempd(1,1)+atempd(2,2))*
7561      &           scalar2(cc(1,1,itl),vtemp2(1))
7562 #else
7563             s8d = 0.0d0
7564 #endif
7565             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7566      &           auxmatd(1,1))
7567             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7568             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7569 c      s1d=0.0d0
7570 c      s2d=0.0d0
7571 c      s8d=0.0d0
7572 c      s12d=0.0d0
7573 c      s13d=0.0d0
7574 #ifdef MOMENT
7575             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7576      &        - 0.5d0*(s1d+s2d)
7577 #else
7578             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7579      &        - 0.5d0*s2d
7580 #endif
7581 #ifdef MOMENT
7582             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7583      &        - 0.5d0*(s8d+s12d)
7584 #else
7585             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7586      &        - 0.5d0*s12d
7587 #endif
7588           enddo
7589         enddo
7590       enddo
7591 #ifdef MOMENT
7592       do kkk=1,5
7593         do lll=1,3
7594           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7595      &      achuj_tempd(1,1))
7596           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7597           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7598           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7599           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7600           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7601      &      vtemp4d(1))
7602           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7603           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7604           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7605         enddo
7606       enddo
7607 #endif
7608 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7609 cd     &  16*eel_turn6_num
7610 cd      goto 1112
7611       if (j.lt.nres-1) then
7612         j1=j+1
7613         j2=j-1
7614       else
7615         j1=j-1
7616         j2=j-2
7617       endif
7618       if (l.lt.nres-1) then
7619         l1=l+1
7620         l2=l-1
7621       else
7622         l1=l-1
7623         l2=l-2
7624       endif
7625       do ll=1,3
7626         ggg1(ll)=eel_turn6*g_contij(ll,1)
7627         ggg2(ll)=eel_turn6*g_contij(ll,2)
7628         ghalf=0.5d0*ggg1(ll)
7629 cd        ghalf=0.0d0
7630         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7631      &    +ekont*derx_turn(ll,2,1)
7632         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7633         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7634      &    +ekont*derx_turn(ll,4,1)
7635         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7636         ghalf=0.5d0*ggg2(ll)
7637 cd        ghalf=0.0d0
7638         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7639      &    +ekont*derx_turn(ll,2,2)
7640         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7641         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7642      &    +ekont*derx_turn(ll,4,2)
7643         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7644       enddo
7645 cd      goto 1112
7646       do m=i+1,j-1
7647         do ll=1,3
7648           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7649         enddo
7650       enddo
7651       do m=k+1,l-1
7652         do ll=1,3
7653           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7654         enddo
7655       enddo
7656 1112  continue
7657       do m=i+2,j2
7658         do ll=1,3
7659           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7660         enddo
7661       enddo
7662       do m=k+2,l2
7663         do ll=1,3
7664           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7665         enddo
7666       enddo
7667 cd      do iii=1,nres-3
7668 cd        write (2,*) iii,g_corr6_loc(iii)
7669 cd      enddo
7670       endif
7671       eello_turn6=ekont*eel_turn6
7672 cd      write (2,*) 'ekont',ekont
7673 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7674       return
7675       end
7676 crc-------------------------------------------------
7677 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7678       subroutine Eliptransfer(eliptran)
7679       implicit real*8 (a-h,o-z)
7680       include 'DIMENSIONS'
7681       include 'COMMON.GEO'
7682       include 'COMMON.VAR'
7683       include 'COMMON.LOCAL'
7684       include 'COMMON.CHAIN'
7685       include 'COMMON.DERIV'
7686       include 'COMMON.INTERACT'
7687       include 'COMMON.IOUNITS'
7688       include 'COMMON.CALC'
7689       include 'COMMON.CONTROL'
7690       include 'COMMON.SPLITELE'
7691       include 'COMMON.SBRIDGE'
7692 C this is done by Adasko
7693 C      print *,"wchodze"
7694 C structure of box:
7695 C      water
7696 C--bordliptop-- buffore starts
7697 C--bufliptop--- here true lipid starts
7698 C      lipid
7699 C--buflipbot--- lipid ends buffore starts
7700 C--bordlipbot--buffore ends
7701       eliptran=0.0
7702       do i=1,nres
7703 C       do i=1,1
7704         if (itype(i).eq.ntyp1) cycle
7705
7706         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
7707         if (positi.le.0) positi=positi+boxzsize
7708 C        print *,i
7709 C first for peptide groups
7710 c for each residue check if it is in lipid or lipid water border area
7711        if ((positi.gt.bordlipbot)
7712      &.and.(positi.lt.bordliptop)) then
7713 C the energy transfer exist
7714         if (positi.lt.buflipbot) then
7715 C what fraction I am in
7716          fracinbuf=1.0d0-
7717      &        ((positi-bordlipbot)/lipbufthick)
7718 C lipbufthick is thickenes of lipid buffore
7719          sslip=sscalelip(fracinbuf)
7720          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
7721          eliptran=eliptran+sslip*pepliptran
7722          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
7723          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
7724 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
7725         elseif (positi.gt.bufliptop) then
7726          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
7727          sslip=sscalelip(fracinbuf)
7728          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
7729          eliptran=eliptran+sslip*pepliptran
7730          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
7731          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
7732 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
7733 C          print *, "doing sscalefor top part"
7734 C         print *,i,sslip,fracinbuf,ssgradlip
7735         else
7736          eliptran=eliptran+pepliptran
7737 C         print *,"I am in true lipid"
7738         endif
7739 C       else
7740 C       eliptran=elpitran+0.0 ! I am in water
7741        endif
7742        enddo
7743 C       print *, "nic nie bylo w lipidzie?"
7744 C now multiply all by the peptide group transfer factor
7745 C       eliptran=eliptran*pepliptran
7746 C now the same for side chains
7747 CV       do i=1,1
7748        do i=1,nres
7749         if (itype(i).eq.ntyp1) cycle
7750         positi=(mod(c(3,i+nres),boxzsize))
7751         if (positi.le.0) positi=positi+boxzsize
7752 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
7753 c for each residue check if it is in lipid or lipid water border area
7754 C       respos=mod(c(3,i+nres),boxzsize)
7755 C       print *,positi,bordlipbot,buflipbot
7756        if ((positi.gt.bordlipbot)
7757      & .and.(positi.lt.bordliptop)) then
7758 C the energy transfer exist
7759         if (positi.lt.buflipbot) then
7760          fracinbuf=1.0d0-
7761      &     ((positi-bordlipbot)/lipbufthick)
7762 C lipbufthick is thickenes of lipid buffore
7763          sslip=sscalelip(fracinbuf)
7764          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
7765          eliptran=eliptran+sslip*liptranene(itype(i))
7766          gliptranx(3,i)=gliptranx(3,i)
7767      &+ssgradlip*liptranene(itype(i))
7768          gliptranc(3,i-1)= gliptranc(3,i-1)
7769      &+ssgradlip*liptranene(itype(i))
7770 C         print *,"doing sccale for lower part"
7771         elseif (positi.gt.bufliptop) then
7772          fracinbuf=1.0d0-
7773      &((bordliptop-positi)/lipbufthick)
7774          sslip=sscalelip(fracinbuf)
7775          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
7776          eliptran=eliptran+sslip*liptranene(itype(i))
7777          gliptranx(3,i)=gliptranx(3,i)
7778      &+ssgradlip*liptranene(itype(i))
7779          gliptranc(3,i-1)= gliptranc(3,i-1)
7780      &+ssgradlip*liptranene(itype(i))
7781 C          print *, "doing sscalefor top part",sslip,fracinbuf
7782         else
7783          eliptran=eliptran+liptranene(itype(i))
7784 C         print *,"I am in true lipid"
7785         endif
7786         endif ! if in lipid or buffor
7787 C       else
7788 C       eliptran=elpitran+0.0 ! I am in water
7789        enddo
7790        return
7791        end
7792
7793
7794 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7795
7796       SUBROUTINE MATVEC2(A1,V1,V2)
7797       implicit real*8 (a-h,o-z)
7798       include 'DIMENSIONS'
7799       DIMENSION A1(2,2),V1(2),V2(2)
7800 c      DO 1 I=1,2
7801 c        VI=0.0
7802 c        DO 3 K=1,2
7803 c    3     VI=VI+A1(I,K)*V1(K)
7804 c        Vaux(I)=VI
7805 c    1 CONTINUE
7806
7807       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7808       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7809
7810       v2(1)=vaux1
7811       v2(2)=vaux2
7812       END
7813 C---------------------------------------
7814       SUBROUTINE MATMAT2(A1,A2,A3)
7815       implicit real*8 (a-h,o-z)
7816       include 'DIMENSIONS'
7817       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7818 c      DIMENSION AI3(2,2)
7819 c        DO  J=1,2
7820 c          A3IJ=0.0
7821 c          DO K=1,2
7822 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7823 c          enddo
7824 c          A3(I,J)=A3IJ
7825 c       enddo
7826 c      enddo
7827
7828       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7829       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7830       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7831       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7832
7833       A3(1,1)=AI3_11
7834       A3(2,1)=AI3_21
7835       A3(1,2)=AI3_12
7836       A3(2,2)=AI3_22
7837       END
7838
7839 c-------------------------------------------------------------------------
7840       double precision function scalar2(u,v)
7841       implicit none
7842       double precision u(2),v(2)
7843       double precision sc
7844       integer i
7845       scalar2=u(1)*v(1)+u(2)*v(2)
7846       return
7847       end
7848
7849 C-----------------------------------------------------------------------------
7850
7851       subroutine transpose2(a,at)
7852       implicit none
7853       double precision a(2,2),at(2,2)
7854       at(1,1)=a(1,1)
7855       at(1,2)=a(2,1)
7856       at(2,1)=a(1,2)
7857       at(2,2)=a(2,2)
7858       return
7859       end
7860 c--------------------------------------------------------------------------
7861       subroutine transpose(n,a,at)
7862       implicit none
7863       integer n,i,j
7864       double precision a(n,n),at(n,n)
7865       do i=1,n
7866         do j=1,n
7867           at(j,i)=a(i,j)
7868         enddo
7869       enddo
7870       return
7871       end
7872 C---------------------------------------------------------------------------
7873       subroutine prodmat3(a1,a2,kk,transp,prod)
7874       implicit none
7875       integer i,j
7876       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7877       logical transp
7878 crc      double precision auxmat(2,2),prod_(2,2)
7879
7880       if (transp) then
7881 crc        call transpose2(kk(1,1),auxmat(1,1))
7882 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7883 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7884
7885            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7886      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7887            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7888      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7889            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7890      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7891            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7892      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7893
7894       else
7895 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7896 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7897
7898            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7899      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7900            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7901      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7902            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7903      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7904            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7905      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7906
7907       endif
7908 c      call transpose2(a2(1,1),a2t(1,1))
7909
7910 crc      print *,transp
7911 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7912 crc      print *,((prod(i,j),i=1,2),j=1,2)
7913
7914       return
7915       end
7916 C-----------------------------------------------------------------------------
7917       double precision function scalar(u,v)
7918       implicit none
7919       double precision u(3),v(3)
7920       double precision sc
7921       integer i
7922       sc=0.0d0
7923       do i=1,3
7924         sc=sc+u(i)*v(i)
7925       enddo
7926       scalar=sc
7927       return
7928       end
7929 C-----------------------------------------------------------------------
7930       double precision function sscale(r)
7931       double precision r,gamm
7932       include "COMMON.SPLITELE"
7933       if(r.lt.r_cut-rlamb) then
7934         sscale=1.0d0
7935       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7936         gamm=(r-(r_cut-rlamb))/rlamb
7937         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
7938       else
7939         sscale=0d0
7940       endif
7941       return
7942       end
7943 C-----------------------------------------------------------------------
7944 C-----------------------------------------------------------------------
7945       double precision function sscagrad(r)
7946       double precision r,gamm
7947       include "COMMON.SPLITELE"
7948       if(r.lt.r_cut-rlamb) then
7949         sscagrad=0.0d0
7950       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7951         gamm=(r-(r_cut-rlamb))/rlamb
7952         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
7953       else
7954         sscagrad=0.0d0
7955       endif
7956       return
7957       end
7958 C-----------------------------------------------------------------------
7959 C-----------------------------------------------------------------------
7960       double precision function sscalelip(r)
7961       double precision r,gamm
7962       include "COMMON.SPLITELE"
7963 C      if(r.lt.r_cut-rlamb) then
7964 C        sscale=1.0d0
7965 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7966 C        gamm=(r-(r_cut-rlamb))/rlamb
7967         sscalelip=1.0d0+r*r*(2*r-3.0d0)
7968 C      else
7969 C        sscale=0d0
7970 C      endif
7971       return
7972       end
7973 C-----------------------------------------------------------------------
7974       double precision function sscagradlip(r)
7975       double precision r,gamm
7976       include "COMMON.SPLITELE"
7977 C     if(r.lt.r_cut-rlamb) then
7978 C        sscagrad=0.0d0
7979 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
7980 C        gamm=(r-(r_cut-rlamb))/rlamb
7981         sscagradlip=r*(6*r-6.0d0)
7982 C      else
7983 C        sscagrad=0.0d0
7984 C      endif
7985       return
7986       end
7987
7988 C-----------------------------------------------------------------------
7989