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