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