source/cluster/wham/src-restraint/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.0d0
 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       include 'DIMENSIONS'
3039
3040       integer nnn, i, j, k, ki, irec, l
3041       integer katy, odleglosci, test7
3042       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3043       real*8 distance(max_template),distancek(max_template),
3044      &    min_odl,godl(max_template),dih_diff(max_template)
3045
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       include 'COMMON.CONTROL'
3055
3056
3057       do i=1,19
3058         distancek(i)=9999999.9
3059       enddo
3060
3061
3062       odleg=0.0d0
3063       write (iout,*) "waga_dist",waga_dist
3064 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3065 c function)
3066 C AL 5/2/14 - Introduce list of restraints
3067       do ii = link_start_homo,link_end_homo
3068          i = ires_homo(ii)
3069          j = jres_homo(ii)
3070          dij=dist(i,j)
3071          do k=1,constr_homology
3072            distance(k)=odl(k,ii)-dij
3073            distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3074          enddo
3075
3076          min_odl=minval(distancek)
3077 #ifdef DEBUG
3078          write (iout,*) "ij dij",i,j,dij
3079          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3080          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3081          write (iout,* )"min_odl",min_odl
3082 #endif
3083          odleg2=0.0d0
3084          do k=1,constr_homology
3085 c Nie wiem po co to liczycie jeszcze raz!
3086 c            odleg3=-waga_dist*((distance(i,j,k)**2)/
3087 c     &              (2*(sigma_odl(i,j,k))**2))
3088             godl(k)=dexp(-distancek(k)+min_odl)
3089             odleg2=odleg2+godl(k)
3090
3091 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3092 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3093 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3094 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3095
3096          enddo
3097 #ifdef DEBUG
3098          write (iout,*) "godl",(godl(k),k=1,constr_homology)
3099          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
3100 #endif
3101          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3102 c Gradient
3103          sum_godl=odleg2
3104          sum_sgodl=0.0
3105          do k=1,constr_homology
3106 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3107 c     &           *waga_dist)+min_odl
3108            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3109            sum_sgodl=sum_sgodl+sgodl
3110
3111 c            sgodl2=sgodl2+sgodl
3112 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3113 c      write(iout,*) "constr_homology=",constr_homology
3114 c      write(iout,*) i, j, k, "TEST K"
3115          enddo
3116
3117          grad_odl3=sum_sgodl/(sum_godl*dij)
3118
3119
3120 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3121 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3122 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3123
3124 ccc      write(iout,*) godl, sgodl, grad_odl3
3125
3126 c          grad_odl=grad_odl+grad_odl3
3127
3128          do jik=1,3
3129             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3130 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3131 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3132 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3133             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3134             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3135 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3136 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3137
3138          enddo
3139 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3140 ccc     & dLOG(odleg2),"-odleg=", -odleg
3141
3142       enddo ! ii
3143 c Pseudo-energy and gradient from dihedral-angle restraints from
3144 c homology templates
3145 c      write (iout,*) "End of distance loop"
3146 c      call flush(iout)
3147       kat=0.0d0
3148 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3149       do i=idihconstr_start_homo,idihconstr_end_homo
3150         kat2=0.0d0
3151 c        betai=beta(i,i+1,i+2,i+3)
3152         betai = phi(i+3)
3153         do k=1,constr_homology
3154           dih_diff(k)=pinorm(dih(k,i)-betai)
3155 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3156 c     &                                   -(6.28318-dih_diff(i,k))
3157 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3158 c     &                                   6.28318+dih_diff(i,k)
3159
3160           kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3161           gdih(k)=dexp(kat3)
3162           kat2=kat2+gdih(k)
3163 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3164 c          write(*,*)""
3165         enddo
3166 #ifdef DEBUG
3167         write (iout,*) "i",i," betai",betai," kat2",kat2
3168         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3169 #endif
3170         if (kat2.le.1.0d-14) cycle
3171         kat=kat-dLOG(kat2/constr_homology)
3172
3173 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3174 ccc     & dLOG(kat2), "-kat=", -kat
3175
3176 c ----------------------------------------------------------------------
3177 c Gradient
3178 c ----------------------------------------------------------------------
3179
3180         sum_gdih=kat2
3181         sum_sgdih=0.0
3182         do k=1,constr_homology
3183           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3184           sum_sgdih=sum_sgdih+sgdih
3185         enddo
3186         grad_dih3=sum_sgdih/sum_gdih
3187
3188 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3189 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3190 ccc     & gloc(nphi+i-3,icg)
3191         gloc(i,icg)=gloc(i,icg)+grad_dih3
3192 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3193 ccc     & gloc(nphi+i-3,icg)
3194
3195       enddo
3196
3197
3198 c Total energy from homology restraints
3199 #ifdef DEBUG
3200       write (iout,*) "odleg",odleg," kat",kat
3201 #endif
3202       ehomology_constr=odleg+kat
3203       return
3204
3205   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
3206   747 format(a12,i4,i4,i4,f8.3,f8.3)
3207   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
3208   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
3209   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
3210      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
3211       end
3212
3213
3214
3215
3216 C--------------------------------------------------------------------------
3217       subroutine ebond(estr)
3218 c
3219 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3220 c
3221       implicit real*8 (a-h,o-z)
3222       include 'DIMENSIONS'
3223       include 'COMMON.LOCAL'
3224       include 'COMMON.GEO'
3225       include 'COMMON.INTERACT'
3226       include 'COMMON.DERIV'
3227       include 'COMMON.VAR'
3228       include 'COMMON.CHAIN'
3229       include 'COMMON.IOUNITS'
3230       include 'COMMON.NAMES'
3231       include 'COMMON.FFIELD'
3232       include 'COMMON.CONTROL'
3233       double precision u(3),ud(3)
3234       estr=0.0d0
3235       do i=nnt+1,nct
3236         diff = vbld(i)-vbldp0
3237 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3238         estr=estr+diff*diff
3239         do j=1,3
3240           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3241         enddo
3242       enddo
3243       estr=0.5d0*AKP*estr
3244 c
3245 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3246 c
3247       do i=nnt,nct
3248         iti=itype(i)
3249         if (iti.ne.10) then
3250           nbi=nbondterm(iti)
3251           if (nbi.eq.1) then
3252             diff=vbld(i+nres)-vbldsc0(1,iti)
3253 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3254 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3255             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3256             do j=1,3
3257               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3258             enddo
3259           else
3260             do j=1,nbi
3261               diff=vbld(i+nres)-vbldsc0(j,iti)
3262               ud(j)=aksc(j,iti)*diff
3263               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3264             enddo
3265             uprod=u(1)
3266             do j=2,nbi
3267               uprod=uprod*u(j)
3268             enddo
3269             usum=0.0d0
3270             usumsqder=0.0d0
3271             do j=1,nbi
3272               uprod1=1.0d0
3273               uprod2=1.0d0
3274               do k=1,nbi
3275                 if (k.ne.j) then
3276                   uprod1=uprod1*u(k)
3277                   uprod2=uprod2*u(k)*u(k)
3278                 endif
3279               enddo
3280               usum=usum+uprod1
3281               usumsqder=usumsqder+ud(j)*uprod2
3282             enddo
3283 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3284 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3285             estr=estr+uprod/usum
3286             do j=1,3
3287              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3288             enddo
3289           endif
3290         endif
3291       enddo
3292       return
3293       end
3294 #ifdef CRYST_THETA
3295 C--------------------------------------------------------------------------
3296       subroutine ebend(etheta)
3297 C
3298 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3299 C angles gamma and its derivatives in consecutive thetas and gammas.
3300 C
3301       implicit real*8 (a-h,o-z)
3302       include 'DIMENSIONS'
3303       include 'sizesclu.dat'
3304       include 'COMMON.LOCAL'
3305       include 'COMMON.GEO'
3306       include 'COMMON.INTERACT'
3307       include 'COMMON.DERIV'
3308       include 'COMMON.VAR'
3309       include 'COMMON.CHAIN'
3310       include 'COMMON.IOUNITS'
3311       include 'COMMON.NAMES'
3312       include 'COMMON.FFIELD'
3313       common /calcthet/ term1,term2,termm,diffak,ratak,
3314      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3315      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3316       double precision y(2),z(2)
3317       delta=0.02d0*pi
3318       time11=dexp(-2*time)
3319       time12=1.0d0
3320       etheta=0.0D0
3321 c      write (iout,*) "nres",nres
3322 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3323 c      write (iout,*) ithet_start,ithet_end
3324       do i=ithet_start,ithet_end
3325 C Zero the energy function and its derivative at 0 or pi.
3326         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3327         it=itype(i-1)
3328 c        if (i.gt.ithet_start .and.
3329 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3330 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3331 c          phii=phi(i)
3332 c          y(1)=dcos(phii)
3333 c          y(2)=dsin(phii)
3334 c        else
3335 c          y(1)=0.0D0
3336 c          y(2)=0.0D0
3337 c        endif
3338 c        if (i.lt.nres .and. itel(i).ne.0) then
3339 c          phii1=phi(i+1)
3340 c          z(1)=dcos(phii1)
3341 c          z(2)=dsin(phii1)
3342 c        else
3343 c          z(1)=0.0D0
3344 c          z(2)=0.0D0
3345 c        endif
3346         if (i.gt.3) then
3347 #ifdef OSF
3348           phii=phi(i)
3349           icrc=0
3350           call proc_proc(phii,icrc)
3351           if (icrc.eq.1) phii=150.0
3352 #else
3353           phii=phi(i)
3354 #endif
3355           y(1)=dcos(phii)
3356           y(2)=dsin(phii)
3357         else
3358           y(1)=0.0D0
3359           y(2)=0.0D0
3360         endif
3361         if (i.lt.nres) then
3362 #ifdef OSF
3363           phii1=phi(i+1)
3364           icrc=0
3365           call proc_proc(phii1,icrc)
3366           if (icrc.eq.1) phii1=150.0
3367           phii1=pinorm(phii1)
3368           z(1)=cos(phii1)
3369 #else
3370           phii1=phi(i+1)
3371           z(1)=dcos(phii1)
3372 #endif
3373           z(2)=dsin(phii1)
3374         else
3375           z(1)=0.0D0
3376           z(2)=0.0D0
3377         endif
3378 C Calculate the "mean" value of theta from the part of the distribution
3379 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3380 C In following comments this theta will be referred to as t_c.
3381         thet_pred_mean=0.0d0
3382         do k=1,2
3383           athetk=athet(k,it)
3384           bthetk=bthet(k,it)
3385           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3386         enddo
3387 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3388         dthett=thet_pred_mean*ssd
3389         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3390 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3391 C Derivatives of the "mean" values in gamma1 and gamma2.
3392         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3393         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3394         if (theta(i).gt.pi-delta) then
3395           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3396      &         E_tc0)
3397           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3398           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3399           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3400      &        E_theta)
3401           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3402      &        E_tc)
3403         else if (theta(i).lt.delta) then
3404           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3405           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3406           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3407      &        E_theta)
3408           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3409           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3410      &        E_tc)
3411         else
3412           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3413      &        E_theta,E_tc)
3414         endif
3415         etheta=etheta+ethetai
3416 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3417 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3418         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3419         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3420         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3421  1215   continue
3422       enddo
3423 C Ufff.... We've done all this!!!
3424       return
3425       end
3426 C---------------------------------------------------------------------------
3427       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3428      &     E_tc)
3429       implicit real*8 (a-h,o-z)
3430       include 'DIMENSIONS'
3431       include 'COMMON.LOCAL'
3432       include 'COMMON.IOUNITS'
3433       common /calcthet/ term1,term2,termm,diffak,ratak,
3434      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3435      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3436 C Calculate the contributions to both Gaussian lobes.
3437 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3438 C The "polynomial part" of the "standard deviation" of this part of
3439 C the distribution.
3440         sig=polthet(3,it)
3441         do j=2,0,-1
3442           sig=sig*thet_pred_mean+polthet(j,it)
3443         enddo
3444 C Derivative of the "interior part" of the "standard deviation of the"
3445 C gamma-dependent Gaussian lobe in t_c.
3446         sigtc=3*polthet(3,it)
3447         do j=2,1,-1
3448           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3449         enddo
3450         sigtc=sig*sigtc
3451 C Set the parameters of both Gaussian lobes of the distribution.
3452 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3453         fac=sig*sig+sigc0(it)
3454         sigcsq=fac+fac
3455         sigc=1.0D0/sigcsq
3456 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3457         sigsqtc=-4.0D0*sigcsq*sigtc
3458 c       print *,i,sig,sigtc,sigsqtc
3459 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3460         sigtc=-sigtc/(fac*fac)
3461 C Following variable is sigma(t_c)**(-2)
3462         sigcsq=sigcsq*sigcsq
3463         sig0i=sig0(it)
3464         sig0inv=1.0D0/sig0i**2
3465         delthec=thetai-thet_pred_mean
3466         delthe0=thetai-theta0i
3467         term1=-0.5D0*sigcsq*delthec*delthec
3468         term2=-0.5D0*sig0inv*delthe0*delthe0
3469 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3470 C NaNs in taking the logarithm. We extract the largest exponent which is added
3471 C to the energy (this being the log of the distribution) at the end of energy
3472 C term evaluation for this virtual-bond angle.
3473         if (term1.gt.term2) then
3474           termm=term1
3475           term2=dexp(term2-termm)
3476           term1=1.0d0
3477         else
3478           termm=term2
3479           term1=dexp(term1-termm)
3480           term2=1.0d0
3481         endif
3482 C The ratio between the gamma-independent and gamma-dependent lobes of
3483 C the distribution is a Gaussian function of thet_pred_mean too.
3484         diffak=gthet(2,it)-thet_pred_mean
3485         ratak=diffak/gthet(3,it)**2
3486         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3487 C Let's differentiate it in thet_pred_mean NOW.
3488         aktc=ak*ratak
3489 C Now put together the distribution terms to make complete distribution.
3490         termexp=term1+ak*term2
3491         termpre=sigc+ak*sig0i
3492 C Contribution of the bending energy from this theta is just the -log of
3493 C the sum of the contributions from the two lobes and the pre-exponential
3494 C factor. Simple enough, isn't it?
3495         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3496 C NOW the derivatives!!!
3497 C 6/6/97 Take into account the deformation.
3498         E_theta=(delthec*sigcsq*term1
3499      &       +ak*delthe0*sig0inv*term2)/termexp
3500         E_tc=((sigtc+aktc*sig0i)/termpre
3501      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3502      &       aktc*term2)/termexp)
3503       return
3504       end
3505 c-----------------------------------------------------------------------------
3506       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3507       implicit real*8 (a-h,o-z)
3508       include 'DIMENSIONS'
3509       include 'COMMON.LOCAL'
3510       include 'COMMON.IOUNITS'
3511       common /calcthet/ term1,term2,termm,diffak,ratak,
3512      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3513      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3514       delthec=thetai-thet_pred_mean
3515       delthe0=thetai-theta0i
3516 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3517       t3 = thetai-thet_pred_mean
3518       t6 = t3**2
3519       t9 = term1
3520       t12 = t3*sigcsq
3521       t14 = t12+t6*sigsqtc
3522       t16 = 1.0d0
3523       t21 = thetai-theta0i
3524       t23 = t21**2
3525       t26 = term2
3526       t27 = t21*t26
3527       t32 = termexp
3528       t40 = t32**2
3529       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3530      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3531      & *(-t12*t9-ak*sig0inv*t27)
3532       return
3533       end
3534 #else
3535 C--------------------------------------------------------------------------
3536       subroutine ebend(etheta)
3537 C
3538 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3539 C angles gamma and its derivatives in consecutive thetas and gammas.
3540 C ab initio-derived potentials from
3541 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3542 C
3543       implicit real*8 (a-h,o-z)
3544       include 'DIMENSIONS'
3545       include 'COMMON.LOCAL'
3546       include 'COMMON.GEO'
3547       include 'COMMON.INTERACT'
3548       include 'COMMON.DERIV'
3549       include 'COMMON.VAR'
3550       include 'COMMON.CHAIN'
3551       include 'COMMON.IOUNITS'
3552       include 'COMMON.NAMES'
3553       include 'COMMON.FFIELD'
3554       include 'COMMON.CONTROL'
3555       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3556      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3557      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3558      & sinph1ph2(maxdouble,maxdouble)
3559       logical lprn /.false./, lprn1 /.false./
3560       etheta=0.0D0
3561 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3562       do i=ithet_start,ithet_end
3563         dethetai=0.0d0
3564         dephii=0.0d0
3565         dephii1=0.0d0
3566         theti2=0.5d0*theta(i)
3567         ityp2=ithetyp(itype(i-1))
3568         do k=1,nntheterm
3569           coskt(k)=dcos(k*theti2)
3570           sinkt(k)=dsin(k*theti2)
3571         enddo
3572         if (i.gt.3) then
3573 #ifdef OSF
3574           phii=phi(i)
3575           if (phii.ne.phii) phii=150.0
3576 #else
3577           phii=phi(i)
3578 #endif
3579           ityp1=ithetyp(itype(i-2))
3580           do k=1,nsingle
3581             cosph1(k)=dcos(k*phii)
3582             sinph1(k)=dsin(k*phii)
3583           enddo
3584         else
3585           phii=0.0d0
3586           ityp1=nthetyp+1
3587           do k=1,nsingle
3588             cosph1(k)=0.0d0
3589             sinph1(k)=0.0d0
3590           enddo
3591         endif
3592         if (i.lt.nres) then
3593 #ifdef OSF
3594           phii1=phi(i+1)
3595           if (phii1.ne.phii1) phii1=150.0
3596           phii1=pinorm(phii1)
3597 #else
3598           phii1=phi(i+1)
3599 #endif
3600           ityp3=ithetyp(itype(i))
3601           do k=1,nsingle
3602             cosph2(k)=dcos(k*phii1)
3603             sinph2(k)=dsin(k*phii1)
3604           enddo
3605         else
3606           phii1=0.0d0
3607           ityp3=nthetyp+1
3608           do k=1,nsingle
3609             cosph2(k)=0.0d0
3610             sinph2(k)=0.0d0
3611           enddo
3612         endif
3613 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3614 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3615 c        call flush(iout)
3616         ethetai=aa0thet(ityp1,ityp2,ityp3)
3617         do k=1,ndouble
3618           do l=1,k-1
3619             ccl=cosph1(l)*cosph2(k-l)
3620             ssl=sinph1(l)*sinph2(k-l)
3621             scl=sinph1(l)*cosph2(k-l)
3622             csl=cosph1(l)*sinph2(k-l)
3623             cosph1ph2(l,k)=ccl-ssl
3624             cosph1ph2(k,l)=ccl+ssl
3625             sinph1ph2(l,k)=scl+csl
3626             sinph1ph2(k,l)=scl-csl
3627           enddo
3628         enddo
3629         if (lprn) then
3630         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3631      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3632         write (iout,*) "coskt and sinkt"
3633         do k=1,nntheterm
3634           write (iout,*) k,coskt(k),sinkt(k)
3635         enddo
3636         endif
3637         do k=1,ntheterm
3638           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3639           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3640      &      *coskt(k)
3641           if (lprn)
3642      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3643      &     " ethetai",ethetai
3644         enddo
3645         if (lprn) then
3646         write (iout,*) "cosph and sinph"
3647         do k=1,nsingle
3648           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3649         enddo
3650         write (iout,*) "cosph1ph2 and sinph2ph2"
3651         do k=2,ndouble
3652           do l=1,k-1
3653             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3654      &         sinph1ph2(l,k),sinph1ph2(k,l)
3655           enddo
3656         enddo
3657         write(iout,*) "ethetai",ethetai
3658         endif
3659         do m=1,ntheterm2
3660           do k=1,nsingle
3661             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3662      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3663      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3664      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3665             ethetai=ethetai+sinkt(m)*aux
3666             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3667             dephii=dephii+k*sinkt(m)*(
3668      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3669      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3670             dephii1=dephii1+k*sinkt(m)*(
3671      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3672      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3673             if (lprn)
3674      &      write (iout,*) "m",m," k",k," bbthet",
3675      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3676      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3677      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3678      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3679           enddo
3680         enddo
3681         if (lprn)
3682      &  write(iout,*) "ethetai",ethetai
3683         do m=1,ntheterm3
3684           do k=2,ndouble
3685             do l=1,k-1
3686               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3687      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3688      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3689      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3690               ethetai=ethetai+sinkt(m)*aux
3691               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3692               dephii=dephii+l*sinkt(m)*(
3693      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3694      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3695      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3696      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3697               dephii1=dephii1+(k-l)*sinkt(m)*(
3698      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3699      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3700      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3701      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3702               if (lprn) then
3703               write (iout,*) "m",m," k",k," l",l," ffthet",
3704      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3705      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3706      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3707      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3708               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3709      &            cosph1ph2(k,l)*sinkt(m),
3710      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3711               endif
3712             enddo
3713           enddo
3714         enddo
3715 10      continue
3716         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3717      &   i,theta(i)*rad2deg,phii*rad2deg,
3718      &   phii1*rad2deg,ethetai
3719         etheta=etheta+ethetai
3720         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3721         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3722         gloc(nphi+i-2,icg)=wang*dethetai
3723       enddo
3724       return
3725       end
3726 #endif
3727 #ifdef CRYST_SC
3728 c-----------------------------------------------------------------------------
3729       subroutine esc(escloc)
3730 C Calculate the local energy of a side chain and its derivatives in the
3731 C corresponding virtual-bond valence angles THETA and the spherical angles
3732 C ALPHA and OMEGA.
3733       implicit real*8 (a-h,o-z)
3734       include 'DIMENSIONS'
3735       include 'sizesclu.dat'
3736       include 'COMMON.GEO'
3737       include 'COMMON.LOCAL'
3738       include 'COMMON.VAR'
3739       include 'COMMON.INTERACT'
3740       include 'COMMON.DERIV'
3741       include 'COMMON.CHAIN'
3742       include 'COMMON.IOUNITS'
3743       include 'COMMON.NAMES'
3744       include 'COMMON.FFIELD'
3745       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3746      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3747       common /sccalc/ time11,time12,time112,theti,it,nlobit
3748       delta=0.02d0*pi
3749       escloc=0.0D0
3750 c     write (iout,'(a)') 'ESC'
3751       do i=loc_start,loc_end
3752         it=itype(i)
3753         if (it.eq.10) goto 1
3754         nlobit=nlob(it)
3755 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3756 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3757         theti=theta(i+1)-pipol
3758         x(1)=dtan(theti)
3759         x(2)=alph(i)
3760         x(3)=omeg(i)
3761 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3762
3763         if (x(2).gt.pi-delta) then
3764           xtemp(1)=x(1)
3765           xtemp(2)=pi-delta
3766           xtemp(3)=x(3)
3767           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3768           xtemp(2)=pi
3769           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3770           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3771      &        escloci,dersc(2))
3772           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3773      &        ddersc0(1),dersc(1))
3774           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3775      &        ddersc0(3),dersc(3))
3776           xtemp(2)=pi-delta
3777           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3778           xtemp(2)=pi
3779           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3780           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3781      &            dersc0(2),esclocbi,dersc02)
3782           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3783      &            dersc12,dersc01)
3784           call splinthet(x(2),0.5d0*delta,ss,ssd)
3785           dersc0(1)=dersc01
3786           dersc0(2)=dersc02
3787           dersc0(3)=0.0d0
3788           do k=1,3
3789             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3790           enddo
3791           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3792 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3793 c    &             esclocbi,ss,ssd
3794           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3795 c         escloci=esclocbi
3796 c         write (iout,*) escloci
3797         else if (x(2).lt.delta) then
3798           xtemp(1)=x(1)
3799           xtemp(2)=delta
3800           xtemp(3)=x(3)
3801           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3802           xtemp(2)=0.0d0
3803           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3804           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3805      &        escloci,dersc(2))
3806           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3807      &        ddersc0(1),dersc(1))
3808           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3809      &        ddersc0(3),dersc(3))
3810           xtemp(2)=delta
3811           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3812           xtemp(2)=0.0d0
3813           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3814           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3815      &            dersc0(2),esclocbi,dersc02)
3816           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3817      &            dersc12,dersc01)
3818           dersc0(1)=dersc01
3819           dersc0(2)=dersc02
3820           dersc0(3)=0.0d0
3821           call splinthet(x(2),0.5d0*delta,ss,ssd)
3822           do k=1,3
3823             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3824           enddo
3825           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3826 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3827 c    &             esclocbi,ss,ssd
3828           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3829 c         write (iout,*) escloci
3830         else
3831           call enesc(x,escloci,dersc,ddummy,.false.)
3832         endif
3833
3834         escloc=escloc+escloci
3835 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3836
3837         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3838      &   wscloc*dersc(1)
3839         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3840         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3841     1   continue
3842       enddo
3843       return
3844       end
3845 C---------------------------------------------------------------------------
3846       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3847       implicit real*8 (a-h,o-z)
3848       include 'DIMENSIONS'
3849       include 'COMMON.GEO'
3850       include 'COMMON.LOCAL'
3851       include 'COMMON.IOUNITS'
3852       common /sccalc/ time11,time12,time112,theti,it,nlobit
3853       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3854       double precision contr(maxlob,-1:1)
3855       logical mixed
3856 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3857         escloc_i=0.0D0
3858         do j=1,3
3859           dersc(j)=0.0D0
3860           if (mixed) ddersc(j)=0.0d0
3861         enddo
3862         x3=x(3)
3863
3864 C Because of periodicity of the dependence of the SC energy in omega we have
3865 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3866 C To avoid underflows, first compute & store the exponents.
3867
3868         do iii=-1,1
3869
3870           x(3)=x3+iii*dwapi
3871
3872           do j=1,nlobit
3873             do k=1,3
3874               z(k)=x(k)-censc(k,j,it)
3875             enddo
3876             do k=1,3
3877               Axk=0.0D0
3878               do l=1,3
3879                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3880               enddo
3881               Ax(k,j,iii)=Axk
3882             enddo
3883             expfac=0.0D0
3884             do k=1,3
3885               expfac=expfac+Ax(k,j,iii)*z(k)
3886             enddo
3887             contr(j,iii)=expfac
3888           enddo ! j
3889
3890         enddo ! iii
3891
3892         x(3)=x3
3893 C As in the case of ebend, we want to avoid underflows in exponentiation and
3894 C subsequent NaNs and INFs in energy calculation.
3895 C Find the largest exponent
3896         emin=contr(1,-1)
3897         do iii=-1,1
3898           do j=1,nlobit
3899             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3900           enddo
3901         enddo
3902         emin=0.5D0*emin
3903 cd      print *,'it=',it,' emin=',emin
3904
3905 C Compute the contribution to SC energy and derivatives
3906         do iii=-1,1
3907
3908           do j=1,nlobit
3909             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3910 cd          print *,'j=',j,' expfac=',expfac
3911             escloc_i=escloc_i+expfac
3912             do k=1,3
3913               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3914             enddo
3915             if (mixed) then
3916               do k=1,3,2
3917                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3918      &            +gaussc(k,2,j,it))*expfac
3919               enddo
3920             endif
3921           enddo
3922
3923         enddo ! iii
3924
3925         dersc(1)=dersc(1)/cos(theti)**2
3926         ddersc(1)=ddersc(1)/cos(theti)**2
3927         ddersc(3)=ddersc(3)
3928
3929         escloci=-(dlog(escloc_i)-emin)
3930         do j=1,3
3931           dersc(j)=dersc(j)/escloc_i
3932         enddo
3933         if (mixed) then
3934           do j=1,3,2
3935             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3936           enddo
3937         endif
3938       return
3939       end
3940 C------------------------------------------------------------------------------
3941       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3942       implicit real*8 (a-h,o-z)
3943       include 'DIMENSIONS'
3944       include 'COMMON.GEO'
3945       include 'COMMON.LOCAL'
3946       include 'COMMON.IOUNITS'
3947       common /sccalc/ time11,time12,time112,theti,it,nlobit
3948       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3949       double precision contr(maxlob)
3950       logical mixed
3951
3952       escloc_i=0.0D0
3953
3954       do j=1,3
3955         dersc(j)=0.0D0
3956       enddo
3957
3958       do j=1,nlobit
3959         do k=1,2
3960           z(k)=x(k)-censc(k,j,it)
3961         enddo
3962         z(3)=dwapi
3963         do k=1,3
3964           Axk=0.0D0
3965           do l=1,3
3966             Axk=Axk+gaussc(l,k,j,it)*z(l)
3967           enddo
3968           Ax(k,j)=Axk
3969         enddo
3970         expfac=0.0D0
3971         do k=1,3
3972           expfac=expfac+Ax(k,j)*z(k)
3973         enddo
3974         contr(j)=expfac
3975       enddo ! j
3976
3977 C As in the case of ebend, we want to avoid underflows in exponentiation and
3978 C subsequent NaNs and INFs in energy calculation.
3979 C Find the largest exponent
3980       emin=contr(1)
3981       do j=1,nlobit
3982         if (emin.gt.contr(j)) emin=contr(j)
3983       enddo
3984       emin=0.5D0*emin
3985
3986 C Compute the contribution to SC energy and derivatives
3987
3988       dersc12=0.0d0
3989       do j=1,nlobit
3990         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
3991         escloc_i=escloc_i+expfac
3992         do k=1,2
3993           dersc(k)=dersc(k)+Ax(k,j)*expfac
3994         enddo
3995         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3996      &            +gaussc(1,2,j,it))*expfac
3997         dersc(3)=0.0d0
3998       enddo
3999
4000       dersc(1)=dersc(1)/cos(theti)**2
4001       dersc12=dersc12/cos(theti)**2
4002       escloci=-(dlog(escloc_i)-emin)
4003       do j=1,2
4004         dersc(j)=dersc(j)/escloc_i
4005       enddo
4006       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4007       return
4008       end
4009 #else
4010 c----------------------------------------------------------------------------------
4011       subroutine esc(escloc)
4012 C Calculate the local energy of a side chain and its derivatives in the
4013 C corresponding virtual-bond valence angles THETA and the spherical angles
4014 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4015 C added by Urszula Kozlowska. 07/11/2007
4016 C
4017       implicit real*8 (a-h,o-z)
4018       include 'DIMENSIONS'
4019       include 'COMMON.GEO'
4020       include 'COMMON.LOCAL'
4021       include 'COMMON.VAR'
4022       include 'COMMON.SCROT'
4023       include 'COMMON.INTERACT'
4024       include 'COMMON.DERIV'
4025       include 'COMMON.CHAIN'
4026       include 'COMMON.IOUNITS'
4027       include 'COMMON.NAMES'
4028       include 'COMMON.FFIELD'
4029       include 'COMMON.CONTROL'
4030       include 'COMMON.VECTORS'
4031       double precision x_prime(3),y_prime(3),z_prime(3)
4032      &    , sumene,dsc_i,dp2_i,x(65),
4033      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4034      &    de_dxx,de_dyy,de_dzz,de_dt
4035       double precision s1_t,s1_6_t,s2_t,s2_6_t
4036       double precision
4037      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4038      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4039      & dt_dCi(3),dt_dCi1(3)
4040       common /sccalc/ time11,time12,time112,theti,it,nlobit
4041       delta=0.02d0*pi
4042       escloc=0.0D0
4043       do i=loc_start,loc_end
4044         costtab(i+1) =dcos(theta(i+1))
4045         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4046         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4047         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4048         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4049         cosfac=dsqrt(cosfac2)
4050         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4051         sinfac=dsqrt(sinfac2)
4052         it=itype(i)
4053         if (it.eq.10) goto 1
4054 c
4055 C  Compute the axes of tghe local cartesian coordinates system; store in
4056 c   x_prime, y_prime and z_prime
4057 c
4058         do j=1,3
4059           x_prime(j) = 0.00
4060           y_prime(j) = 0.00
4061           z_prime(j) = 0.00
4062         enddo
4063 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4064 C     &   dc_norm(3,i+nres)
4065         do j = 1,3
4066           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4067           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4068         enddo
4069         do j = 1,3
4070           z_prime(j) = -uz(j,i-1)
4071         enddo
4072 c       write (2,*) "i",i
4073 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4074 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4075 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4076 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4077 c      & " xy",scalar(x_prime(1),y_prime(1)),
4078 c      & " xz",scalar(x_prime(1),z_prime(1)),
4079 c      & " yy",scalar(y_prime(1),y_prime(1)),
4080 c      & " yz",scalar(y_prime(1),z_prime(1)),
4081 c      & " zz",scalar(z_prime(1),z_prime(1))
4082 c
4083 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4084 C to local coordinate system. Store in xx, yy, zz.
4085 c
4086         xx=0.0d0
4087         yy=0.0d0
4088         zz=0.0d0
4089         do j = 1,3
4090           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4091           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4092           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4093         enddo
4094
4095         xxtab(i)=xx
4096         yytab(i)=yy
4097         zztab(i)=zz
4098 C
4099 C Compute the energy of the ith side cbain
4100 C
4101 c        write (2,*) "xx",xx," yy",yy," zz",zz
4102         it=itype(i)
4103         do j = 1,65
4104           x(j) = sc_parmin(j,it)
4105         enddo
4106 #ifdef CHECK_COORD
4107 Cc diagnostics - remove later
4108         xx1 = dcos(alph(2))
4109         yy1 = dsin(alph(2))*dcos(omeg(2))
4110         zz1 = -dsin(alph(2))*dsin(omeg(2))
4111         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4112      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4113      &    xx1,yy1,zz1
4114 C,"  --- ", xx_w,yy_w,zz_w
4115 c end diagnostics
4116 #endif
4117         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4118      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4119      &   + x(10)*yy*zz
4120         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4121      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4122      & + x(20)*yy*zz
4123         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4124      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4125      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4126      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4127      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4128      &  +x(40)*xx*yy*zz
4129         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4130      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4131      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4132      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4133      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4134      &  +x(60)*xx*yy*zz
4135         dsc_i   = 0.743d0+x(61)
4136         dp2_i   = 1.9d0+x(62)
4137         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4138      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4139         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4140      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4141         s1=(1+x(63))/(0.1d0 + dscp1)
4142         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4143         s2=(1+x(65))/(0.1d0 + dscp2)
4144         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4145         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4146      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4147 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4148 c     &   sumene4,
4149 c     &   dscp1,dscp2,sumene
4150 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4151         escloc = escloc + sumene
4152 c        write (2,*) "escloc",escloc
4153         if (.not. calc_grad) goto 1
4154 #ifdef DEBUG
4155 C
4156 C This section to check the numerical derivatives of the energy of ith side
4157 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4158 C #define DEBUG in the code to turn it on.
4159 C
4160         write (2,*) "sumene               =",sumene
4161         aincr=1.0d-7
4162         xxsave=xx
4163         xx=xx+aincr
4164         write (2,*) xx,yy,zz
4165         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4166         de_dxx_num=(sumenep-sumene)/aincr
4167         xx=xxsave
4168         write (2,*) "xx+ sumene from enesc=",sumenep
4169         yysave=yy
4170         yy=yy+aincr
4171         write (2,*) xx,yy,zz
4172         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4173         de_dyy_num=(sumenep-sumene)/aincr
4174         yy=yysave
4175         write (2,*) "yy+ sumene from enesc=",sumenep
4176         zzsave=zz
4177         zz=zz+aincr
4178         write (2,*) xx,yy,zz
4179         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4180         de_dzz_num=(sumenep-sumene)/aincr
4181         zz=zzsave
4182         write (2,*) "zz+ sumene from enesc=",sumenep
4183         costsave=cost2tab(i+1)
4184         sintsave=sint2tab(i+1)
4185         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4186         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4187         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4188         de_dt_num=(sumenep-sumene)/aincr
4189         write (2,*) " t+ sumene from enesc=",sumenep
4190         cost2tab(i+1)=costsave
4191         sint2tab(i+1)=sintsave
4192 C End of diagnostics section.
4193 #endif
4194 C
4195 C Compute the gradient of esc
4196 C
4197         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4198         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4199         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4200         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4201         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4202         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4203         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4204         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4205         pom1=(sumene3*sint2tab(i+1)+sumene1)
4206      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4207         pom2=(sumene4*cost2tab(i+1)+sumene2)
4208      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4209         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4210         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4211      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4212      &  +x(40)*yy*zz
4213         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4214         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4215      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4216      &  +x(60)*yy*zz
4217         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4218      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4219      &        +(pom1+pom2)*pom_dx
4220 #ifdef DEBUG
4221         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4222 #endif
4223 C
4224         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4225         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4226      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4227      &  +x(40)*xx*zz
4228         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4229         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4230      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4231      &  +x(59)*zz**2 +x(60)*xx*zz
4232         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4233      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4234      &        +(pom1-pom2)*pom_dy
4235 #ifdef DEBUG
4236         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4237 #endif
4238 C
4239         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4240      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4241      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4242      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4243      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4244      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4245      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4246      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4247 #ifdef DEBUG
4248         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4249 #endif
4250 C
4251         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4252      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4253      &  +pom1*pom_dt1+pom2*pom_dt2
4254 #ifdef DEBUG
4255         write(2,*), "de_dt = ", de_dt,de_dt_num
4256 #endif
4257 c
4258 C
4259        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4260        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4261        cosfac2xx=cosfac2*xx
4262        sinfac2yy=sinfac2*yy
4263        do k = 1,3
4264          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4265      &      vbld_inv(i+1)
4266          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4267      &      vbld_inv(i)
4268          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4269          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4270 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4271 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4272 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4273 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4274          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4275          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4276          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4277          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4278          dZZ_Ci1(k)=0.0d0
4279          dZZ_Ci(k)=0.0d0
4280          do j=1,3
4281            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4282            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4283          enddo
4284
4285          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4286          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4287          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4288 c
4289          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4290          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4291        enddo
4292
4293        do k=1,3
4294          dXX_Ctab(k,i)=dXX_Ci(k)
4295          dXX_C1tab(k,i)=dXX_Ci1(k)
4296          dYY_Ctab(k,i)=dYY_Ci(k)
4297          dYY_C1tab(k,i)=dYY_Ci1(k)
4298          dZZ_Ctab(k,i)=dZZ_Ci(k)
4299          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4300          dXX_XYZtab(k,i)=dXX_XYZ(k)
4301          dYY_XYZtab(k,i)=dYY_XYZ(k)
4302          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4303        enddo
4304
4305        do k = 1,3
4306 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4307 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4308 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4309 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4310 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4311 c     &    dt_dci(k)
4312 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4313 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4314          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4315      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4316          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4317      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4318          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4319      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4320        enddo
4321 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4322 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4323
4324 C to check gradient call subroutine check_grad
4325
4326     1 continue
4327       enddo
4328       return
4329       end
4330 #endif
4331 c------------------------------------------------------------------------------
4332       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4333 C
4334 C This procedure calculates two-body contact function g(rij) and its derivative:
4335 C
4336 C           eps0ij                                     !       x < -1
4337 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4338 C            0                                         !       x > 1
4339 C
4340 C where x=(rij-r0ij)/delta
4341 C
4342 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4343 C
4344       implicit none
4345       double precision rij,r0ij,eps0ij,fcont,fprimcont
4346       double precision x,x2,x4,delta
4347 c     delta=0.02D0*r0ij
4348 c      delta=0.2D0*r0ij
4349       x=(rij-r0ij)/delta
4350       if (x.lt.-1.0D0) then
4351         fcont=eps0ij
4352         fprimcont=0.0D0
4353       else if (x.le.1.0D0) then
4354         x2=x*x
4355         x4=x2*x2
4356         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4357         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4358       else
4359         fcont=0.0D0
4360         fprimcont=0.0D0
4361       endif
4362       return
4363       end
4364 c------------------------------------------------------------------------------
4365       subroutine splinthet(theti,delta,ss,ssder)
4366       implicit real*8 (a-h,o-z)
4367       include 'DIMENSIONS'
4368       include 'sizesclu.dat'
4369       include 'COMMON.VAR'
4370       include 'COMMON.GEO'
4371       thetup=pi-delta
4372       thetlow=delta
4373       if (theti.gt.pipol) then
4374         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4375       else
4376         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4377         ssder=-ssder
4378       endif
4379       return
4380       end
4381 c------------------------------------------------------------------------------
4382       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4383       implicit none
4384       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4385       double precision ksi,ksi2,ksi3,a1,a2,a3
4386       a1=fprim0*delta/(f1-f0)
4387       a2=3.0d0-2.0d0*a1
4388       a3=a1-2.0d0
4389       ksi=(x-x0)/delta
4390       ksi2=ksi*ksi
4391       ksi3=ksi2*ksi
4392       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4393       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4394       return
4395       end
4396 c------------------------------------------------------------------------------
4397       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4398       implicit none
4399       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4400       double precision ksi,ksi2,ksi3,a1,a2,a3
4401       ksi=(x-x0)/delta
4402       ksi2=ksi*ksi
4403       ksi3=ksi2*ksi
4404       a1=fprim0x*delta
4405       a2=3*(f1x-f0x)-2*fprim0x*delta
4406       a3=fprim0x*delta-2*(f1x-f0x)
4407       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4408       return
4409       end
4410 C-----------------------------------------------------------------------------
4411 #ifdef CRYST_TOR
4412 C-----------------------------------------------------------------------------
4413       subroutine etor(etors,edihcnstr,fact)
4414       implicit real*8 (a-h,o-z)
4415       include 'DIMENSIONS'
4416       include 'sizesclu.dat'
4417       include 'COMMON.VAR'
4418       include 'COMMON.GEO'
4419       include 'COMMON.LOCAL'
4420       include 'COMMON.TORSION'
4421       include 'COMMON.INTERACT'
4422       include 'COMMON.DERIV'
4423       include 'COMMON.CHAIN'
4424       include 'COMMON.NAMES'
4425       include 'COMMON.IOUNITS'
4426       include 'COMMON.FFIELD'
4427       include 'COMMON.TORCNSTR'
4428       logical lprn
4429 C Set lprn=.true. for debugging
4430       lprn=.false.
4431 c      lprn=.true.
4432       etors=0.0D0
4433       do i=iphi_start,iphi_end
4434         itori=itortyp(itype(i-2))
4435         itori1=itortyp(itype(i-1))
4436         phii=phi(i)
4437         gloci=0.0D0
4438 C Proline-Proline pair is a special case...
4439         if (itori.eq.3 .and. itori1.eq.3) then
4440           if (phii.gt.-dwapi3) then
4441             cosphi=dcos(3*phii)
4442             fac=1.0D0/(1.0D0-cosphi)
4443             etorsi=v1(1,3,3)*fac
4444             etorsi=etorsi+etorsi
4445             etors=etors+etorsi-v1(1,3,3)
4446             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4447           endif
4448           do j=1,3
4449             v1ij=v1(j+1,itori,itori1)
4450             v2ij=v2(j+1,itori,itori1)
4451             cosphi=dcos(j*phii)
4452             sinphi=dsin(j*phii)
4453             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4454             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4455           enddo
4456         else
4457           do j=1,nterm_old
4458             v1ij=v1(j,itori,itori1)
4459             v2ij=v2(j,itori,itori1)
4460             cosphi=dcos(j*phii)
4461             sinphi=dsin(j*phii)
4462             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4463             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4464           enddo
4465         endif
4466         if (lprn)
4467      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4468      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4469      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4470         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4471 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4472       enddo
4473 ! 6/20/98 - dihedral angle constraints
4474       edihcnstr=0.0d0
4475       do i=1,ndih_constr
4476         itori=idih_constr(i)
4477         phii=phi(itori)
4478         difi=pinorm(phii-phi0(i))
4479         if (difi.gt.drange(i)) then
4480           difi=difi-drange(i)
4481           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4482           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4483         else if (difi.lt.-drange(i)) then
4484           difi=difi+drange(i)
4485           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4486           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4487         endif
4488 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4489 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4490       enddo
4491       write (iout,*) 'edihcnstr',edihcnstr
4492       return
4493       end
4494 c------------------------------------------------------------------------------
4495 #else
4496       subroutine etor(etors,edihcnstr,fact)
4497       implicit real*8 (a-h,o-z)
4498       include 'DIMENSIONS'
4499       include 'sizesclu.dat'
4500       include 'COMMON.VAR'
4501       include 'COMMON.GEO'
4502       include 'COMMON.LOCAL'
4503       include 'COMMON.TORSION'
4504       include 'COMMON.INTERACT'
4505       include 'COMMON.DERIV'
4506       include 'COMMON.CHAIN'
4507       include 'COMMON.NAMES'
4508       include 'COMMON.IOUNITS'
4509       include 'COMMON.FFIELD'
4510       include 'COMMON.TORCNSTR'
4511       logical lprn
4512 C Set lprn=.true. for debugging
4513       lprn=.false.
4514 c      lprn=.true.
4515       etors=0.0D0
4516       do i=iphi_start,iphi_end
4517         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4518         itori=itortyp(itype(i-2))
4519         itori1=itortyp(itype(i-1))
4520         phii=phi(i)
4521         gloci=0.0D0
4522 C Regular cosine and sine terms
4523         do j=1,nterm(itori,itori1)
4524           v1ij=v1(j,itori,itori1)
4525           v2ij=v2(j,itori,itori1)
4526           cosphi=dcos(j*phii)
4527           sinphi=dsin(j*phii)
4528           etors=etors+v1ij*cosphi+v2ij*sinphi
4529           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4530         enddo
4531 C Lorentz terms
4532 C                         v1
4533 C  E = SUM ----------------------------------- - v1
4534 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4535 C
4536         cosphi=dcos(0.5d0*phii)
4537         sinphi=dsin(0.5d0*phii)
4538         do j=1,nlor(itori,itori1)
4539           vl1ij=vlor1(j,itori,itori1)
4540           vl2ij=vlor2(j,itori,itori1)
4541           vl3ij=vlor3(j,itori,itori1)
4542           pom=vl2ij*cosphi+vl3ij*sinphi
4543           pom1=1.0d0/(pom*pom+1.0d0)
4544           etors=etors+vl1ij*pom1
4545           pom=-pom*pom1*pom1
4546           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4547         enddo
4548 C Subtract the constant term
4549         etors=etors-v0(itori,itori1)
4550         if (lprn)
4551      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4552      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4553      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4554         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4555 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4556  1215   continue
4557       enddo
4558 ! 6/20/98 - dihedral angle constraints
4559       edihcnstr=0.0d0
4560 c      write (iout,*) "Dihedral angle restraint energy"
4561       do i=1,ndih_constr
4562         itori=idih_constr(i)
4563         phii=phi(itori)
4564         difi=pinorm(phii-phi0(i))
4565 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
4566 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
4567         if (difi.gt.drange(i)) then
4568           difi=difi-drange(i)
4569           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4570           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4571 c          write (iout,*) 0.25d0*ftors*difi**4
4572         else if (difi.lt.-drange(i)) then
4573           difi=difi+drange(i)
4574           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4575           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4576 c          write (iout,*) 0.25d0*ftors*difi**4
4577         endif
4578       enddo
4579 c      write (iout,*) 'edihcnstr',edihcnstr
4580       return
4581       end
4582 c----------------------------------------------------------------------------
4583       subroutine etor_d(etors_d,fact2)
4584 C 6/23/01 Compute double torsional energy
4585       implicit real*8 (a-h,o-z)
4586       include 'DIMENSIONS'
4587       include 'sizesclu.dat'
4588       include 'COMMON.VAR'
4589       include 'COMMON.GEO'
4590       include 'COMMON.LOCAL'
4591       include 'COMMON.TORSION'
4592       include 'COMMON.INTERACT'
4593       include 'COMMON.DERIV'
4594       include 'COMMON.CHAIN'
4595       include 'COMMON.NAMES'
4596       include 'COMMON.IOUNITS'
4597       include 'COMMON.FFIELD'
4598       include 'COMMON.TORCNSTR'
4599       logical lprn
4600 C Set lprn=.true. for debugging
4601       lprn=.false.
4602 c     lprn=.true.
4603       etors_d=0.0D0
4604       do i=iphi_start,iphi_end-1
4605         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4606      &     goto 1215
4607         itori=itortyp(itype(i-2))
4608         itori1=itortyp(itype(i-1))
4609         itori2=itortyp(itype(i))
4610         phii=phi(i)
4611         phii1=phi(i+1)
4612         gloci1=0.0D0
4613         gloci2=0.0D0
4614 C Regular cosine and sine terms
4615         do j=1,ntermd_1(itori,itori1,itori2)
4616           v1cij=v1c(1,j,itori,itori1,itori2)
4617           v1sij=v1s(1,j,itori,itori1,itori2)
4618           v2cij=v1c(2,j,itori,itori1,itori2)
4619           v2sij=v1s(2,j,itori,itori1,itori2)
4620           cosphi1=dcos(j*phii)
4621           sinphi1=dsin(j*phii)
4622           cosphi2=dcos(j*phii1)
4623           sinphi2=dsin(j*phii1)
4624           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4625      &     v2cij*cosphi2+v2sij*sinphi2
4626           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4627           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4628         enddo
4629         do k=2,ntermd_2(itori,itori1,itori2)
4630           do l=1,k-1
4631             v1cdij = v2c(k,l,itori,itori1,itori2)
4632             v2cdij = v2c(l,k,itori,itori1,itori2)
4633             v1sdij = v2s(k,l,itori,itori1,itori2)
4634             v2sdij = v2s(l,k,itori,itori1,itori2)
4635             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4636             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4637             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4638             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4639             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4640      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4641             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4642      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4643             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4644      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4645           enddo
4646         enddo
4647         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4648         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4649  1215   continue
4650       enddo
4651       return
4652       end
4653 #endif
4654 c------------------------------------------------------------------------------
4655       subroutine eback_sc_corr(esccor,fact)
4656 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4657 c        conformational states; temporarily implemented as differences
4658 c        between UNRES torsional potentials (dependent on three types of
4659 c        residues) and the torsional potentials dependent on all 20 types
4660 c        of residues computed from AM1 energy surfaces of terminally-blocked
4661 c        amino-acid residues.
4662       implicit real*8 (a-h,o-z)
4663       include 'DIMENSIONS'
4664       include 'COMMON.VAR'
4665       include 'COMMON.GEO'
4666       include 'COMMON.LOCAL'
4667       include 'COMMON.TORSION'
4668       include 'COMMON.SCCOR'
4669       include 'COMMON.INTERACT'
4670       include 'COMMON.DERIV'
4671       include 'COMMON.CHAIN'
4672       include 'COMMON.NAMES'
4673       include 'COMMON.IOUNITS'
4674       include 'COMMON.FFIELD'
4675       include 'COMMON.CONTROL'
4676       logical lprn
4677 C Set lprn=.true. for debugging
4678       lprn=.false.
4679 c      lprn=.true.
4680 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4681       esccor=0.0D0
4682       do i=itau_start,itau_end
4683         esccor_ii=0.0D0
4684         isccori=isccortyp(itype(i-2))
4685         isccori1=isccortyp(itype(i-1))
4686         phii=phi(i)
4687 cccc  Added 9 May 2012
4688 cc Tauangle is torsional engle depending on the value of first digit
4689 c(see comment below)
4690 cc Omicron is flat angle depending on the value of first digit
4691 c(see comment below)
4692
4693
4694         do intertyp=1,3 !intertyp
4695 cc Added 09 May 2012 (Adasko)
4696 cc  Intertyp means interaction type of backbone mainchain correlation:
4697 c   1 = SC...Ca...Ca...Ca
4698 c   2 = Ca...Ca...Ca...SC
4699 c   3 = SC...Ca...Ca...SCi
4700         gloci=0.0D0
4701         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4702      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
4703      &      (itype(i-1).eq.21)))
4704      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4705      &     .or.(itype(i-2).eq.21)))
4706      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4707      &      (itype(i-1).eq.21)))) cycle
4708         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
4709         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
4710      & cycle
4711         do j=1,nterm_sccor(isccori,isccori1)
4712           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4713           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4714           cosphi=dcos(j*tauangle(intertyp,i))
4715           sinphi=dsin(j*tauangle(intertyp,i))
4716           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4717           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4718         enddo
4719         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4720 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
4721 c     &gloc_sc(intertyp,i-3,icg)
4722         if (lprn)
4723      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4724      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4725      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
4726      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
4727         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4728        enddo !intertyp
4729       enddo
4730
4731       return
4732       end
4733 c------------------------------------------------------------------------------
4734       subroutine multibody(ecorr)
4735 C This subroutine calculates multi-body contributions to energy following
4736 C the idea of Skolnick et al. If side chains I and J make a contact and
4737 C at the same time side chains I+1 and J+1 make a contact, an extra
4738 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4739       implicit real*8 (a-h,o-z)
4740       include 'DIMENSIONS'
4741       include 'COMMON.IOUNITS'
4742       include 'COMMON.DERIV'
4743       include 'COMMON.INTERACT'
4744       include 'COMMON.CONTACTS'
4745       double precision gx(3),gx1(3)
4746       logical lprn
4747
4748 C Set lprn=.true. for debugging
4749       lprn=.false.
4750
4751       if (lprn) then
4752         write (iout,'(a)') 'Contact function values:'
4753         do i=nnt,nct-2
4754           write (iout,'(i2,20(1x,i2,f10.5))')
4755      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4756         enddo
4757       endif
4758       ecorr=0.0D0
4759       do i=nnt,nct
4760         do j=1,3
4761           gradcorr(j,i)=0.0D0
4762           gradxorr(j,i)=0.0D0
4763         enddo
4764       enddo
4765       do i=nnt,nct-2
4766
4767         DO ISHIFT = 3,4
4768
4769         i1=i+ishift
4770         num_conti=num_cont(i)
4771         num_conti1=num_cont(i1)
4772         do jj=1,num_conti
4773           j=jcont(jj,i)
4774           do kk=1,num_conti1
4775             j1=jcont(kk,i1)
4776             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4777 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4778 cd   &                   ' ishift=',ishift
4779 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4780 C The system gains extra energy.
4781               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4782             endif   ! j1==j+-ishift
4783           enddo     ! kk
4784         enddo       ! jj
4785
4786         ENDDO ! ISHIFT
4787
4788       enddo         ! i
4789       return
4790       end
4791 c------------------------------------------------------------------------------
4792       double precision function esccorr(i,j,k,l,jj,kk)
4793       implicit real*8 (a-h,o-z)
4794       include 'DIMENSIONS'
4795       include 'COMMON.IOUNITS'
4796       include 'COMMON.DERIV'
4797       include 'COMMON.INTERACT'
4798       include 'COMMON.CONTACTS'
4799       double precision gx(3),gx1(3)
4800       logical lprn
4801       lprn=.false.
4802       eij=facont(jj,i)
4803       ekl=facont(kk,k)
4804 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4805 C Calculate the multi-body contribution to energy.
4806 C Calculate multi-body contributions to the gradient.
4807 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4808 cd   & k,l,(gacont(m,kk,k),m=1,3)
4809       do m=1,3
4810         gx(m) =ekl*gacont(m,jj,i)
4811         gx1(m)=eij*gacont(m,kk,k)
4812         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4813         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4814         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4815         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4816       enddo
4817       do m=i,j-1
4818         do ll=1,3
4819           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4820         enddo
4821       enddo
4822       do m=k,l-1
4823         do ll=1,3
4824           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4825         enddo
4826       enddo
4827       esccorr=-eij*ekl
4828       return
4829       end
4830 c------------------------------------------------------------------------------
4831 #ifdef MPL
4832       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4833       implicit real*8 (a-h,o-z)
4834       include 'DIMENSIONS'
4835       integer dimen1,dimen2,atom,indx
4836       double precision buffer(dimen1,dimen2)
4837       double precision zapas
4838       common /contacts_hb/ zapas(3,20,maxres,7),
4839      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4840      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4841       num_kont=num_cont_hb(atom)
4842       do i=1,num_kont
4843         do k=1,7
4844           do j=1,3
4845             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4846           enddo ! j
4847         enddo ! k
4848         buffer(i,indx+22)=facont_hb(i,atom)
4849         buffer(i,indx+23)=ees0p(i,atom)
4850         buffer(i,indx+24)=ees0m(i,atom)
4851         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4852       enddo ! i
4853       buffer(1,indx+26)=dfloat(num_kont)
4854       return
4855       end
4856 c------------------------------------------------------------------------------
4857       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4858       implicit real*8 (a-h,o-z)
4859       include 'DIMENSIONS'
4860       integer dimen1,dimen2,atom,indx
4861       double precision buffer(dimen1,dimen2)
4862       double precision zapas
4863       common /contacts_hb/ zapas(3,20,maxres,7),
4864      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4865      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4866       num_kont=buffer(1,indx+26)
4867       num_kont_old=num_cont_hb(atom)
4868       num_cont_hb(atom)=num_kont+num_kont_old
4869       do i=1,num_kont
4870         ii=i+num_kont_old
4871         do k=1,7
4872           do j=1,3
4873             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4874           enddo ! j
4875         enddo ! k
4876         facont_hb(ii,atom)=buffer(i,indx+22)
4877         ees0p(ii,atom)=buffer(i,indx+23)
4878         ees0m(ii,atom)=buffer(i,indx+24)
4879         jcont_hb(ii,atom)=buffer(i,indx+25)
4880       enddo ! i
4881       return
4882       end
4883 c------------------------------------------------------------------------------
4884 #endif
4885       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4886 C This subroutine calculates multi-body contributions to hydrogen-bonding
4887       implicit real*8 (a-h,o-z)
4888       include 'DIMENSIONS'
4889       include 'sizesclu.dat'
4890       include 'COMMON.IOUNITS'
4891 #ifdef MPL
4892       include 'COMMON.INFO'
4893 #endif
4894       include 'COMMON.FFIELD'
4895       include 'COMMON.DERIV'
4896       include 'COMMON.INTERACT'
4897       include 'COMMON.CONTACTS'
4898 #ifdef MPL
4899       parameter (max_cont=maxconts)
4900       parameter (max_dim=2*(8*3+2))
4901       parameter (msglen1=max_cont*max_dim*4)
4902       parameter (msglen2=2*msglen1)
4903       integer source,CorrelType,CorrelID,Error
4904       double precision buffer(max_cont,max_dim)
4905 #endif
4906       double precision gx(3),gx1(3)
4907       logical lprn,ldone
4908
4909 C Set lprn=.true. for debugging
4910       lprn=.false.
4911 #ifdef MPL
4912       n_corr=0
4913       n_corr1=0
4914       if (fgProcs.le.1) goto 30
4915       if (lprn) then
4916         write (iout,'(a)') 'Contact function values:'
4917         do i=nnt,nct-2
4918           write (iout,'(2i3,50(1x,i2,f5.2))')
4919      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4920      &    j=1,num_cont_hb(i))
4921         enddo
4922       endif
4923 C Caution! Following code assumes that electrostatic interactions concerning
4924 C a given atom are split among at most two processors!
4925       CorrelType=477
4926       CorrelID=MyID+1
4927       ldone=.false.
4928       do i=1,max_cont
4929         do j=1,max_dim
4930           buffer(i,j)=0.0D0
4931         enddo
4932       enddo
4933       mm=mod(MyRank,2)
4934 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4935       if (mm) 20,20,10
4936    10 continue
4937 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4938       if (MyRank.gt.0) then
4939 C Send correlation contributions to the preceding processor
4940         msglen=msglen1
4941         nn=num_cont_hb(iatel_s)
4942         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4943 cd      write (iout,*) 'The BUFFER array:'
4944 cd      do i=1,nn
4945 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4946 cd      enddo
4947         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4948           msglen=msglen2
4949             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4950 C Clear the contacts of the atom passed to the neighboring processor
4951         nn=num_cont_hb(iatel_s+1)
4952 cd      do i=1,nn
4953 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4954 cd      enddo
4955             num_cont_hb(iatel_s)=0
4956         endif
4957 cd      write (iout,*) 'Processor ',MyID,MyRank,
4958 cd   & ' is sending correlation contribution to processor',MyID-1,
4959 cd   & ' msglen=',msglen
4960 cd      write (*,*) 'Processor ',MyID,MyRank,
4961 cd   & ' is sending correlation contribution to processor',MyID-1,
4962 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4963         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4964 cd      write (iout,*) 'Processor ',MyID,
4965 cd   & ' has sent correlation contribution to processor',MyID-1,
4966 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4967 cd      write (*,*) 'Processor ',MyID,
4968 cd   & ' has sent correlation contribution to processor',MyID-1,
4969 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4970         msglen=msglen1
4971       endif ! (MyRank.gt.0)
4972       if (ldone) goto 30
4973       ldone=.true.
4974    20 continue
4975 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4976       if (MyRank.lt.fgProcs-1) then
4977 C Receive correlation contributions from the next processor
4978         msglen=msglen1
4979         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4980 cd      write (iout,*) 'Processor',MyID,
4981 cd   & ' is receiving correlation contribution from processor',MyID+1,
4982 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4983 cd      write (*,*) 'Processor',MyID,
4984 cd   & ' is receiving correlation contribution from processor',MyID+1,
4985 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4986         nbytes=-1
4987         do while (nbytes.le.0)
4988           call mp_probe(MyID+1,CorrelType,nbytes)
4989         enddo
4990 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4991         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4992 cd      write (iout,*) 'Processor',MyID,
4993 cd   & ' has received correlation contribution from processor',MyID+1,
4994 cd   & ' msglen=',msglen,' nbytes=',nbytes
4995 cd      write (iout,*) 'The received BUFFER array:'
4996 cd      do i=1,max_cont
4997 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4998 cd      enddo
4999         if (msglen.eq.msglen1) then
5000           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5001         else if (msglen.eq.msglen2)  then
5002           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5003           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5004         else
5005           write (iout,*)
5006      & 'ERROR!!!! message length changed while processing correlations.'
5007           write (*,*)
5008      & 'ERROR!!!! message length changed while processing correlations.'
5009           call mp_stopall(Error)
5010         endif ! msglen.eq.msglen1
5011       endif ! MyRank.lt.fgProcs-1
5012       if (ldone) goto 30
5013       ldone=.true.
5014       goto 10
5015    30 continue
5016 #endif
5017       if (lprn) then
5018         write (iout,'(a)') 'Contact function values:'
5019         do i=nnt,nct-2
5020           write (iout,'(2i3,50(1x,i2,f5.2))')
5021      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5022      &    j=1,num_cont_hb(i))
5023         enddo
5024       endif
5025       ecorr=0.0D0
5026 C Remove the loop below after debugging !!!
5027       do i=nnt,nct
5028         do j=1,3
5029           gradcorr(j,i)=0.0D0
5030           gradxorr(j,i)=0.0D0
5031         enddo
5032       enddo
5033 C Calculate the local-electrostatic correlation terms
5034       do i=iatel_s,iatel_e+1
5035         i1=i+1
5036         num_conti=num_cont_hb(i)
5037         num_conti1=num_cont_hb(i+1)
5038         do jj=1,num_conti
5039           j=jcont_hb(jj,i)
5040           do kk=1,num_conti1
5041             j1=jcont_hb(kk,i1)
5042 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5043 c     &         ' jj=',jj,' kk=',kk
5044             if (j1.eq.j+1 .or. j1.eq.j-1) then
5045 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5046 C The system gains extra energy.
5047               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5048               n_corr=n_corr+1
5049             else if (j1.eq.j) then
5050 C Contacts I-J and I-(J+1) occur simultaneously.
5051 C The system loses extra energy.
5052 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5053             endif
5054           enddo ! kk
5055           do kk=1,num_conti
5056             j1=jcont_hb(kk,i)
5057 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5058 c    &         ' jj=',jj,' kk=',kk
5059             if (j1.eq.j+1) then
5060 C Contacts I-J and (I+1)-J occur simultaneously.
5061 C The system loses extra energy.
5062 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5063             endif ! j1==j+1
5064           enddo ! kk
5065         enddo ! jj
5066       enddo ! i
5067       return
5068       end
5069 c------------------------------------------------------------------------------
5070       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5071      &  n_corr1)
5072 C This subroutine calculates multi-body contributions to hydrogen-bonding
5073       implicit real*8 (a-h,o-z)
5074       include 'DIMENSIONS'
5075       include 'sizesclu.dat'
5076       include 'COMMON.IOUNITS'
5077 #ifdef MPL
5078       include 'COMMON.INFO'
5079 #endif
5080       include 'COMMON.FFIELD'
5081       include 'COMMON.DERIV'
5082       include 'COMMON.INTERACT'
5083       include 'COMMON.CONTACTS'
5084 #ifdef MPL
5085       parameter (max_cont=maxconts)
5086       parameter (max_dim=2*(8*3+2))
5087       parameter (msglen1=max_cont*max_dim*4)
5088       parameter (msglen2=2*msglen1)
5089       integer source,CorrelType,CorrelID,Error
5090       double precision buffer(max_cont,max_dim)
5091 #endif
5092       double precision gx(3),gx1(3)
5093       logical lprn,ldone
5094
5095 C Set lprn=.true. for debugging
5096       lprn=.false.
5097       eturn6=0.0d0
5098       ecorr6=0.0d0
5099 #ifdef MPL
5100       n_corr=0
5101       n_corr1=0
5102       if (fgProcs.le.1) goto 30
5103       if (lprn) then
5104         write (iout,'(a)') 'Contact function values:'
5105         do i=nnt,nct-2
5106           write (iout,'(2i3,50(1x,i2,f5.2))')
5107      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5108      &    j=1,num_cont_hb(i))
5109         enddo
5110       endif
5111 C Caution! Following code assumes that electrostatic interactions concerning
5112 C a given atom are split among at most two processors!
5113       CorrelType=477
5114       CorrelID=MyID+1
5115       ldone=.false.
5116       do i=1,max_cont
5117         do j=1,max_dim
5118           buffer(i,j)=0.0D0
5119         enddo
5120       enddo
5121       mm=mod(MyRank,2)
5122 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5123       if (mm) 20,20,10
5124    10 continue
5125 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5126       if (MyRank.gt.0) then
5127 C Send correlation contributions to the preceding processor
5128         msglen=msglen1
5129         nn=num_cont_hb(iatel_s)
5130         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5131 cd      write (iout,*) 'The BUFFER array:'
5132 cd      do i=1,nn
5133 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5134 cd      enddo
5135         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5136           msglen=msglen2
5137             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5138 C Clear the contacts of the atom passed to the neighboring processor
5139         nn=num_cont_hb(iatel_s+1)
5140 cd      do i=1,nn
5141 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5142 cd      enddo
5143             num_cont_hb(iatel_s)=0
5144         endif
5145 cd      write (iout,*) 'Processor ',MyID,MyRank,
5146 cd   & ' is sending correlation contribution to processor',MyID-1,
5147 cd   & ' msglen=',msglen
5148 cd      write (*,*) 'Processor ',MyID,MyRank,
5149 cd   & ' is sending correlation contribution to processor',MyID-1,
5150 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5151         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5152 cd      write (iout,*) 'Processor ',MyID,
5153 cd   & ' has sent correlation contribution to processor',MyID-1,
5154 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5155 cd      write (*,*) 'Processor ',MyID,
5156 cd   & ' has sent correlation contribution to processor',MyID-1,
5157 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5158         msglen=msglen1
5159       endif ! (MyRank.gt.0)
5160       if (ldone) goto 30
5161       ldone=.true.
5162    20 continue
5163 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5164       if (MyRank.lt.fgProcs-1) then
5165 C Receive correlation contributions from the next processor
5166         msglen=msglen1
5167         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5168 cd      write (iout,*) 'Processor',MyID,
5169 cd   & ' is receiving correlation contribution from processor',MyID+1,
5170 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5171 cd      write (*,*) 'Processor',MyID,
5172 cd   & ' is receiving correlation contribution from processor',MyID+1,
5173 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5174         nbytes=-1
5175         do while (nbytes.le.0)
5176           call mp_probe(MyID+1,CorrelType,nbytes)
5177         enddo
5178 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5179         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5180 cd      write (iout,*) 'Processor',MyID,
5181 cd   & ' has received correlation contribution from processor',MyID+1,
5182 cd   & ' msglen=',msglen,' nbytes=',nbytes
5183 cd      write (iout,*) 'The received BUFFER array:'
5184 cd      do i=1,max_cont
5185 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5186 cd      enddo
5187         if (msglen.eq.msglen1) then
5188           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5189         else if (msglen.eq.msglen2)  then
5190           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5191           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5192         else
5193           write (iout,*)
5194      & 'ERROR!!!! message length changed while processing correlations.'
5195           write (*,*)
5196      & 'ERROR!!!! message length changed while processing correlations.'
5197           call mp_stopall(Error)
5198         endif ! msglen.eq.msglen1
5199       endif ! MyRank.lt.fgProcs-1
5200       if (ldone) goto 30
5201       ldone=.true.
5202       goto 10
5203    30 continue
5204 #endif
5205       if (lprn) then
5206         write (iout,'(a)') 'Contact function values:'
5207         do i=nnt,nct-2
5208           write (iout,'(2i3,50(1x,i2,f5.2))')
5209      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5210      &    j=1,num_cont_hb(i))
5211         enddo
5212       endif
5213       ecorr=0.0D0
5214       ecorr5=0.0d0
5215       ecorr6=0.0d0
5216 C Remove the loop below after debugging !!!
5217       do i=nnt,nct
5218         do j=1,3
5219           gradcorr(j,i)=0.0D0
5220           gradxorr(j,i)=0.0D0
5221         enddo
5222       enddo
5223 C Calculate the dipole-dipole interaction energies
5224       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5225       do i=iatel_s,iatel_e+1
5226         num_conti=num_cont_hb(i)
5227         do jj=1,num_conti
5228           j=jcont_hb(jj,i)
5229           call dipole(i,j,jj)
5230         enddo
5231       enddo
5232       endif
5233 C Calculate the local-electrostatic correlation terms
5234       do i=iatel_s,iatel_e+1
5235         i1=i+1
5236         num_conti=num_cont_hb(i)
5237         num_conti1=num_cont_hb(i+1)
5238         do jj=1,num_conti
5239           j=jcont_hb(jj,i)
5240           do kk=1,num_conti1
5241             j1=jcont_hb(kk,i1)
5242 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5243 c     &         ' jj=',jj,' kk=',kk
5244             if (j1.eq.j+1 .or. j1.eq.j-1) then
5245 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5246 C The system gains extra energy.
5247               n_corr=n_corr+1
5248               sqd1=dsqrt(d_cont(jj,i))
5249               sqd2=dsqrt(d_cont(kk,i1))
5250               sred_geom = sqd1*sqd2
5251               IF (sred_geom.lt.cutoff_corr) THEN
5252                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5253      &            ekont,fprimcont)
5254 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5255 c     &         ' jj=',jj,' kk=',kk
5256                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5257                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5258                 do l=1,3
5259                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5260                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5261                 enddo
5262                 n_corr1=n_corr1+1
5263 cd               write (iout,*) 'sred_geom=',sred_geom,
5264 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5265                 call calc_eello(i,j,i+1,j1,jj,kk)
5266                 if (wcorr4.gt.0.0d0)
5267      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5268                 if (wcorr5.gt.0.0d0)
5269      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5270 c                print *,"wcorr5",ecorr5
5271 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5272 cd                write(2,*)'ijkl',i,j,i+1,j1
5273                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5274      &               .or. wturn6.eq.0.0d0))then
5275 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5276 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5277 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5278 c     &            'ecorr6=',ecorr6, wcorr6
5279 cd                write (iout,'(4e15.5)') sred_geom,
5280 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5281 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5282 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5283                 else if (wturn6.gt.0.0d0
5284      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5285 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5286                   eturn6=eturn6+eello_turn6(i,jj,kk)
5287 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5288                 endif
5289               ENDIF
5290 1111          continue
5291             else if (j1.eq.j) then
5292 C Contacts I-J and I-(J+1) occur simultaneously.
5293 C The system loses extra energy.
5294 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5295             endif
5296           enddo ! kk
5297           do kk=1,num_conti
5298             j1=jcont_hb(kk,i)
5299 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5300 c    &         ' jj=',jj,' kk=',kk
5301             if (j1.eq.j+1) then
5302 C Contacts I-J and (I+1)-J occur simultaneously.
5303 C The system loses extra energy.
5304 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5305             endif ! j1==j+1
5306           enddo ! kk
5307         enddo ! jj
5308       enddo ! i
5309       return
5310       end
5311 c------------------------------------------------------------------------------
5312       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5313       implicit real*8 (a-h,o-z)
5314       include 'DIMENSIONS'
5315       include 'COMMON.IOUNITS'
5316       include 'COMMON.DERIV'
5317       include 'COMMON.INTERACT'
5318       include 'COMMON.CONTACTS'
5319       double precision gx(3),gx1(3)
5320       logical lprn
5321       lprn=.false.
5322       eij=facont_hb(jj,i)
5323       ekl=facont_hb(kk,k)
5324       ees0pij=ees0p(jj,i)
5325       ees0pkl=ees0p(kk,k)
5326       ees0mij=ees0m(jj,i)
5327       ees0mkl=ees0m(kk,k)
5328       ekont=eij*ekl
5329       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5330 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5331 C Following 4 lines for diagnostics.
5332 cd    ees0pkl=0.0D0
5333 cd    ees0pij=1.0D0
5334 cd    ees0mkl=0.0D0
5335 cd    ees0mij=1.0D0
5336 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5337 c    &   ' and',k,l
5338 c     write (iout,*)'Contacts have occurred for peptide groups',
5339 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5340 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5341 C Calculate the multi-body contribution to energy.
5342       ecorr=ecorr+ekont*ees
5343       if (calc_grad) then
5344 C Calculate multi-body contributions to the gradient.
5345       do ll=1,3
5346         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5347         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5348      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5349      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5350         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5351      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5352      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5353         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5354         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5355      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5356      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5357         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5358      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5359      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5360       enddo
5361       do m=i+1,j-1
5362         do ll=1,3
5363           gradcorr(ll,m)=gradcorr(ll,m)+
5364      &     ees*ekl*gacont_hbr(ll,jj,i)-
5365      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5366      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5367         enddo
5368       enddo
5369       do m=k+1,l-1
5370         do ll=1,3
5371           gradcorr(ll,m)=gradcorr(ll,m)+
5372      &     ees*eij*gacont_hbr(ll,kk,k)-
5373      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5374      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5375         enddo
5376       enddo
5377       endif
5378       ehbcorr=ekont*ees
5379       return
5380       end
5381 C---------------------------------------------------------------------------
5382       subroutine dipole(i,j,jj)
5383       implicit real*8 (a-h,o-z)
5384       include 'DIMENSIONS'
5385       include 'sizesclu.dat'
5386       include 'COMMON.IOUNITS'
5387       include 'COMMON.CHAIN'
5388       include 'COMMON.FFIELD'
5389       include 'COMMON.DERIV'
5390       include 'COMMON.INTERACT'
5391       include 'COMMON.CONTACTS'
5392       include 'COMMON.TORSION'
5393       include 'COMMON.VAR'
5394       include 'COMMON.GEO'
5395       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5396      &  auxmat(2,2)
5397       iti1 = itortyp(itype(i+1))
5398       if (j.lt.nres-1) then
5399         itj1 = itortyp(itype(j+1))
5400       else
5401         itj1=ntortyp+1
5402       endif
5403       do iii=1,2
5404         dipi(iii,1)=Ub2(iii,i)
5405         dipderi(iii)=Ub2der(iii,i)
5406         dipi(iii,2)=b1(iii,iti1)
5407         dipj(iii,1)=Ub2(iii,j)
5408         dipderj(iii)=Ub2der(iii,j)
5409         dipj(iii,2)=b1(iii,itj1)
5410       enddo
5411       kkk=0
5412       do iii=1,2
5413         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5414         do jjj=1,2
5415           kkk=kkk+1
5416           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5417         enddo
5418       enddo
5419       if (.not.calc_grad) return
5420       do kkk=1,5
5421         do lll=1,3
5422           mmm=0
5423           do iii=1,2
5424             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5425      &        auxvec(1))
5426             do jjj=1,2
5427               mmm=mmm+1
5428               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5429             enddo
5430           enddo
5431         enddo
5432       enddo
5433       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5434       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5435       do iii=1,2
5436         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5437       enddo
5438       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5439       do iii=1,2
5440         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5441       enddo
5442       return
5443       end
5444 C---------------------------------------------------------------------------
5445       subroutine calc_eello(i,j,k,l,jj,kk)
5446 C
5447 C This subroutine computes matrices and vectors needed to calculate
5448 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5449 C
5450       implicit real*8 (a-h,o-z)
5451       include 'DIMENSIONS'
5452       include 'sizesclu.dat'
5453       include 'COMMON.IOUNITS'
5454       include 'COMMON.CHAIN'
5455       include 'COMMON.DERIV'
5456       include 'COMMON.INTERACT'
5457       include 'COMMON.CONTACTS'
5458       include 'COMMON.TORSION'
5459       include 'COMMON.VAR'
5460       include 'COMMON.GEO'
5461       include 'COMMON.FFIELD'
5462       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5463      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5464       logical lprn
5465       common /kutas/ lprn
5466 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5467 cd     & ' jj=',jj,' kk=',kk
5468 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5469       do iii=1,2
5470         do jjj=1,2
5471           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5472           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5473         enddo
5474       enddo
5475       call transpose2(aa1(1,1),aa1t(1,1))
5476       call transpose2(aa2(1,1),aa2t(1,1))
5477       do kkk=1,5
5478         do lll=1,3
5479           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5480      &      aa1tder(1,1,lll,kkk))
5481           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5482      &      aa2tder(1,1,lll,kkk))
5483         enddo
5484       enddo
5485       if (l.eq.j+1) then
5486 C parallel orientation of the two CA-CA-CA frames.
5487         if (i.gt.1) then
5488           iti=itortyp(itype(i))
5489         else
5490           iti=ntortyp+1
5491         endif
5492         itk1=itortyp(itype(k+1))
5493         itj=itortyp(itype(j))
5494         if (l.lt.nres-1) then
5495           itl1=itortyp(itype(l+1))
5496         else
5497           itl1=ntortyp+1
5498         endif
5499 C A1 kernel(j+1) A2T
5500 cd        do iii=1,2
5501 cd          write (iout,'(3f10.5,5x,3f10.5)')
5502 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5503 cd        enddo
5504         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5505      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5506      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5507 C Following matrices are needed only for 6-th order cumulants
5508         IF (wcorr6.gt.0.0d0) THEN
5509         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5510      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5511      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5512         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5513      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5514      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5515      &   ADtEAderx(1,1,1,1,1,1))
5516         lprn=.false.
5517         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5518      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5519      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5520      &   ADtEA1derx(1,1,1,1,1,1))
5521         ENDIF
5522 C End 6-th order cumulants
5523 cd        lprn=.false.
5524 cd        if (lprn) then
5525 cd        write (2,*) 'In calc_eello6'
5526 cd        do iii=1,2
5527 cd          write (2,*) 'iii=',iii
5528 cd          do kkk=1,5
5529 cd            write (2,*) 'kkk=',kkk
5530 cd            do jjj=1,2
5531 cd              write (2,'(3(2f10.5),5x)')
5532 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5533 cd            enddo
5534 cd          enddo
5535 cd        enddo
5536 cd        endif
5537         call transpose2(EUgder(1,1,k),auxmat(1,1))
5538         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5539         call transpose2(EUg(1,1,k),auxmat(1,1))
5540         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5541         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5542         do iii=1,2
5543           do kkk=1,5
5544             do lll=1,3
5545               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5546      &          EAEAderx(1,1,lll,kkk,iii,1))
5547             enddo
5548           enddo
5549         enddo
5550 C A1T kernel(i+1) A2
5551         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5552      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5553      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5554 C Following matrices are needed only for 6-th order cumulants
5555         IF (wcorr6.gt.0.0d0) THEN
5556         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5557      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5558      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5559         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5560      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5561      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5562      &   ADtEAderx(1,1,1,1,1,2))
5563         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5564      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5565      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5566      &   ADtEA1derx(1,1,1,1,1,2))
5567         ENDIF
5568 C End 6-th order cumulants
5569         call transpose2(EUgder(1,1,l),auxmat(1,1))
5570         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5571         call transpose2(EUg(1,1,l),auxmat(1,1))
5572         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5573         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5574         do iii=1,2
5575           do kkk=1,5
5576             do lll=1,3
5577               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5578      &          EAEAderx(1,1,lll,kkk,iii,2))
5579             enddo
5580           enddo
5581         enddo
5582 C AEAb1 and AEAb2
5583 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5584 C They are needed only when the fifth- or the sixth-order cumulants are
5585 C indluded.
5586         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5587         call transpose2(AEA(1,1,1),auxmat(1,1))
5588         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5589         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5590         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5591         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5592         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5593         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5594         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5595         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5596         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5597         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5598         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5599         call transpose2(AEA(1,1,2),auxmat(1,1))
5600         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5601         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5602         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5603         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5604         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5605         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5606         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5607         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5608         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5609         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5610         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5611 C Calculate the Cartesian derivatives of the vectors.
5612         do iii=1,2
5613           do kkk=1,5
5614             do lll=1,3
5615               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5616               call matvec2(auxmat(1,1),b1(1,iti),
5617      &          AEAb1derx(1,lll,kkk,iii,1,1))
5618               call matvec2(auxmat(1,1),Ub2(1,i),
5619      &          AEAb2derx(1,lll,kkk,iii,1,1))
5620               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5621      &          AEAb1derx(1,lll,kkk,iii,2,1))
5622               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5623      &          AEAb2derx(1,lll,kkk,iii,2,1))
5624               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5625               call matvec2(auxmat(1,1),b1(1,itj),
5626      &          AEAb1derx(1,lll,kkk,iii,1,2))
5627               call matvec2(auxmat(1,1),Ub2(1,j),
5628      &          AEAb2derx(1,lll,kkk,iii,1,2))
5629               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5630      &          AEAb1derx(1,lll,kkk,iii,2,2))
5631               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5632      &          AEAb2derx(1,lll,kkk,iii,2,2))
5633             enddo
5634           enddo
5635         enddo
5636         ENDIF
5637 C End vectors
5638       else
5639 C Antiparallel orientation of the two CA-CA-CA frames.
5640         if (i.gt.1) then
5641           iti=itortyp(itype(i))
5642         else
5643           iti=ntortyp+1
5644         endif
5645         itk1=itortyp(itype(k+1))
5646         itl=itortyp(itype(l))
5647         itj=itortyp(itype(j))
5648         if (j.lt.nres-1) then
5649           itj1=itortyp(itype(j+1))
5650         else
5651           itj1=ntortyp+1
5652         endif
5653 C A2 kernel(j-1)T A1T
5654         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5655      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5656      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5657 C Following matrices are needed only for 6-th order cumulants
5658         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5659      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5660         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5661      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5662      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5663         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5664      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5665      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5666      &   ADtEAderx(1,1,1,1,1,1))
5667         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5668      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5669      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5670      &   ADtEA1derx(1,1,1,1,1,1))
5671         ENDIF
5672 C End 6-th order cumulants
5673         call transpose2(EUgder(1,1,k),auxmat(1,1))
5674         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5675         call transpose2(EUg(1,1,k),auxmat(1,1))
5676         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5677         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5678         do iii=1,2
5679           do kkk=1,5
5680             do lll=1,3
5681               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5682      &          EAEAderx(1,1,lll,kkk,iii,1))
5683             enddo
5684           enddo
5685         enddo
5686 C A2T kernel(i+1)T A1
5687         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5688      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5689      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5690 C Following matrices are needed only for 6-th order cumulants
5691         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5692      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5693         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5694      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5695      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5696         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5697      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5698      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5699      &   ADtEAderx(1,1,1,1,1,2))
5700         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5701      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5702      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5703      &   ADtEA1derx(1,1,1,1,1,2))
5704         ENDIF
5705 C End 6-th order cumulants
5706         call transpose2(EUgder(1,1,j),auxmat(1,1))
5707         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5708         call transpose2(EUg(1,1,j),auxmat(1,1))
5709         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5710         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5711         do iii=1,2
5712           do kkk=1,5
5713             do lll=1,3
5714               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5715      &          EAEAderx(1,1,lll,kkk,iii,2))
5716             enddo
5717           enddo
5718         enddo
5719 C AEAb1 and AEAb2
5720 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5721 C They are needed only when the fifth- or the sixth-order cumulants are
5722 C indluded.
5723         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5724      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5725         call transpose2(AEA(1,1,1),auxmat(1,1))
5726         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5727         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5728         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5729         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5730         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5731         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5732         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5733         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5734         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5735         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5736         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5737         call transpose2(AEA(1,1,2),auxmat(1,1))
5738         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5739         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5740         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5741         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5742         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5743         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5744         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5745         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5746         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5747         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5748         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5749 C Calculate the Cartesian derivatives of the vectors.
5750         do iii=1,2
5751           do kkk=1,5
5752             do lll=1,3
5753               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5754               call matvec2(auxmat(1,1),b1(1,iti),
5755      &          AEAb1derx(1,lll,kkk,iii,1,1))
5756               call matvec2(auxmat(1,1),Ub2(1,i),
5757      &          AEAb2derx(1,lll,kkk,iii,1,1))
5758               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5759      &          AEAb1derx(1,lll,kkk,iii,2,1))
5760               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5761      &          AEAb2derx(1,lll,kkk,iii,2,1))
5762               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5763               call matvec2(auxmat(1,1),b1(1,itl),
5764      &          AEAb1derx(1,lll,kkk,iii,1,2))
5765               call matvec2(auxmat(1,1),Ub2(1,l),
5766      &          AEAb2derx(1,lll,kkk,iii,1,2))
5767               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5768      &          AEAb1derx(1,lll,kkk,iii,2,2))
5769               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5770      &          AEAb2derx(1,lll,kkk,iii,2,2))
5771             enddo
5772           enddo
5773         enddo
5774         ENDIF
5775 C End vectors
5776       endif
5777       return
5778       end
5779 C---------------------------------------------------------------------------
5780       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5781      &  KK,KKderg,AKA,AKAderg,AKAderx)
5782       implicit none
5783       integer nderg
5784       logical transp
5785       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5786      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5787      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5788       integer iii,kkk,lll
5789       integer jjj,mmm
5790       logical lprn
5791       common /kutas/ lprn
5792       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5793       do iii=1,nderg
5794         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5795      &    AKAderg(1,1,iii))
5796       enddo
5797 cd      if (lprn) write (2,*) 'In kernel'
5798       do kkk=1,5
5799 cd        if (lprn) write (2,*) 'kkk=',kkk
5800         do lll=1,3
5801           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5802      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5803 cd          if (lprn) then
5804 cd            write (2,*) 'lll=',lll
5805 cd            write (2,*) 'iii=1'
5806 cd            do jjj=1,2
5807 cd              write (2,'(3(2f10.5),5x)')
5808 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5809 cd            enddo
5810 cd          endif
5811           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5812      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5813 cd          if (lprn) then
5814 cd            write (2,*) 'lll=',lll
5815 cd            write (2,*) 'iii=2'
5816 cd            do jjj=1,2
5817 cd              write (2,'(3(2f10.5),5x)')
5818 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5819 cd            enddo
5820 cd          endif
5821         enddo
5822       enddo
5823       return
5824       end
5825 C---------------------------------------------------------------------------
5826       double precision function eello4(i,j,k,l,jj,kk)
5827       implicit real*8 (a-h,o-z)
5828       include 'DIMENSIONS'
5829       include 'sizesclu.dat'
5830       include 'COMMON.IOUNITS'
5831       include 'COMMON.CHAIN'
5832       include 'COMMON.DERIV'
5833       include 'COMMON.INTERACT'
5834       include 'COMMON.CONTACTS'
5835       include 'COMMON.TORSION'
5836       include 'COMMON.VAR'
5837       include 'COMMON.GEO'
5838       double precision pizda(2,2),ggg1(3),ggg2(3)
5839 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5840 cd        eello4=0.0d0
5841 cd        return
5842 cd      endif
5843 cd      print *,'eello4:',i,j,k,l,jj,kk
5844 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5845 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5846 cold      eij=facont_hb(jj,i)
5847 cold      ekl=facont_hb(kk,k)
5848 cold      ekont=eij*ekl
5849       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5850       if (calc_grad) then
5851 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5852       gcorr_loc(k-1)=gcorr_loc(k-1)
5853      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5854       if (l.eq.j+1) then
5855         gcorr_loc(l-1)=gcorr_loc(l-1)
5856      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5857       else
5858         gcorr_loc(j-1)=gcorr_loc(j-1)
5859      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5860       endif
5861       do iii=1,2
5862         do kkk=1,5
5863           do lll=1,3
5864             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5865      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5866 cd            derx(lll,kkk,iii)=0.0d0
5867           enddo
5868         enddo
5869       enddo
5870 cd      gcorr_loc(l-1)=0.0d0
5871 cd      gcorr_loc(j-1)=0.0d0
5872 cd      gcorr_loc(k-1)=0.0d0
5873 cd      eel4=1.0d0
5874 cd      write (iout,*)'Contacts have occurred for peptide groups',
5875 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5876 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5877       if (j.lt.nres-1) then
5878         j1=j+1
5879         j2=j-1
5880       else
5881         j1=j-1
5882         j2=j-2
5883       endif
5884       if (l.lt.nres-1) then
5885         l1=l+1
5886         l2=l-1
5887       else
5888         l1=l-1
5889         l2=l-2
5890       endif
5891       do ll=1,3
5892 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5893         ggg1(ll)=eel4*g_contij(ll,1)
5894         ggg2(ll)=eel4*g_contij(ll,2)
5895         ghalf=0.5d0*ggg1(ll)
5896 cd        ghalf=0.0d0
5897         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5898         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5899         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5900         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5901 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5902         ghalf=0.5d0*ggg2(ll)
5903 cd        ghalf=0.0d0
5904         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5905         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5906         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5907         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5908       enddo
5909 cd      goto 1112
5910       do m=i+1,j-1
5911         do ll=1,3
5912 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5913           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5914         enddo
5915       enddo
5916       do m=k+1,l-1
5917         do ll=1,3
5918 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5919           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5920         enddo
5921       enddo
5922 1112  continue
5923       do m=i+2,j2
5924         do ll=1,3
5925           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5926         enddo
5927       enddo
5928       do m=k+2,l2
5929         do ll=1,3
5930           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5931         enddo
5932       enddo
5933 cd      do iii=1,nres-3
5934 cd        write (2,*) iii,gcorr_loc(iii)
5935 cd      enddo
5936       endif
5937       eello4=ekont*eel4
5938 cd      write (2,*) 'ekont',ekont
5939 cd      write (iout,*) 'eello4',ekont*eel4
5940       return
5941       end
5942 C---------------------------------------------------------------------------
5943       double precision function eello5(i,j,k,l,jj,kk)
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'sizesclu.dat'
5947       include 'COMMON.IOUNITS'
5948       include 'COMMON.CHAIN'
5949       include 'COMMON.DERIV'
5950       include 'COMMON.INTERACT'
5951       include 'COMMON.CONTACTS'
5952       include 'COMMON.TORSION'
5953       include 'COMMON.VAR'
5954       include 'COMMON.GEO'
5955       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5956       double precision ggg1(3),ggg2(3)
5957 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5958 C                                                                              C
5959 C                            Parallel chains                                   C
5960 C                                                                              C
5961 C          o             o                   o             o                   C
5962 C         /l\           / \             \   / \           / \   /              C
5963 C        /   \         /   \             \ /   \         /   \ /               C
5964 C       j| o |l1       | o |              o| o |         | o |o                C
5965 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5966 C      \i/   \         /   \ /             /   \         /   \                 C
5967 C       o    k1             o                                                  C
5968 C         (I)          (II)                (III)          (IV)                 C
5969 C                                                                              C
5970 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5971 C                                                                              C
5972 C                            Antiparallel chains                               C
5973 C                                                                              C
5974 C          o             o                   o             o                   C
5975 C         /j\           / \             \   / \           / \   /              C
5976 C        /   \         /   \             \ /   \         /   \ /               C
5977 C      j1| o |l        | o |              o| o |         | o |o                C
5978 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5979 C      \i/   \         /   \ /             /   \         /   \                 C
5980 C       o     k1            o                                                  C
5981 C         (I)          (II)                (III)          (IV)                 C
5982 C                                                                              C
5983 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5984 C                                                                              C
5985 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5986 C                                                                              C
5987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5988 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5989 cd        eello5=0.0d0
5990 cd        return
5991 cd      endif
5992 cd      write (iout,*)
5993 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5994 cd     &   ' and',k,l
5995       itk=itortyp(itype(k))
5996       itl=itortyp(itype(l))
5997       itj=itortyp(itype(j))
5998       eello5_1=0.0d0
5999       eello5_2=0.0d0
6000       eello5_3=0.0d0
6001       eello5_4=0.0d0
6002 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6003 cd     &   eel5_3_num,eel5_4_num)
6004       do iii=1,2
6005         do kkk=1,5
6006           do lll=1,3
6007             derx(lll,kkk,iii)=0.0d0
6008           enddo
6009         enddo
6010       enddo
6011 cd      eij=facont_hb(jj,i)
6012 cd      ekl=facont_hb(kk,k)
6013 cd      ekont=eij*ekl
6014 cd      write (iout,*)'Contacts have occurred for peptide groups',
6015 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6016 cd      goto 1111
6017 C Contribution from the graph I.
6018 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6019 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6020       call transpose2(EUg(1,1,k),auxmat(1,1))
6021       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6022       vv(1)=pizda(1,1)-pizda(2,2)
6023       vv(2)=pizda(1,2)+pizda(2,1)
6024       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6025      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6026       if (calc_grad) then
6027 C Explicit gradient in virtual-dihedral angles.
6028       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6029      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6030      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6031       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6032       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6033       vv(1)=pizda(1,1)-pizda(2,2)
6034       vv(2)=pizda(1,2)+pizda(2,1)
6035       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6036      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6037      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6038       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6039       vv(1)=pizda(1,1)-pizda(2,2)
6040       vv(2)=pizda(1,2)+pizda(2,1)
6041       if (l.eq.j+1) then
6042         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6043      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6044      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6045       else
6046         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6047      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6048      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6049       endif
6050 C Cartesian gradient
6051       do iii=1,2
6052         do kkk=1,5
6053           do lll=1,3
6054             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6055      &        pizda(1,1))
6056             vv(1)=pizda(1,1)-pizda(2,2)
6057             vv(2)=pizda(1,2)+pizda(2,1)
6058             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6059      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6060      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6061           enddo
6062         enddo
6063       enddo
6064 c      goto 1112
6065       endif
6066 c1111  continue
6067 C Contribution from graph II
6068       call transpose2(EE(1,1,itk),auxmat(1,1))
6069       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6070       vv(1)=pizda(1,1)+pizda(2,2)
6071       vv(2)=pizda(2,1)-pizda(1,2)
6072       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6073      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6074       if (calc_grad) then
6075 C Explicit gradient in virtual-dihedral angles.
6076       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6077      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6078       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6079       vv(1)=pizda(1,1)+pizda(2,2)
6080       vv(2)=pizda(2,1)-pizda(1,2)
6081       if (l.eq.j+1) then
6082         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6083      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6084      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6085       else
6086         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6087      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6088      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6089       endif
6090 C Cartesian gradient
6091       do iii=1,2
6092         do kkk=1,5
6093           do lll=1,3
6094             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6095      &        pizda(1,1))
6096             vv(1)=pizda(1,1)+pizda(2,2)
6097             vv(2)=pizda(2,1)-pizda(1,2)
6098             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6099      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6100      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6101           enddo
6102         enddo
6103       enddo
6104 cd      goto 1112
6105       endif
6106 cd1111  continue
6107       if (l.eq.j+1) then
6108 cd        goto 1110
6109 C Parallel orientation
6110 C Contribution from graph III
6111         call transpose2(EUg(1,1,l),auxmat(1,1))
6112         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6113         vv(1)=pizda(1,1)-pizda(2,2)
6114         vv(2)=pizda(1,2)+pizda(2,1)
6115         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6116      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6117         if (calc_grad) then
6118 C Explicit gradient in virtual-dihedral angles.
6119         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6120      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6121      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6122         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6123         vv(1)=pizda(1,1)-pizda(2,2)
6124         vv(2)=pizda(1,2)+pizda(2,1)
6125         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6126      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6127      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6128         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6129         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6130         vv(1)=pizda(1,1)-pizda(2,2)
6131         vv(2)=pizda(1,2)+pizda(2,1)
6132         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6133      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6134      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6135 C Cartesian gradient
6136         do iii=1,2
6137           do kkk=1,5
6138             do lll=1,3
6139               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6140      &          pizda(1,1))
6141               vv(1)=pizda(1,1)-pizda(2,2)
6142               vv(2)=pizda(1,2)+pizda(2,1)
6143               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6144      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6145      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6146             enddo
6147           enddo
6148         enddo
6149 cd        goto 1112
6150         endif
6151 C Contribution from graph IV
6152 cd1110    continue
6153         call transpose2(EE(1,1,itl),auxmat(1,1))
6154         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6155         vv(1)=pizda(1,1)+pizda(2,2)
6156         vv(2)=pizda(2,1)-pizda(1,2)
6157         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6158      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6159         if (calc_grad) then
6160 C Explicit gradient in virtual-dihedral angles.
6161         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6162      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6163         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6164         vv(1)=pizda(1,1)+pizda(2,2)
6165         vv(2)=pizda(2,1)-pizda(1,2)
6166         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6167      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6168      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6169 C Cartesian gradient
6170         do iii=1,2
6171           do kkk=1,5
6172             do lll=1,3
6173               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6174      &          pizda(1,1))
6175               vv(1)=pizda(1,1)+pizda(2,2)
6176               vv(2)=pizda(2,1)-pizda(1,2)
6177               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6178      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6179      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6180             enddo
6181           enddo
6182         enddo
6183         endif
6184       else
6185 C Antiparallel orientation
6186 C Contribution from graph III
6187 c        goto 1110
6188         call transpose2(EUg(1,1,j),auxmat(1,1))
6189         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6190         vv(1)=pizda(1,1)-pizda(2,2)
6191         vv(2)=pizda(1,2)+pizda(2,1)
6192         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6193      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6194         if (calc_grad) then
6195 C Explicit gradient in virtual-dihedral angles.
6196         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6197      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6198      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6199         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6200         vv(1)=pizda(1,1)-pizda(2,2)
6201         vv(2)=pizda(1,2)+pizda(2,1)
6202         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6203      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6204      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6205         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6206         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6207         vv(1)=pizda(1,1)-pizda(2,2)
6208         vv(2)=pizda(1,2)+pizda(2,1)
6209         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6210      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6211      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6212 C Cartesian gradient
6213         do iii=1,2
6214           do kkk=1,5
6215             do lll=1,3
6216               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6217      &          pizda(1,1))
6218               vv(1)=pizda(1,1)-pizda(2,2)
6219               vv(2)=pizda(1,2)+pizda(2,1)
6220               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6221      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6222      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6223             enddo
6224           enddo
6225         enddo
6226 cd        goto 1112
6227         endif
6228 C Contribution from graph IV
6229 1110    continue
6230         call transpose2(EE(1,1,itj),auxmat(1,1))
6231         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6232         vv(1)=pizda(1,1)+pizda(2,2)
6233         vv(2)=pizda(2,1)-pizda(1,2)
6234         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6235      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6236         if (calc_grad) then
6237 C Explicit gradient in virtual-dihedral angles.
6238         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6239      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6240         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6241         vv(1)=pizda(1,1)+pizda(2,2)
6242         vv(2)=pizda(2,1)-pizda(1,2)
6243         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6244      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6245      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6246 C Cartesian gradient
6247         do iii=1,2
6248           do kkk=1,5
6249             do lll=1,3
6250               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6251      &          pizda(1,1))
6252               vv(1)=pizda(1,1)+pizda(2,2)
6253               vv(2)=pizda(2,1)-pizda(1,2)
6254               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6255      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6256      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6257             enddo
6258           enddo
6259         enddo
6260       endif
6261       endif
6262 1112  continue
6263       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6264 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6265 cd        write (2,*) 'ijkl',i,j,k,l
6266 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6267 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6268 cd      endif
6269 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6270 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6271 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6272 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6273       if (calc_grad) then
6274       if (j.lt.nres-1) then
6275         j1=j+1
6276         j2=j-1
6277       else
6278         j1=j-1
6279         j2=j-2
6280       endif
6281       if (l.lt.nres-1) then
6282         l1=l+1
6283         l2=l-1
6284       else
6285         l1=l-1
6286         l2=l-2
6287       endif
6288 cd      eij=1.0d0
6289 cd      ekl=1.0d0
6290 cd      ekont=1.0d0
6291 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6292       do ll=1,3
6293         ggg1(ll)=eel5*g_contij(ll,1)
6294         ggg2(ll)=eel5*g_contij(ll,2)
6295 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6296         ghalf=0.5d0*ggg1(ll)
6297 cd        ghalf=0.0d0
6298         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6299         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6300         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6301         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6302 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6303         ghalf=0.5d0*ggg2(ll)
6304 cd        ghalf=0.0d0
6305         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6306         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6307         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6308         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6309       enddo
6310 cd      goto 1112
6311       do m=i+1,j-1
6312         do ll=1,3
6313 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6314           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6315         enddo
6316       enddo
6317       do m=k+1,l-1
6318         do ll=1,3
6319 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6320           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6321         enddo
6322       enddo
6323 c1112  continue
6324       do m=i+2,j2
6325         do ll=1,3
6326           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6327         enddo
6328       enddo
6329       do m=k+2,l2
6330         do ll=1,3
6331           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6332         enddo
6333       enddo
6334 cd      do iii=1,nres-3
6335 cd        write (2,*) iii,g_corr5_loc(iii)
6336 cd      enddo
6337       endif
6338       eello5=ekont*eel5
6339 cd      write (2,*) 'ekont',ekont
6340 cd      write (iout,*) 'eello5',ekont*eel5
6341       return
6342       end
6343 c--------------------------------------------------------------------------
6344       double precision function eello6(i,j,k,l,jj,kk)
6345       implicit real*8 (a-h,o-z)
6346       include 'DIMENSIONS'
6347       include 'sizesclu.dat'
6348       include 'COMMON.IOUNITS'
6349       include 'COMMON.CHAIN'
6350       include 'COMMON.DERIV'
6351       include 'COMMON.INTERACT'
6352       include 'COMMON.CONTACTS'
6353       include 'COMMON.TORSION'
6354       include 'COMMON.VAR'
6355       include 'COMMON.GEO'
6356       include 'COMMON.FFIELD'
6357       double precision ggg1(3),ggg2(3)
6358 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6359 cd        eello6=0.0d0
6360 cd        return
6361 cd      endif
6362 cd      write (iout,*)
6363 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6364 cd     &   ' and',k,l
6365       eello6_1=0.0d0
6366       eello6_2=0.0d0
6367       eello6_3=0.0d0
6368       eello6_4=0.0d0
6369       eello6_5=0.0d0
6370       eello6_6=0.0d0
6371 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6372 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6373       do iii=1,2
6374         do kkk=1,5
6375           do lll=1,3
6376             derx(lll,kkk,iii)=0.0d0
6377           enddo
6378         enddo
6379       enddo
6380 cd      eij=facont_hb(jj,i)
6381 cd      ekl=facont_hb(kk,k)
6382 cd      ekont=eij*ekl
6383 cd      eij=1.0d0
6384 cd      ekl=1.0d0
6385 cd      ekont=1.0d0
6386       if (l.eq.j+1) then
6387         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6388         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6389         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6390         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6391         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6392         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6393       else
6394         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6395         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6396         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6397         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6398         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6399           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6400         else
6401           eello6_5=0.0d0
6402         endif
6403         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6404       endif
6405 C If turn contributions are considered, they will be handled separately.
6406       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6407 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6408 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6409 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6410 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6411 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6412 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6413 cd      goto 1112
6414       if (calc_grad) then
6415       if (j.lt.nres-1) then
6416         j1=j+1
6417         j2=j-1
6418       else
6419         j1=j-1
6420         j2=j-2
6421       endif
6422       if (l.lt.nres-1) then
6423         l1=l+1
6424         l2=l-1
6425       else
6426         l1=l-1
6427         l2=l-2
6428       endif
6429       do ll=1,3
6430         ggg1(ll)=eel6*g_contij(ll,1)
6431         ggg2(ll)=eel6*g_contij(ll,2)
6432 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6433         ghalf=0.5d0*ggg1(ll)
6434 cd        ghalf=0.0d0
6435         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6436         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6437         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6438         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6439         ghalf=0.5d0*ggg2(ll)
6440 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6441 cd        ghalf=0.0d0
6442         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6443         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6444         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6445         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6446       enddo
6447 cd      goto 1112
6448       do m=i+1,j-1
6449         do ll=1,3
6450 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6451           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6452         enddo
6453       enddo
6454       do m=k+1,l-1
6455         do ll=1,3
6456 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6457           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6458         enddo
6459       enddo
6460 1112  continue
6461       do m=i+2,j2
6462         do ll=1,3
6463           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6464         enddo
6465       enddo
6466       do m=k+2,l2
6467         do ll=1,3
6468           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6469         enddo
6470       enddo
6471 cd      do iii=1,nres-3
6472 cd        write (2,*) iii,g_corr6_loc(iii)
6473 cd      enddo
6474       endif
6475       eello6=ekont*eel6
6476 cd      write (2,*) 'ekont',ekont
6477 cd      write (iout,*) 'eello6',ekont*eel6
6478       return
6479       end
6480 c--------------------------------------------------------------------------
6481       double precision function eello6_graph1(i,j,k,l,imat,swap)
6482       implicit real*8 (a-h,o-z)
6483       include 'DIMENSIONS'
6484       include 'sizesclu.dat'
6485       include 'COMMON.IOUNITS'
6486       include 'COMMON.CHAIN'
6487       include 'COMMON.DERIV'
6488       include 'COMMON.INTERACT'
6489       include 'COMMON.CONTACTS'
6490       include 'COMMON.TORSION'
6491       include 'COMMON.VAR'
6492       include 'COMMON.GEO'
6493       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6494       logical swap
6495       logical lprn
6496       common /kutas/ lprn
6497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6498 C                                                                              C
6499 C      Parallel       Antiparallel                                             C
6500 C                                                                              C
6501 C          o             o                                                     C
6502 C         /l\           /j\                                                    C
6503 C        /   \         /   \                                                   C
6504 C       /| o |         | o |\                                                  C
6505 C     \ j|/k\|  /   \  |/k\|l /                                                C
6506 C      \ /   \ /     \ /   \ /                                                 C
6507 C       o     o       o     o                                                  C
6508 C       i             i                                                        C
6509 C                                                                              C
6510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6511       itk=itortyp(itype(k))
6512       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6513       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6514       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6515       call transpose2(EUgC(1,1,k),auxmat(1,1))
6516       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6517       vv1(1)=pizda1(1,1)-pizda1(2,2)
6518       vv1(2)=pizda1(1,2)+pizda1(2,1)
6519       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6520       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6521       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6522       s5=scalar2(vv(1),Dtobr2(1,i))
6523 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6524       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6525       if (.not. calc_grad) return
6526       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6527      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6528      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6529      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6530      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6531      & +scalar2(vv(1),Dtobr2der(1,i)))
6532       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6533       vv1(1)=pizda1(1,1)-pizda1(2,2)
6534       vv1(2)=pizda1(1,2)+pizda1(2,1)
6535       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6536       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6537       if (l.eq.j+1) then
6538         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6539      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6540      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6541      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6542      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6543       else
6544         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6545      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6546      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6547      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6548      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6549       endif
6550       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6551       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6552       vv1(1)=pizda1(1,1)-pizda1(2,2)
6553       vv1(2)=pizda1(1,2)+pizda1(2,1)
6554       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6555      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6556      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6557      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6558       do iii=1,2
6559         if (swap) then
6560           ind=3-iii
6561         else
6562           ind=iii
6563         endif
6564         do kkk=1,5
6565           do lll=1,3
6566             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6567             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6568             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6569             call transpose2(EUgC(1,1,k),auxmat(1,1))
6570             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6571      &        pizda1(1,1))
6572             vv1(1)=pizda1(1,1)-pizda1(2,2)
6573             vv1(2)=pizda1(1,2)+pizda1(2,1)
6574             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6575             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6576      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6577             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6578      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6579             s5=scalar2(vv(1),Dtobr2(1,i))
6580             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6581           enddo
6582         enddo
6583       enddo
6584       return
6585       end
6586 c----------------------------------------------------------------------------
6587       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6588       implicit real*8 (a-h,o-z)
6589       include 'DIMENSIONS'
6590       include 'sizesclu.dat'
6591       include 'COMMON.IOUNITS'
6592       include 'COMMON.CHAIN'
6593       include 'COMMON.DERIV'
6594       include 'COMMON.INTERACT'
6595       include 'COMMON.CONTACTS'
6596       include 'COMMON.TORSION'
6597       include 'COMMON.VAR'
6598       include 'COMMON.GEO'
6599       logical swap
6600       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6601      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6602       logical lprn
6603       common /kutas/ lprn
6604 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6605 C                                                                              C
6606 C      Parallel       Antiparallel                                             C
6607 C                                                                              C
6608 C          o             o                                                     C
6609 C     \   /l\           /j\   /                                                C
6610 C      \ /   \         /   \ /                                                 C
6611 C       o| o |         | o |o                                                  C
6612 C     \ j|/k\|      \  |/k\|l                                                  C
6613 C      \ /   \       \ /   \                                                   C
6614 C       o             o                                                        C
6615 C       i             i                                                        C
6616 C                                                                              C
6617 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6618 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6619 C AL 7/4/01 s1 would occur in the sixth-order moment,
6620 C           but not in a cluster cumulant
6621 #ifdef MOMENT
6622       s1=dip(1,jj,i)*dip(1,kk,k)
6623 #endif
6624       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6625       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6626       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6627       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6628       call transpose2(EUg(1,1,k),auxmat(1,1))
6629       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6630       vv(1)=pizda(1,1)-pizda(2,2)
6631       vv(2)=pizda(1,2)+pizda(2,1)
6632       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6633 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6634 #ifdef MOMENT
6635       eello6_graph2=-(s1+s2+s3+s4)
6636 #else
6637       eello6_graph2=-(s2+s3+s4)
6638 #endif
6639 c      eello6_graph2=-s3
6640       if (.not. calc_grad) return
6641 C Derivatives in gamma(i-1)
6642       if (i.gt.1) then
6643 #ifdef MOMENT
6644         s1=dipderg(1,jj,i)*dip(1,kk,k)
6645 #endif
6646         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6647         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6648         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6649         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6650 #ifdef MOMENT
6651         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6652 #else
6653         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6654 #endif
6655 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6656       endif
6657 C Derivatives in gamma(k-1)
6658 #ifdef MOMENT
6659       s1=dip(1,jj,i)*dipderg(1,kk,k)
6660 #endif
6661       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6662       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6663       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6664       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6665       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6666       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6667       vv(1)=pizda(1,1)-pizda(2,2)
6668       vv(2)=pizda(1,2)+pizda(2,1)
6669       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6670 #ifdef MOMENT
6671       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6672 #else
6673       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6674 #endif
6675 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6676 C Derivatives in gamma(j-1) or gamma(l-1)
6677       if (j.gt.1) then
6678 #ifdef MOMENT
6679         s1=dipderg(3,jj,i)*dip(1,kk,k)
6680 #endif
6681         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6682         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6683         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6684         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6685         vv(1)=pizda(1,1)-pizda(2,2)
6686         vv(2)=pizda(1,2)+pizda(2,1)
6687         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6688 #ifdef MOMENT
6689         if (swap) then
6690           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6691         else
6692           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6693         endif
6694 #endif
6695         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6696 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6697       endif
6698 C Derivatives in gamma(l-1) or gamma(j-1)
6699       if (l.gt.1) then
6700 #ifdef MOMENT
6701         s1=dip(1,jj,i)*dipderg(3,kk,k)
6702 #endif
6703         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6704         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6705         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6706         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6707         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6708         vv(1)=pizda(1,1)-pizda(2,2)
6709         vv(2)=pizda(1,2)+pizda(2,1)
6710         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6711 #ifdef MOMENT
6712         if (swap) then
6713           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6714         else
6715           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6716         endif
6717 #endif
6718         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6719 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6720       endif
6721 C Cartesian derivatives.
6722       if (lprn) then
6723         write (2,*) 'In eello6_graph2'
6724         do iii=1,2
6725           write (2,*) 'iii=',iii
6726           do kkk=1,5
6727             write (2,*) 'kkk=',kkk
6728             do jjj=1,2
6729               write (2,'(3(2f10.5),5x)')
6730      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6731             enddo
6732           enddo
6733         enddo
6734       endif
6735       do iii=1,2
6736         do kkk=1,5
6737           do lll=1,3
6738 #ifdef MOMENT
6739             if (iii.eq.1) then
6740               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6741             else
6742               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6743             endif
6744 #endif
6745             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6746      &        auxvec(1))
6747             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6748             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6749      &        auxvec(1))
6750             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6751             call transpose2(EUg(1,1,k),auxmat(1,1))
6752             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6753      &        pizda(1,1))
6754             vv(1)=pizda(1,1)-pizda(2,2)
6755             vv(2)=pizda(1,2)+pizda(2,1)
6756             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6757 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6758 #ifdef MOMENT
6759             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6760 #else
6761             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6762 #endif
6763             if (swap) then
6764               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6765             else
6766               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6767             endif
6768           enddo
6769         enddo
6770       enddo
6771       return
6772       end
6773 c----------------------------------------------------------------------------
6774       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6775       implicit real*8 (a-h,o-z)
6776       include 'DIMENSIONS'
6777       include 'sizesclu.dat'
6778       include 'COMMON.IOUNITS'
6779       include 'COMMON.CHAIN'
6780       include 'COMMON.DERIV'
6781       include 'COMMON.INTERACT'
6782       include 'COMMON.CONTACTS'
6783       include 'COMMON.TORSION'
6784       include 'COMMON.VAR'
6785       include 'COMMON.GEO'
6786       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6787       logical swap
6788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6789 C                                                                              C
6790 C      Parallel       Antiparallel                                             C
6791 C                                                                              C
6792 C          o             o                                                     C
6793 C         /l\   /   \   /j\                                                    C
6794 C        /   \ /     \ /   \                                                   C
6795 C       /| o |o       o| o |\                                                  C
6796 C       j|/k\|  /      |/k\|l /                                                C
6797 C        /   \ /       /   \ /                                                 C
6798 C       /     o       /     o                                                  C
6799 C       i             i                                                        C
6800 C                                                                              C
6801 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6802 C
6803 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6804 C           energy moment and not to the cluster cumulant.
6805       iti=itortyp(itype(i))
6806       if (j.lt.nres-1) then
6807         itj1=itortyp(itype(j+1))
6808       else
6809         itj1=ntortyp+1
6810       endif
6811       itk=itortyp(itype(k))
6812       itk1=itortyp(itype(k+1))
6813       if (l.lt.nres-1) then
6814         itl1=itortyp(itype(l+1))
6815       else
6816         itl1=ntortyp+1
6817       endif
6818 #ifdef MOMENT
6819       s1=dip(4,jj,i)*dip(4,kk,k)
6820 #endif
6821       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6822       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6823       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6824       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6825       call transpose2(EE(1,1,itk),auxmat(1,1))
6826       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6827       vv(1)=pizda(1,1)+pizda(2,2)
6828       vv(2)=pizda(2,1)-pizda(1,2)
6829       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6830 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6831 #ifdef MOMENT
6832       eello6_graph3=-(s1+s2+s3+s4)
6833 #else
6834       eello6_graph3=-(s2+s3+s4)
6835 #endif
6836 c      eello6_graph3=-s4
6837       if (.not. calc_grad) return
6838 C Derivatives in gamma(k-1)
6839       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6840       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6841       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6842       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6843 C Derivatives in gamma(l-1)
6844       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6845       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6846       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6847       vv(1)=pizda(1,1)+pizda(2,2)
6848       vv(2)=pizda(2,1)-pizda(1,2)
6849       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6850       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6851 C Cartesian derivatives.
6852       do iii=1,2
6853         do kkk=1,5
6854           do lll=1,3
6855 #ifdef MOMENT
6856             if (iii.eq.1) then
6857               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6858             else
6859               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6860             endif
6861 #endif
6862             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6863      &        auxvec(1))
6864             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6865             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6866      &        auxvec(1))
6867             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6868             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6869      &        pizda(1,1))
6870             vv(1)=pizda(1,1)+pizda(2,2)
6871             vv(2)=pizda(2,1)-pizda(1,2)
6872             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6873 #ifdef MOMENT
6874             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6875 #else
6876             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6877 #endif
6878             if (swap) then
6879               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6880             else
6881               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6882             endif
6883 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6884           enddo
6885         enddo
6886       enddo
6887       return
6888       end
6889 c----------------------------------------------------------------------------
6890       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6891       implicit real*8 (a-h,o-z)
6892       include 'DIMENSIONS'
6893       include 'sizesclu.dat'
6894       include 'COMMON.IOUNITS'
6895       include 'COMMON.CHAIN'
6896       include 'COMMON.DERIV'
6897       include 'COMMON.INTERACT'
6898       include 'COMMON.CONTACTS'
6899       include 'COMMON.TORSION'
6900       include 'COMMON.VAR'
6901       include 'COMMON.GEO'
6902       include 'COMMON.FFIELD'
6903       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6904      & auxvec1(2),auxmat1(2,2)
6905       logical swap
6906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6907 C                                                                              C
6908 C      Parallel       Antiparallel                                             C
6909 C                                                                              C
6910 C          o             o                                                     C
6911 C         /l\   /   \   /j\                                                    C
6912 C        /   \ /     \ /   \                                                   C
6913 C       /| o |o       o| o |\                                                  C
6914 C     \ j|/k\|      \  |/k\|l                                                  C
6915 C      \ /   \       \ /   \                                                   C
6916 C       o     \       o     \                                                  C
6917 C       i             i                                                        C
6918 C                                                                              C
6919 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6920 C
6921 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6922 C           energy moment and not to the cluster cumulant.
6923 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6924       iti=itortyp(itype(i))
6925       itj=itortyp(itype(j))
6926       if (j.lt.nres-1) then
6927         itj1=itortyp(itype(j+1))
6928       else
6929         itj1=ntortyp+1
6930       endif
6931       itk=itortyp(itype(k))
6932       if (k.lt.nres-1) then
6933         itk1=itortyp(itype(k+1))
6934       else
6935         itk1=ntortyp+1
6936       endif
6937       itl=itortyp(itype(l))
6938       if (l.lt.nres-1) then
6939         itl1=itortyp(itype(l+1))
6940       else
6941         itl1=ntortyp+1
6942       endif
6943 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6944 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6945 cd     & ' itl',itl,' itl1',itl1
6946 #ifdef MOMENT
6947       if (imat.eq.1) then
6948         s1=dip(3,jj,i)*dip(3,kk,k)
6949       else
6950         s1=dip(2,jj,j)*dip(2,kk,l)
6951       endif
6952 #endif
6953       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6954       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6955       if (j.eq.l+1) then
6956         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6957         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6958       else
6959         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6960         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6961       endif
6962       call transpose2(EUg(1,1,k),auxmat(1,1))
6963       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6964       vv(1)=pizda(1,1)-pizda(2,2)
6965       vv(2)=pizda(2,1)+pizda(1,2)
6966       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6967 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6968 #ifdef MOMENT
6969       eello6_graph4=-(s1+s2+s3+s4)
6970 #else
6971       eello6_graph4=-(s2+s3+s4)
6972 #endif
6973       if (.not. calc_grad) return
6974 C Derivatives in gamma(i-1)
6975       if (i.gt.1) then
6976 #ifdef MOMENT
6977         if (imat.eq.1) then
6978           s1=dipderg(2,jj,i)*dip(3,kk,k)
6979         else
6980           s1=dipderg(4,jj,j)*dip(2,kk,l)
6981         endif
6982 #endif
6983         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6984         if (j.eq.l+1) then
6985           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6986           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6987         else
6988           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6989           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6990         endif
6991         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6992         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6993 cd          write (2,*) 'turn6 derivatives'
6994 #ifdef MOMENT
6995           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6996 #else
6997           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6998 #endif
6999         else
7000 #ifdef MOMENT
7001           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7002 #else
7003           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7004 #endif
7005         endif
7006       endif
7007 C Derivatives in gamma(k-1)
7008 #ifdef MOMENT
7009       if (imat.eq.1) then
7010         s1=dip(3,jj,i)*dipderg(2,kk,k)
7011       else
7012         s1=dip(2,jj,j)*dipderg(4,kk,l)
7013       endif
7014 #endif
7015       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7016       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7017       if (j.eq.l+1) then
7018         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7019         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7020       else
7021         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7022         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7023       endif
7024       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7025       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7026       vv(1)=pizda(1,1)-pizda(2,2)
7027       vv(2)=pizda(2,1)+pizda(1,2)
7028       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7029       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7030 #ifdef MOMENT
7031         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7032 #else
7033         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7034 #endif
7035       else
7036 #ifdef MOMENT
7037         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7038 #else
7039         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7040 #endif
7041       endif
7042 C Derivatives in gamma(j-1) or gamma(l-1)
7043       if (l.eq.j+1 .and. l.gt.1) then
7044         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7045         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7046         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7047         vv(1)=pizda(1,1)-pizda(2,2)
7048         vv(2)=pizda(2,1)+pizda(1,2)
7049         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7050         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7051       else if (j.gt.1) then
7052         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7053         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7054         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7055         vv(1)=pizda(1,1)-pizda(2,2)
7056         vv(2)=pizda(2,1)+pizda(1,2)
7057         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7058         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7059           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7060         else
7061           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7062         endif
7063       endif
7064 C Cartesian derivatives.
7065       do iii=1,2
7066         do kkk=1,5
7067           do lll=1,3
7068 #ifdef MOMENT
7069             if (iii.eq.1) then
7070               if (imat.eq.1) then
7071                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7072               else
7073                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7074               endif
7075             else
7076               if (imat.eq.1) then
7077                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7078               else
7079                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7080               endif
7081             endif
7082 #endif
7083             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7084      &        auxvec(1))
7085             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7086             if (j.eq.l+1) then
7087               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7088      &          b1(1,itj1),auxvec(1))
7089               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7090             else
7091               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7092      &          b1(1,itl1),auxvec(1))
7093               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7094             endif
7095             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7096      &        pizda(1,1))
7097             vv(1)=pizda(1,1)-pizda(2,2)
7098             vv(2)=pizda(2,1)+pizda(1,2)
7099             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7100             if (swap) then
7101               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7102 #ifdef MOMENT
7103                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7104      &             -(s1+s2+s4)
7105 #else
7106                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7107      &             -(s2+s4)
7108 #endif
7109                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7110               else
7111 #ifdef MOMENT
7112                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7113 #else
7114                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7115 #endif
7116                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7117               endif
7118             else
7119 #ifdef MOMENT
7120               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7121 #else
7122               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7123 #endif
7124               if (l.eq.j+1) then
7125                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7126               else
7127                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7128               endif
7129             endif
7130           enddo
7131         enddo
7132       enddo
7133       return
7134       end
7135 c----------------------------------------------------------------------------
7136       double precision function eello_turn6(i,jj,kk)
7137       implicit real*8 (a-h,o-z)
7138       include 'DIMENSIONS'
7139       include 'sizesclu.dat'
7140       include 'COMMON.IOUNITS'
7141       include 'COMMON.CHAIN'
7142       include 'COMMON.DERIV'
7143       include 'COMMON.INTERACT'
7144       include 'COMMON.CONTACTS'
7145       include 'COMMON.TORSION'
7146       include 'COMMON.VAR'
7147       include 'COMMON.GEO'
7148       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7149      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7150      &  ggg1(3),ggg2(3)
7151       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7152      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7153 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7154 C           the respective energy moment and not to the cluster cumulant.
7155       eello_turn6=0.0d0
7156       j=i+4
7157       k=i+1
7158       l=i+3
7159       iti=itortyp(itype(i))
7160       itk=itortyp(itype(k))
7161       itk1=itortyp(itype(k+1))
7162       itl=itortyp(itype(l))
7163       itj=itortyp(itype(j))
7164 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7165 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7166 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7167 cd        eello6=0.0d0
7168 cd        return
7169 cd      endif
7170 cd      write (iout,*)
7171 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7172 cd     &   ' and',k,l
7173 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7174       do iii=1,2
7175         do kkk=1,5
7176           do lll=1,3
7177             derx_turn(lll,kkk,iii)=0.0d0
7178           enddo
7179         enddo
7180       enddo
7181 cd      eij=1.0d0
7182 cd      ekl=1.0d0
7183 cd      ekont=1.0d0
7184       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7185 cd      eello6_5=0.0d0
7186 cd      write (2,*) 'eello6_5',eello6_5
7187 #ifdef MOMENT
7188       call transpose2(AEA(1,1,1),auxmat(1,1))
7189       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7190       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7191       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7192 #else
7193       s1 = 0.0d0
7194 #endif
7195       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7196       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7197       s2 = scalar2(b1(1,itk),vtemp1(1))
7198 #ifdef MOMENT
7199       call transpose2(AEA(1,1,2),atemp(1,1))
7200       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7201       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7202       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7203 #else
7204       s8=0.0d0
7205 #endif
7206       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7207       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7208       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7209 #ifdef MOMENT
7210       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7211       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7212       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7213       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7214       ss13 = scalar2(b1(1,itk),vtemp4(1))
7215       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7216 #else
7217       s13=0.0d0
7218 #endif
7219 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7220 c      s1=0.0d0
7221 c      s2=0.0d0
7222 c      s8=0.0d0
7223 c      s12=0.0d0
7224 c      s13=0.0d0
7225       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7226       if (calc_grad) then
7227 C Derivatives in gamma(i+2)
7228 #ifdef MOMENT
7229       call transpose2(AEA(1,1,1),auxmatd(1,1))
7230       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7231       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7232       call transpose2(AEAderg(1,1,2),atempd(1,1))
7233       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7234       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7235 #else
7236       s8d=0.0d0
7237 #endif
7238       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7239       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7240       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7241 c      s1d=0.0d0
7242 c      s2d=0.0d0
7243 c      s8d=0.0d0
7244 c      s12d=0.0d0
7245 c      s13d=0.0d0
7246       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7247 C Derivatives in gamma(i+3)
7248 #ifdef MOMENT
7249       call transpose2(AEA(1,1,1),auxmatd(1,1))
7250       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7251       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7252       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7253 #else
7254       s1d=0.0d0
7255 #endif
7256       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7257       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7258       s2d = scalar2(b1(1,itk),vtemp1d(1))
7259 #ifdef MOMENT
7260       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7261       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7262 #endif
7263       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7264 #ifdef MOMENT
7265       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7266       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7267       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7268 #else
7269       s13d=0.0d0
7270 #endif
7271 c      s1d=0.0d0
7272 c      s2d=0.0d0
7273 c      s8d=0.0d0
7274 c      s12d=0.0d0
7275 c      s13d=0.0d0
7276 #ifdef MOMENT
7277       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7278      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7279 #else
7280       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7281      &               -0.5d0*ekont*(s2d+s12d)
7282 #endif
7283 C Derivatives in gamma(i+4)
7284       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7285       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7286       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7287 #ifdef MOMENT
7288       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7289       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7290       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7291 #else
7292       s13d = 0.0d0
7293 #endif
7294 c      s1d=0.0d0
7295 c      s2d=0.0d0
7296 c      s8d=0.0d0
7297 C      s12d=0.0d0
7298 c      s13d=0.0d0
7299 #ifdef MOMENT
7300       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7301 #else
7302       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7303 #endif
7304 C Derivatives in gamma(i+5)
7305 #ifdef MOMENT
7306       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7307       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7308       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7309 #else
7310       s1d = 0.0d0
7311 #endif
7312       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7313       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7314       s2d = scalar2(b1(1,itk),vtemp1d(1))
7315 #ifdef MOMENT
7316       call transpose2(AEA(1,1,2),atempd(1,1))
7317       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7318       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7319 #else
7320       s8d = 0.0d0
7321 #endif
7322       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7323       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7324 #ifdef MOMENT
7325       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7326       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7327       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7328 #else
7329       s13d = 0.0d0
7330 #endif
7331 c      s1d=0.0d0
7332 c      s2d=0.0d0
7333 c      s8d=0.0d0
7334 c      s12d=0.0d0
7335 c      s13d=0.0d0
7336 #ifdef MOMENT
7337       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7338      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7339 #else
7340       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7341      &               -0.5d0*ekont*(s2d+s12d)
7342 #endif
7343 C Cartesian derivatives
7344       do iii=1,2
7345         do kkk=1,5
7346           do lll=1,3
7347 #ifdef MOMENT
7348             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7349             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7350             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7351 #else
7352             s1d = 0.0d0
7353 #endif
7354             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7355             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7356      &          vtemp1d(1))
7357             s2d = scalar2(b1(1,itk),vtemp1d(1))
7358 #ifdef MOMENT
7359             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7360             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7361             s8d = -(atempd(1,1)+atempd(2,2))*
7362      &           scalar2(cc(1,1,itl),vtemp2(1))
7363 #else
7364             s8d = 0.0d0
7365 #endif
7366             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7367      &           auxmatd(1,1))
7368             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7369             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7370 c      s1d=0.0d0
7371 c      s2d=0.0d0
7372 c      s8d=0.0d0
7373 c      s12d=0.0d0
7374 c      s13d=0.0d0
7375 #ifdef MOMENT
7376             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7377      &        - 0.5d0*(s1d+s2d)
7378 #else
7379             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7380      &        - 0.5d0*s2d
7381 #endif
7382 #ifdef MOMENT
7383             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7384      &        - 0.5d0*(s8d+s12d)
7385 #else
7386             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7387      &        - 0.5d0*s12d
7388 #endif
7389           enddo
7390         enddo
7391       enddo
7392 #ifdef MOMENT
7393       do kkk=1,5
7394         do lll=1,3
7395           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7396      &      achuj_tempd(1,1))
7397           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7398           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7399           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7400           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7401           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7402      &      vtemp4d(1))
7403           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7404           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7405           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7406         enddo
7407       enddo
7408 #endif
7409 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7410 cd     &  16*eel_turn6_num
7411 cd      goto 1112
7412       if (j.lt.nres-1) then
7413         j1=j+1
7414         j2=j-1
7415       else
7416         j1=j-1
7417         j2=j-2
7418       endif
7419       if (l.lt.nres-1) then
7420         l1=l+1
7421         l2=l-1
7422       else
7423         l1=l-1
7424         l2=l-2
7425       endif
7426       do ll=1,3
7427         ggg1(ll)=eel_turn6*g_contij(ll,1)
7428         ggg2(ll)=eel_turn6*g_contij(ll,2)
7429         ghalf=0.5d0*ggg1(ll)
7430 cd        ghalf=0.0d0
7431         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7432      &    +ekont*derx_turn(ll,2,1)
7433         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7434         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7435      &    +ekont*derx_turn(ll,4,1)
7436         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7437         ghalf=0.5d0*ggg2(ll)
7438 cd        ghalf=0.0d0
7439         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7440      &    +ekont*derx_turn(ll,2,2)
7441         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7442         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7443      &    +ekont*derx_turn(ll,4,2)
7444         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7445       enddo
7446 cd      goto 1112
7447       do m=i+1,j-1
7448         do ll=1,3
7449           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7450         enddo
7451       enddo
7452       do m=k+1,l-1
7453         do ll=1,3
7454           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7455         enddo
7456       enddo
7457 1112  continue
7458       do m=i+2,j2
7459         do ll=1,3
7460           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7461         enddo
7462       enddo
7463       do m=k+2,l2
7464         do ll=1,3
7465           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7466         enddo
7467       enddo
7468 cd      do iii=1,nres-3
7469 cd        write (2,*) iii,g_corr6_loc(iii)
7470 cd      enddo
7471       endif
7472       eello_turn6=ekont*eel_turn6
7473 cd      write (2,*) 'ekont',ekont
7474 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7475       return
7476       end
7477 crc-------------------------------------------------
7478       SUBROUTINE MATVEC2(A1,V1,V2)
7479       implicit real*8 (a-h,o-z)
7480       include 'DIMENSIONS'
7481       DIMENSION A1(2,2),V1(2),V2(2)
7482 c      DO 1 I=1,2
7483 c        VI=0.0
7484 c        DO 3 K=1,2
7485 c    3     VI=VI+A1(I,K)*V1(K)
7486 c        Vaux(I)=VI
7487 c    1 CONTINUE
7488
7489       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7490       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7491
7492       v2(1)=vaux1
7493       v2(2)=vaux2
7494       END
7495 C---------------------------------------
7496       SUBROUTINE MATMAT2(A1,A2,A3)
7497       implicit real*8 (a-h,o-z)
7498       include 'DIMENSIONS'
7499       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7500 c      DIMENSION AI3(2,2)
7501 c        DO  J=1,2
7502 c          A3IJ=0.0
7503 c          DO K=1,2
7504 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7505 c          enddo
7506 c          A3(I,J)=A3IJ
7507 c       enddo
7508 c      enddo
7509
7510       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7511       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7512       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7513       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7514
7515       A3(1,1)=AI3_11
7516       A3(2,1)=AI3_21
7517       A3(1,2)=AI3_12
7518       A3(2,2)=AI3_22
7519       END
7520
7521 c-------------------------------------------------------------------------
7522       double precision function scalar2(u,v)
7523       implicit none
7524       double precision u(2),v(2)
7525       double precision sc
7526       integer i
7527       scalar2=u(1)*v(1)+u(2)*v(2)
7528       return
7529       end
7530
7531 C-----------------------------------------------------------------------------
7532
7533       subroutine transpose2(a,at)
7534       implicit none
7535       double precision a(2,2),at(2,2)
7536       at(1,1)=a(1,1)
7537       at(1,2)=a(2,1)
7538       at(2,1)=a(1,2)
7539       at(2,2)=a(2,2)
7540       return
7541       end
7542 c--------------------------------------------------------------------------
7543       subroutine transpose(n,a,at)
7544       implicit none
7545       integer n,i,j
7546       double precision a(n,n),at(n,n)
7547       do i=1,n
7548         do j=1,n
7549           at(j,i)=a(i,j)
7550         enddo
7551       enddo
7552       return
7553       end
7554 C---------------------------------------------------------------------------
7555       subroutine prodmat3(a1,a2,kk,transp,prod)
7556       implicit none
7557       integer i,j
7558       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7559       logical transp
7560 crc      double precision auxmat(2,2),prod_(2,2)
7561
7562       if (transp) then
7563 crc        call transpose2(kk(1,1),auxmat(1,1))
7564 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7565 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7566
7567            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7568      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7569            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7570      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7571            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7572      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7573            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7574      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7575
7576       else
7577 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7578 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7579
7580            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7581      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7582            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7583      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7584            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7585      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7586            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7587      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7588
7589       endif
7590 c      call transpose2(a2(1,1),a2t(1,1))
7591
7592 crc      print *,transp
7593 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7594 crc      print *,((prod(i,j),i=1,2),j=1,2)
7595
7596       return
7597       end
7598 C-----------------------------------------------------------------------------
7599       double precision function scalar(u,v)
7600       implicit none
7601       double precision u(3),v(3)
7602       double precision sc
7603       integer i
7604       sc=0.0d0
7605       do i=1,3
7606         sc=sc+u(i)*v(i)
7607       enddo
7608       scalar=sc
7609       return
7610       end
7611