source/cluster/wham/src-restraint-MP/energy_p_new.F

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