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