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