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