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