source/wham/src-M/energy_p_new.F

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