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