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