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