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