source/maxlik/src_FPy/energy_p_new_sc.F.org

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8
   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 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105,106) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw)
  33 cd    print '(a)','Exit ELJ'
  34       goto 107
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw)
  37       goto 107
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw)
  40       goto 107
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw)
  43       goto 107
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw)
  46       goto 107
  47 C New SC-SC potential
  48   106 call emomo(evdw,evdw_p,evdw_m)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   107 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 c      call flush(iout)
  64 C
  65 C Calculate the disulfide-bridge and other energy and the contributions
  66 C from other distance constraints.
  67 cd    print *,'Calling EHPB'
  68       call edis(ehpb)
  69 cd    print *,'EHPB exitted succesfully.'
  70 C
  71 C Calculate the virtual-bond-angle energy.
  72 C
  73       call ebend(ebe)
  74 c      write (iout,*)'Bend energy finished.'
  75 c      call flush(iout)
  76 C
  77 C Calculate the SC local energy.
  78 C
  79       call esc(escloc)
  80 c      write (iout,*)'SCLOC energy finished.'
  81 c      call flush(iout)
  82 C
  83 C Calculate the virtual-bond torsional energy.
  84 C
  85 cd    print *,'nterm=',nterm
  86       call etor(etors,edihcnstr)
  87 c      write (iout,*) "After etor"
  88 c      call flush(iout)
  89 C
  90 C 6/23/01 Calculate double-torsional energy
  91 C
  92       call etor_d(etors_d)
  93 c      write (iout,*) "After etor_d"
  94 c      call flush(iout)
  95 C
  96 C 21/5/07 Calculate local sicdechain correlation energy
  97 C
  98       call eback_sc_corr(esccor)
  99 c      write (iout,*) "After eback_sccor"
 100 c      call flush(iout)
 101 C
 102 C 12/1/95 Multi-body terms
 103 C
 104       n_corr=0
 105       n_corr1=0
 106       ecorr=0.0d0
 107       ecorr5=0.0d0
 108       ecorr6=0.0d0
 109       eturn6=0.0d0
 110       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 111      &    .or. wturn6.gt.0.0d0) then
 112 c         print *,"calling multibody_eello"
 113          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 114 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 115 c         print *,ecorr,ecorr5,ecorr6,eturn6
 116       endif
 117       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 118          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 119       endif
 120 C     call multibody(ecorr)
 121 C
 122 C Sum the energies
 123 C
 124 C scale large componenets
 125 #ifdef SCALE
 126       ecorr5_scal=1000.0
 127       eel_loc_scal=100.0
 128       eello_turn3_scal=100.0
 129       eello_turn4_scal=100.0
 130       eturn6_scal=1000.0
 131       ecorr6_scal=1000.0
 132 #else
 133       ecorr5_scal=1.0
 134       eel_loc_scal=1.0
 135       eello_turn3_scal=1.0
 136       eello_turn4_scal=1.0
 137       eturn6_scal=1.0
 138       ecorr6_scal=1.0
 139 #endif
 140
 141       ecorr5=ecorr5/ecorr5_scal
 142       eel_loc=eel_loc/eel_loc_scal
 143       eello_turn3=eello_turn3/eello_turn3_scal
 144       eello_turn4=eello_turn4/eello_turn4_scal
 145       eturn6=eturn6/eturn6_scal
 146       ecorr6=ecorr6/ecorr6_scal
 147 #ifdef SPLITELE
 148       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 149      & +wang*ebe+wtor*etors+wscloc*escloc
 150      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 151      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 152      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 153      & +wbond*estr+wsccor*esccor
 154 #else
 155       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 156      & +wang*ebe+wtor*etors+wscloc*escloc
 157      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 158      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 159      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 160      & +wbond*estr+wsccor*esccor
 161 #endif
 162       energia(0)=etot
 163       energia(1)=evdw
 164 #ifdef SCP14
 165       energia(2)=evdw2-evdw2_14
 166       energia(18)=evdw2_14
 167 #else
 168       energia(2)=evdw2
 169       energia(18)=0.0d0
 170 #endif
 171 #ifdef SPLITELE
 172       energia(3)=ees
 173       energia(16)=evdw1
 174 #else
 175       energia(3)=ees+evdw1
 176       energia(16)=0.0d0
 177 #endif
 178       energia(4)=ecorr
 179       energia(5)=ecorr5
 180       energia(6)=ecorr6
 181       energia(7)=eel_loc
 182       energia(8)=eello_turn3
 183       energia(9)=eello_turn4
 184       energia(10)=eturn6
 185       energia(11)=ebe
 186       energia(12)=escloc
 187       energia(13)=etors
 188       energia(14)=etors_d
 189       energia(15)=ehpb
 190       energia(17)=estr
 191       energia(19)=esccor
 192       energia(20)=edihcnstr
 193 c detecting NaNQ
 194 #ifdef ISNAN
 195 #ifdef AIX
 196       if (isnan(etot).ne.0) energia(0)=1.0d+99
 197 #else
 198       if (isnan(etot)) energia(0)=1.0d+99
 199 #endif
 200 #else
 201       i=0
 202 #ifdef WINPGI
 203       idumm=proc_proc(etot,i)
 204 #else
 205       call proc_proc(etot,i)
 206 #endif
 207       if(i.eq.1)energia(0)=1.0d+99
 208 #endif
 209 #ifdef MPL
 210 c     endif
 211 #endif
 212       if (calc_grad) then
 213 C
 214 C Sum up the components of the Cartesian gradient.
 215 C
 216 #ifdef SPLITELE
 217       do i=1,nct
 218         do j=1,3
 219           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 220      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 221      &                wbond*gradb(j,i)+
 222      &                wstrain*ghpbc(j,i)+
 223      &                wcorr*gradcorr(j,i)+
 224      &                wel_loc*gel_loc(j,i)/eel_loc_scal+
 225      &                wturn3*gcorr3_turn(j,i)/eello_turn3_scal+
 226      &                wturn4*gcorr4_turn(j,i)/eello_turn4_scal+
 227      &                wcorr5*gradcorr5(j,i)/ecorr5_scal+
 228      &                wcorr6*gradcorr6(j,i)/ecorr6_scal+
 229      &                wturn6*gcorr6_turn(j,i)/eturn6_scal+
 230      &                wsccor*gsccorc(j,i)
 231           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 232      &                  wbond*gradbx(j,i)+
 233      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 234      &                  wsccor*gsccorx(j,i)
 235         enddo
 236 #else
 237       do i=1,nct
 238         do j=1,3
 239           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 240      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 241      &                wbond*gradb(j,i)+
 242      &                wcorr*gradcorr(j,i)+
 243      &                wel_loc*gel_loc(j,i)/eel_loc_scal+
 244      &                wturn3*gcorr3_turn(j,i)/eello_turn3_scal+
 245      &                wturn4*gcorr4_turn(j,i)/eello_turn4_scal+
 246      &                wcorr5*gradcorr5(j,i)/ecorr5_scal+
 247      &                wcorr6*gradcorr6(j,i)/ecorr6_scal+
 248      &                wturn6*gcorr6_turn(j,i)/eturn6_scal+
 249      &                wsccor*gsccorc(j,i)
 250           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 251      &                  wbond*gradbx(j,i)+
 252      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 253      &                  wsccor*gsccorc(j,i)
 254         enddo
 255 #endif
 256 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 257 cd   &        (gradc(k,i),k=1,3)
 258       enddo
 259
 260
 261       do i=1,nres-3
 262 cd        write (iout,*) i,g_corr5_loc(i)
 263         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 264      &   +wcorr5*g_corr5_loc(i)/ecorr5_scal
 265      &   +wcorr6*g_corr6_loc(i)/ecorr6_scal
 266      &   +wturn4*gel_loc_turn4(i)/eello_turn4_scal
 267      &   +wturn3*gel_loc_turn3(i)/eello_turn3_scal
 268      &   +wturn6*gel_loc_turn6(i)/eturn6_scal
 269      &   +wel_loc*gel_loc_loc(i)/eel_loc_scal
 270      &   +wsccor*gsccor_loc(i)
 271       enddo
 272       endif
 273 cd    print*,evdw,wsc,evdw2,wscp,ees+evdw1,welec,ebe,wang,
 274 cd   &  escloc,wscloc,etors,wtor,ehpb,wstrain,nss,ebr,etot
 275 cd    call enerprint(energia(0))
 276 cd    call intout
 277 cd    stop
 278       return
 279       end
 280 C------------------------------------------------------------------------
 281       subroutine enerprint(energia)
 282       implicit real*8 (a-h,o-z)
 283       include 'DIMENSIONS'
 284       include 'DIMENSIONS.ZSCOPT'
 285       include 'COMMON.IOUNITS'
 286       include 'COMMON.FFIELD'
 287       include 'COMMON.SBRIDGE'
 288       double precision energia(0:max_ene)
 289       etot=energia(0)
 290       evdw=energia(1)
 291 #ifdef SCP14
 292       evdw2=energia(2)+energia(18)
 293 #else
 294       evdw2=energia(2)
 295 #endif
 296       ees=energia(3)
 297 #ifdef SPLITELE
 298       evdw1=energia(16)
 299 #endif
 300       ecorr=energia(4)
 301       ecorr5=energia(5)
 302       ecorr6=energia(6)
 303       eel_loc=energia(7)
 304       eello_turn3=energia(8)
 305       eello_turn4=energia(9)
 306       eello_turn6=energia(10)
 307       ebe=energia(11)
 308       escloc=energia(12)
 309       etors=energia(13)
 310       etors_d=energia(14)
 311       ehpb=energia(15)
 312       edihcnstr=energia(20)
 313       estr=energia(17)
 314       esccor=energia(19)
 315 #ifdef SPLITELE
 316       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 317      &  estr,wbond,ebe,wang,
 318      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 319      &  ecorr,wcorr,
 320      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 321      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
 322      &  ebr*nss,etot
 323    10 format (/'Virtual-chain energies:'//
 324      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 325      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 326      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 327      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 328      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 329      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 330      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 331      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 332      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 333      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 334      & ' (SS bridges & dist. cnstr.)'/
 335      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 336      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 337      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 338      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 339      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 340      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 341      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 342      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 343      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 344      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 345      & 'ETOT=  ',1pE16.6,' (total)')
 346 #else
 347       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond,ebe,wang,
 348      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 349      &  ecorr,wcorr,
 350      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 351      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
 352      &  ebr*nss,etot
 353    10 format (/'Virtual-chain energies:'//
 354      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 355      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 356      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 357      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 358      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 359      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 360      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 361      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 362      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 363      & ' (SS bridges & dist. cnstr.)'/
 364      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 365      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 366      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 367      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 368      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 369      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 370      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 371      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 372      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 373      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 374      & 'ETOT=  ',1pE16.6,' (total)')
 375 #endif
 376       return
 377       end
 378 C-----------------------------------------------------------------------
 379       subroutine elj(evdw)
 380 C
 381 C This subroutine calculates the interaction energy of nonbonded side chains
 382 C assuming the LJ potential of interaction.
 383 C
 384       implicit real*8 (a-h,o-z)
 385       include 'DIMENSIONS'
 386       include 'DIMENSIONS.ZSCOPT'
 387       parameter (accur=1.0d-10)
 388       include 'COMMON.GEO'
 389       include 'COMMON.VAR'
 390       include 'COMMON.LOCAL'
 391       include 'COMMON.CHAIN'
 392       include 'COMMON.DERIV'
 393       include 'COMMON.INTERACT'
 394       include 'COMMON.TORSION'
 395       include 'COMMON.WEIGHTDER'
 396       include 'COMMON.SBRIDGE'
 397       include 'COMMON.NAMES'
 398       include 'COMMON.IOUNITS'
 399       include 'COMMON.CONTACTS'
 400       dimension gg(3)
 401       integer icant
 402       external icant
 403 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 404       do i=1,210
 405         do j=1,2
 406           eneps_temp(j,i)=0.0d0
 407         enddo
 408       enddo
 409       evdw=0.0D0
 410       do i=iatsc_s,iatsc_e
 411         itypi=itype(i)
 412         itypi1=itype(i+1)
 413         xi=c(1,nres+i)
 414         yi=c(2,nres+i)
 415         zi=c(3,nres+i)
 416 C Change 12/1/95
 417         num_conti=0
 418 C
 419 C Calculate SC interaction energy.
 420 C
 421         do iint=1,nint_gr(i)
 422 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 423 cd   &                  'iend=',iend(i,iint)
 424           do j=istart(i,iint),iend(i,iint)
 425             itypj=itype(j)
 426             xj=c(1,nres+j)-xi
 427             yj=c(2,nres+j)-yi
 428             zj=c(3,nres+j)-zi
 429 C Change 12/1/95 to calculate four-body interactions
 430             rij=xj*xj+yj*yj+zj*zj
 431             rrij=1.0D0/rij
 432 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 433             eps0ij=eps(itypi,itypj)
 434             fac=rrij**expon2
 435             e1=fac*fac*aa(itypi,itypj)
 436             e2=fac*bb(itypi,itypj)
 437             evdwij=e1+e2
 438             ij=icant(itypi,itypj)
 439             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 440             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 441 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 442 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 443 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 444 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 445 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 446 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 447             evdw=evdw+evdwij
 448             if (calc_grad) then
 449 C
 450 C Calculate the components of the gradient in DC and X
 451 C
 452             fac=-rrij*(e1+evdwij)
 453             gg(1)=xj*fac
 454             gg(2)=yj*fac
 455             gg(3)=zj*fac
 456             do k=1,3
 457               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 458               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 459             enddo
 460             do k=i,j-1
 461               do l=1,3
 462                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 463               enddo
 464             enddo
 465             endif
 466 C
 467 C 12/1/95, revised on 5/20/97
 468 C
 469 C Calculate the contact function. The ith column of the array JCONT will
 470 C contain the numbers of atoms that make contacts with the atom I (of numbers
 471 C greater than I). The arrays FACONT and GACONT will contain the values of
 472 C the contact function and its derivative.
 473 C
 474 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 475 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 476 C Uncomment next line, if the correlation interactions are contact function only
 477             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 478               rij=dsqrt(rij)
 479               sigij=sigma(itypi,itypj)
 480               r0ij=rs0(itypi,itypj)
 481 C
 482 C Check whether the SC's are not too far to make a contact.
 483 C
 484               rcut=1.5d0*r0ij
 485               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 486 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 487 C
 488               if (fcont.gt.0.0D0) then
 489 C If the SC-SC distance if close to sigma, apply spline.
 490 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 491 cAdam &             fcont1,fprimcont1)
 492 cAdam           fcont1=1.0d0-fcont1
 493 cAdam           if (fcont1.gt.0.0d0) then
 494 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 495 cAdam             fcont=fcont*fcont1
 496 cAdam           endif
 497 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 498 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 499 cga             do k=1,3
 500 cga               gg(k)=gg(k)*eps0ij
 501 cga             enddo
 502 cga             eps0ij=-evdwij*eps0ij
 503 C Uncomment for AL's type of SC correlation interactions.
 504 cadam           eps0ij=-evdwij
 505                 num_conti=num_conti+1
 506                 jcont(num_conti,i)=j
 507                 facont(num_conti,i)=fcont*eps0ij
 508                 fprimcont=eps0ij*fprimcont/rij
 509                 fcont=expon*fcont
 510 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 511 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 512 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 513 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 514                 gacont(1,num_conti,i)=-fprimcont*xj
 515                 gacont(2,num_conti,i)=-fprimcont*yj
 516                 gacont(3,num_conti,i)=-fprimcont*zj
 517 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 518 cd              write (iout,'(2i3,3f10.5)')
 519 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 520               endif
 521             endif
 522           enddo      ! j
 523         enddo        ! iint
 524 C Change 12/1/95
 525         num_cont(i)=num_conti
 526       enddo          ! i
 527       if (calc_grad) then
 528       do i=1,nct
 529         do j=1,3
 530           gvdwc(j,i)=expon*gvdwc(j,i)
 531           gvdwx(j,i)=expon*gvdwx(j,i)
 532         enddo
 533       enddo
 534       endif
 535 C******************************************************************************
 536 C
 537 C                              N O T E !!!
 538 C
 539 C To save time, the factor of EXPON has been extracted from ALL components
 540 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 541 C use!
 542 C
 543 C******************************************************************************
 544       return
 545       end
 546 C-----------------------------------------------------------------------------
 547       subroutine eljk(evdw)
 548 C
 549 C This subroutine calculates the interaction energy of nonbonded side chains
 550 C assuming the LJK potential of interaction.
 551 C
 552       implicit real*8 (a-h,o-z)
 553       include 'DIMENSIONS'
 554       include 'DIMENSIONS.ZSCOPT'
 555       include 'COMMON.GEO'
 556       include 'COMMON.VAR'
 557       include 'COMMON.LOCAL'
 558       include 'COMMON.CHAIN'
 559       include 'COMMON.DERIV'
 560       include 'COMMON.INTERACT'
 561       include 'COMMON.WEIGHTDER'
 562       include 'COMMON.IOUNITS'
 563       include 'COMMON.NAMES'
 564       dimension gg(3)
 565       logical scheck
 566       integer icant
 567       external icant
 568 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 569       do i=1,210
 570         do j=1,2
 571           eneps_temp(j,i)=0.0d0
 572         enddo
 573       enddo
 574       evdw=0.0D0
 575       do i=iatsc_s,iatsc_e
 576         itypi=itype(i)
 577         itypi1=itype(i+1)
 578         xi=c(1,nres+i)
 579         yi=c(2,nres+i)
 580         zi=c(3,nres+i)
 581 C
 582 C Calculate SC interaction energy.
 583 C
 584         do iint=1,nint_gr(i)
 585           do j=istart(i,iint),iend(i,iint)
 586             itypj=itype(j)
 587             xj=c(1,nres+j)-xi
 588             yj=c(2,nres+j)-yi
 589             zj=c(3,nres+j)-zi
 590             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 591             fac_augm=rrij**expon
 592             e_augm=augm(itypi,itypj)*fac_augm
 593             r_inv_ij=dsqrt(rrij)
 594             rij=1.0D0/r_inv_ij
 595             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 596             fac=r_shift_inv**expon
 597             e1=fac*fac*aa(itypi,itypj)
 598             e2=fac*bb(itypi,itypj)
 599             evdwij=e_augm+e1+e2
 600             ij=icant(itypi,itypj)
 601             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 602      &        /dabs(eps(itypi,itypj))
 603             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 604 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 605 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 606 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 607 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 608 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 609 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 610 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 611             evdw=evdw+evdwij
 612             if (calc_grad) then
 613 C
 614 C Calculate the components of the gradient in DC and X
 615 C
 616             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 617             gg(1)=xj*fac
 618             gg(2)=yj*fac
 619             gg(3)=zj*fac
 620             do k=1,3
 621               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 622               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 623             enddo
 624             do k=i,j-1
 625               do l=1,3
 626                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 627               enddo
 628             enddo
 629             endif
 630           enddo      ! j
 631         enddo        ! iint
 632       enddo          ! i
 633       if (calc_grad) then
 634       do i=1,nct
 635         do j=1,3
 636           gvdwc(j,i)=expon*gvdwc(j,i)
 637           gvdwx(j,i)=expon*gvdwx(j,i)
 638         enddo
 639       enddo
 640       endif
 641       return
 642       end
 643 C-----------------------------------------------------------------------------
 644       subroutine ebp(evdw)
 645 C
 646 C This subroutine calculates the interaction energy of nonbonded side chains
 647 C assuming the Berne-Pechukas potential of interaction.
 648 C
 649       implicit real*8 (a-h,o-z)
 650       include 'DIMENSIONS'
 651       include 'DIMENSIONS.ZSCOPT'
 652       include 'COMMON.GEO'
 653       include 'COMMON.VAR'
 654       include 'COMMON.LOCAL'
 655       include 'COMMON.CHAIN'
 656       include 'COMMON.DERIV'
 657       include 'COMMON.NAMES'
 658       include 'COMMON.INTERACT'
 659       include 'COMMON.WEIGHTDER'
 660       include 'COMMON.IOUNITS'
 661       include 'COMMON.CALC'
 662       common /srutu/ icall
 663 c     double precision rrsave(maxdim)
 664       logical lprn
 665       integer icant
 666       external icant
 667       do i=1,210
 668         do j=1,2
 669           eneps_temp(j,i)=0.0d0
 670         enddo
 671       enddo
 672       evdw=0.0D0
 673 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 674       evdw=0.0D0
 675 c     if (icall.eq.0) then
 676 c       lprn=.true.
 677 c     else
 678         lprn=.false.
 679 c     endif
 680       ind=0
 681       do i=iatsc_s,iatsc_e
 682         itypi=itype(i)
 683         itypi1=itype(i+1)
 684         xi=c(1,nres+i)
 685         yi=c(2,nres+i)
 686         zi=c(3,nres+i)
 687         dxi=dc_norm(1,nres+i)
 688         dyi=dc_norm(2,nres+i)
 689         dzi=dc_norm(3,nres+i)
 690         dsci_inv=vbld_inv(i+nres)
 691 C
 692 C Calculate SC interaction energy.
 693 C
 694         do iint=1,nint_gr(i)
 695           do j=istart(i,iint),iend(i,iint)
 696             ind=ind+1
 697             itypj=itype(j)
 698             dscj_inv=vbld_inv(j+nres)
 699             chi1=chi(itypi,itypj)
 700             chi2=chi(itypj,itypi)
 701             chi12=chi1*chi2
 702             chip1=chip(itypi)
 703             chip2=chip(itypj)
 704             chip12=chip1*chip2
 705             alf1=alp(itypi)
 706             alf2=alp(itypj)
 707             alf12=0.5D0*(alf1+alf2)
 708 C For diagnostics only!!!
 709 c           chi1=0.0D0
 710 c           chi2=0.0D0
 711 c           chi12=0.0D0
 712 c           chip1=0.0D0
 713 c           chip2=0.0D0
 714 c           chip12=0.0D0
 715 c           alf1=0.0D0
 716 c           alf2=0.0D0
 717 c           alf12=0.0D0
 718             xj=c(1,nres+j)-xi
 719             yj=c(2,nres+j)-yi
 720             zj=c(3,nres+j)-zi
 721             dxj=dc_norm(1,nres+j)
 722             dyj=dc_norm(2,nres+j)
 723             dzj=dc_norm(3,nres+j)
 724             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 725 cd          if (icall.eq.0) then
 726 cd            rrsave(ind)=rrij
 727 cd          else
 728 cd            rrij=rrsave(ind)
 729 cd          endif
 730             rij=dsqrt(rrij)
 731 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 732             call sc_angular
 733 C Calculate whole angle-dependent part of epsilon and contributions
 734 C to its derivatives
 735             fac=(rrij*sigsq)**expon2
 736             e1=fac*fac*aa(itypi,itypj)
 737             e2=fac*bb(itypi,itypj)
 738             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 739             eps2der=evdwij*eps3rt
 740             eps3der=evdwij*eps2rt
 741             evdwij=evdwij*eps2rt*eps3rt
 742             ij=icant(itypi,itypj)
 743             aux=eps1*eps2rt**2*eps3rt**2
 744             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 745      &        /dabs(eps(itypi,itypj))
 746             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 747             evdw=evdw+evdwij
 748             if (calc_grad) then
 749             if (lprn) then
 750             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 751             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 752 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 753 cd     &        restyp(itypi),i,restyp(itypj),j,
 754 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 755 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 756 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 757 cd     &        evdwij
 758             endif
 759 C Calculate gradient components.
 760             e1=e1*eps1*eps2rt**2*eps3rt**2
 761             fac=-expon*(e1+evdwij)
 762             sigder=fac/sigsq
 763             fac=rrij*fac
 764 C Calculate radial part of the gradient
 765             gg(1)=xj*fac
 766             gg(2)=yj*fac
 767             gg(3)=zj*fac
 768 C Calculate the angular part of the gradient and sum add the contributions
 769 C to the appropriate components of the Cartesian gradient.
 770             call sc_grad
 771             endif
 772           enddo      ! j
 773         enddo        ! iint
 774       enddo          ! i
 775 c     stop
 776       return
 777       end
 778 C-----------------------------------------------------------------------------
 779       subroutine egb(evdw)
 780 C
 781 C This subroutine calculates the interaction energy of nonbonded side chains
 782 C assuming the Gay-Berne potential of interaction.
 783 C
 784       implicit real*8 (a-h,o-z)
 785       include 'DIMENSIONS'
 786       include 'DIMENSIONS.ZSCOPT'
 787       include 'COMMON.GEO'
 788       include 'COMMON.VAR'
 789       include 'COMMON.LOCAL'
 790       include 'COMMON.CHAIN'
 791       include 'COMMON.DERIV'
 792       include 'COMMON.NAMES'
 793       include 'COMMON.INTERACT'
 794       include 'COMMON.WEIGHTDER'
 795       include 'COMMON.IOUNITS'
 796       include 'COMMON.CALC'
 797       logical lprn
 798       common /srutu/icall
 799       integer icant
 800       external icant
 801       do i=1,210
 802         do j=1,2
 803           eneps_temp(j,i)=0.0d0
 804         enddo
 805       enddo
 806       evdw=0.0D0
 807 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 808       evdw=0.0D0
 809       lprn=.false.
 810 c      if (icall.gt.0) lprn=.true.
 811       ind=0
 812       do i=iatsc_s,iatsc_e
 813         itypi=itype(i)
 814         itypi1=itype(i+1)
 815         xi=c(1,nres+i)
 816         yi=c(2,nres+i)
 817         zi=c(3,nres+i)
 818         dxi=dc_norm(1,nres+i)
 819         dyi=dc_norm(2,nres+i)
 820         dzi=dc_norm(3,nres+i)
 821         dsci_inv=vbld_inv(i+nres)
 822 C
 823 C Calculate SC interaction energy.
 824 C
 825         do iint=1,nint_gr(i)
 826           do j=istart(i,iint),iend(i,iint)
 827             ind=ind+1
 828             itypj=itype(j)
 829             dscj_inv=vbld_inv(j+nres)
 830             sig0ij=sigma(itypi,itypj)
 831             chi1=chi(itypi,itypj)
 832             chi2=chi(itypj,itypi)
 833             chi12=chi1*chi2
 834             chip1=chip(itypi)
 835             chip2=chip(itypj)
 836             chip12=chip1*chip2
 837             alf1=alp(itypi)
 838             alf2=alp(itypj)
 839             alf12=0.5D0*(alf1+alf2)
 840 C For diagnostics only!!!
 841 c           chi1=0.0D0
 842 c           chi2=0.0D0
 843 c           chi12=0.0D0
 844 c           chip1=0.0D0
 845 c           chip2=0.0D0
 846 c           chip12=0.0D0
 847 c           alf1=0.0D0
 848 c           alf2=0.0D0
 849 c           alf12=0.0D0
 850             xj=c(1,nres+j)-xi
 851             yj=c(2,nres+j)-yi
 852             zj=c(3,nres+j)-zi
 853             dxj=dc_norm(1,nres+j)
 854             dyj=dc_norm(2,nres+j)
 855             dzj=dc_norm(3,nres+j)
 856 c            write (iout,*) i,j,xj,yj,zj
 857             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 858             rij=dsqrt(rrij)
 859 C Calculate angle-dependent terms of energy and contributions to their
 860 C derivatives.
 861             call sc_angular
 862             sigsq=1.0D0/sigsq
 863             sig=sig0ij*dsqrt(sigsq)
 864             rij_shift=1.0D0/rij-sig+sig0ij
 865 C I hate to put IF's in the loops, but here don't have another choice!!!!
 866             if (rij_shift.le.0.0D0) then
 867               evdw=1.0D20
 868               return
 869             endif
 870             sigder=-sig*sigsq
 871 c---------------------------------------------------------------
 872             rij_shift=1.0D0/rij_shift
 873             fac=rij_shift**expon
 874             e1=fac*fac*aa(itypi,itypj)
 875             e2=fac*bb(itypi,itypj)
 876             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 877             eps2der=evdwij*eps3rt
 878             eps3der=evdwij*eps2rt
 879             evdwij=evdwij*eps2rt*eps3rt
 880             evdw=evdw+evdwij
 881             ij=icant(itypi,itypj)
 882             aux=eps1*eps2rt**2*eps3rt**2
 883 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 884 c     &        /dabs(eps(itypi,itypj))
 885 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 886 c-----------------------
 887             eps0ij=eps(itypi,itypj)
 888             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
 889             rr0ij=r0(itypi,itypj)
 890             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
 891 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
 892 c-----------------------
 893 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 894 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 895 c     &         aux*e2/eps(itypi,itypj)
 896             if (lprn) then
 897             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 898             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 899             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 900      &        restyp(itypi),i,restyp(itypj),j,
 901      &        epsi,sigm,chi1,chi2,chip1,chip2,
 902      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 903      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 904      &        evdwij
 905             endif
 906             if (calc_grad) then
 907 C Calculate gradient components.
 908             e1=e1*eps1*eps2rt**2*eps3rt**2
 909             fac=-expon*(e1+evdwij)*rij_shift
 910             sigder=fac*sigder
 911             fac=rij*fac
 912 C Calculate the radial part of the gradient
 913             gg(1)=xj*fac
 914             gg(2)=yj*fac
 915             gg(3)=zj*fac
 916 C Calculate angular part of the gradient.
 917             call sc_grad
 918             endif
 919           enddo      ! j
 920         enddo        ! iint
 921       enddo          ! i
 922       return
 923       end
 924 C-----------------------------------------------------------------------------
 925       subroutine egbv(evdw)
 926 C
 927 C This subroutine calculates the interaction energy of nonbonded side chains
 928 C assuming the Gay-Berne-Vorobjev potential of interaction.
 929 C
 930       implicit real*8 (a-h,o-z)
 931       include 'DIMENSIONS'
 932       include 'DIMENSIONS.ZSCOPT'
 933       include 'COMMON.GEO'
 934       include 'COMMON.VAR'
 935       include 'COMMON.LOCAL'
 936       include 'COMMON.CHAIN'
 937       include 'COMMON.DERIV'
 938       include 'COMMON.NAMES'
 939       include 'COMMON.INTERACT'
 940       include 'COMMON.WEIGHTDER'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.CALC'
 943       common /srutu/ icall
 944       logical lprn
 945       integer icant
 946       external icant
 947       do i=1,210
 948         do j=1,2
 949           eneps_temp(j,i)=0.0d0
 950         enddo
 951       enddo
 952       evdw=0.0D0
 953 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 954       evdw=0.0D0
 955       lprn=.false.
 956 c      if (icall.gt.0) lprn=.true.
 957       ind=0
 958       do i=iatsc_s,iatsc_e
 959         itypi=itype(i)
 960         itypi1=itype(i+1)
 961         xi=c(1,nres+i)
 962         yi=c(2,nres+i)
 963         zi=c(3,nres+i)
 964         dxi=dc_norm(1,nres+i)
 965         dyi=dc_norm(2,nres+i)
 966         dzi=dc_norm(3,nres+i)
 967         dsci_inv=vbld_inv(i+nres)
 968 C
 969 C Calculate SC interaction energy.
 970 C
 971         do iint=1,nint_gr(i)
 972           do j=istart(i,iint),iend(i,iint)
 973             ind=ind+1
 974             itypj=itype(j)
 975             dscj_inv=vbld_inv(j+nres)
 976             sig0ij=sigma(itypi,itypj)
 977             r0ij=r0(itypi,itypj)
 978             chi1=chi(itypi,itypj)
 979             chi2=chi(itypj,itypi)
 980             chi12=chi1*chi2
 981             chip1=chip(itypi)
 982             chip2=chip(itypj)
 983             chip12=chip1*chip2
 984             alf1=alp(itypi)
 985             alf2=alp(itypj)
 986             alf12=0.5D0*(alf1+alf2)
 987 C For diagnostics only!!!
 988 c           chi1=0.0D0
 989 c           chi2=0.0D0
 990 c           chi12=0.0D0
 991 c           chip1=0.0D0
 992 c           chip2=0.0D0
 993 c           chip12=0.0D0
 994 c           alf1=0.0D0
 995 c           alf2=0.0D0
 996 c           alf12=0.0D0
 997             xj=c(1,nres+j)-xi
 998             yj=c(2,nres+j)-yi
 999             zj=c(3,nres+j)-zi
1000             dxj=dc_norm(1,nres+j)
1001             dyj=dc_norm(2,nres+j)
1002             dzj=dc_norm(3,nres+j)
1003             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1004             rij=dsqrt(rrij)
1005 C Calculate angle-dependent terms of energy and contributions to their
1006 C derivatives.
1007             call sc_angular
1008             sigsq=1.0D0/sigsq
1009             sig=sig0ij*dsqrt(sigsq)
1010             rij_shift=1.0D0/rij-sig+r0ij
1011 C I hate to put IF's in the loops, but here don't have another choice!!!!
1012             if (rij_shift.le.0.0D0) then
1013               evdw=1.0D20
1014               return
1015             endif
1016             sigder=-sig*sigsq
1017 c---------------------------------------------------------------
1018             rij_shift=1.0D0/rij_shift
1019             fac=rij_shift**expon
1020             e1=fac*fac*aa(itypi,itypj)
1021             e2=fac*bb(itypi,itypj)
1022             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1023             eps2der=evdwij*eps3rt
1024             eps3der=evdwij*eps2rt
1025             fac_augm=rrij**expon
1026             e_augm=augm(itypi,itypj)*fac_augm
1027             evdwij=evdwij*eps2rt*eps3rt
1028             evdw=evdw+evdwij+e_augm
1029             ij=icant(itypi,itypj)
1030             aux=eps1*eps2rt**2*eps3rt**2
1031             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1032      &        /dabs(eps(itypi,itypj))
1033             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1034 c            eneps_temp(ij)=eneps_temp(ij)
1035 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1036 c            if (lprn) then
1037 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1038 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1039 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1040 c     &        restyp(itypi),i,restyp(itypj),j,
1041 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1042 c     &        chi1,chi2,chip1,chip2,
1043 c     &        eps1,eps2rt**2,eps3rt**2,
1044 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1045 c     &        evdwij+e_augm
1046 c            endif
1047             if (calc_grad) then
1048 C Calculate gradient components.
1049             e1=e1*eps1*eps2rt**2*eps3rt**2
1050             fac=-expon*(e1+evdwij)*rij_shift
1051             sigder=fac*sigder
1052             fac=rij*fac-2*expon*rrij*e_augm
1053 C Calculate the radial part of the gradient
1054             gg(1)=xj*fac
1055             gg(2)=yj*fac
1056             gg(3)=zj*fac
1057 C Calculate angular part of the gradient.
1058             call sc_grad
1059             endif
1060           enddo      ! j
1061         enddo        ! iint
1062       enddo          ! i
1063       return
1064       end
1065 C-----------------------------------------------------------------------------
1066       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1067 C
1068 C This subroutine calculates the interaction energy of nonbonded side chains
1069 C assuming the Gay-Berne potential of interaction.
1070 C
1071        IMPLICIT NONE
1072        INCLUDE 'DIMENSIONS'
1073        INCLUDE 'DIMENSIONS.ZSCOPT'
1074        INCLUDE 'COMMON.CALC'
1075        INCLUDE 'COMMON.CONTROL'
1076        INCLUDE 'COMMON.CHAIN'
1077        INCLUDE 'COMMON.DERIV'
1078        INCLUDE 'COMMON.EMP'
1079        INCLUDE 'COMMON.GEO'
1080        INCLUDE 'COMMON.INTERACT'
1081        INCLUDE 'COMMON.IOUNITS'
1082        INCLUDE 'COMMON.LOCAL'
1083        INCLUDE 'COMMON.NAMES'
1084        INCLUDE 'COMMON.VAR'
1085        INCLUDE 'COMMON.WEIGHTDER'
1086        logical lprn,energy_dec
1087        double precision scalar
1088        double precision ener(4)
1089        integer troll
1090        integer iint,ij
1091        integer icant
1092
1093        energy_dec=.false.
1094        IF (energy_dec) write (iout,'(a)')
1095      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1096      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1097        evdw   = 0.0D0
1098        evdw_p = 0.0D0
1099        evdw_m = 0.0D0
1100 c DIAGNOSTICS
1101 ccccc      energy_dec=.false.
1102 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1103 c      lprn   = .false.
1104 c     if (icall.eq.0) lprn=.false.
1105 c END DIAGNOSTICS
1106 c      ind = 0
1107        DO i = iatsc_s, iatsc_e
1108         itypi  = itype(i)
1109 c        itypi1 = itype(i+1)
1110         dxi    = dc_norm(1,nres+i)
1111         dyi    = dc_norm(2,nres+i)
1112         dzi    = dc_norm(3,nres+i)
1113 c        dsci_inv=dsc_inv(itypi)
1114         dsci_inv = vbld_inv(i+nres)
1115 c        DO k = 1, 3
1116 c         ctail(k,1) = c(k, i+nres)
1117 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1118 c        END DO
1119         xi=c(1,nres+i)
1120         yi=c(2,nres+i)
1121         zi=c(3,nres+i)
1122 c!-------------------------------------------------------------------
1123 C Calculate SC interaction energy.
1124         DO iint = 1, nint_gr(i)
1125          DO j = istart(i,iint), iend(i,iint)
1126 c! initialize variables for electrostatic gradients
1127           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1128 c            ind=ind+1
1129 c            dscj_inv = dsc_inv(itypj)
1130           dscj_inv = vbld_inv(j+nres)
1131 c! rij holds 1/(distance of Calpha atoms)
1132           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1133           rij  = dsqrt(rrij)
1134 c!-------------------------------------------------------------------
1135 C Calculate angle-dependent terms of energy and contributions to their
1136 C derivatives.
1137
1138 #IFDEF CHECK_MOMO
1139 c!      DO troll = 10, 5000
1140 c!      om1    = 0.0d0
1141 c!      om2    = 0.0d0
1142 c!      om12   = 1.0d0
1143 c!      sqom1  = om1 * om1
1144 c!      sqom2  = om2 * om2
1145 c!      sqom12 = om12 * om12
1146 c!      rij    = 5.0d0 / troll
1147 c!      rrij   = rij * rij
1148 c!      Rtail  = troll / 5.0d0
1149 c!      Rhead  = troll / 5.0d0
1150 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1151 c!      Rtail = dsqrt((Rtail**2)
1152 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1153 c!      rij = 1.0d0/Rtail
1154 c!      rrij = rij * rij
1155 #ENDIF
1156           CALL sc_angular
1157 c! this should be in elgrad_init but om's are calculated by sc_angular
1158 c! which in turn is used by older potentials
1159 c! which proves how tangled UNRES code is >.<
1160 c! om = omega, sqom = om^2
1161           sqom1  = om1 * om1
1162           sqom2  = om2 * om2
1163           sqom12 = om12 * om12
1164
1165 c! now we calculate EGB - Gey-Berne
1166 c! It will be summed up in evdwij and saved in evdw
1167           sigsq     = 1.0D0  / sigsq
1168           sig       = sig0ij * dsqrt(sigsq)
1169 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1170           rij_shift = Rtail - sig + sig0ij
1171           IF (rij_shift.le.0.0D0) THEN
1172            evdw = 1.0D20
1173            RETURN
1174           END IF
1175           sigder = -sig * sigsq
1176           rij_shift = 1.0D0 / rij_shift
1177           fac       = rij_shift**expon
1178           c1        = fac  * fac * aa(itypi,itypj)
1179 c!          c1        = 0.0d0
1180           c2        = fac  * bb(itypi,itypj)
1181 c!          c2        = 0.0d0
1182           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1183           eps2der   = eps3rt * evdwij
1184           eps3der   = eps2rt * evdwij
1185 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1186           evdwij    = eps2rt * eps3rt * evdwij
1187 c!      evdwij = 0.0d0
1188 c!      write (*,*) "Gey Berne = ", evdwij
1189 #ifdef TSCSC
1190           IF (bb(itypi,itypj).gt.0) THEN
1191            evdw_p = evdw_p + evdwij
1192           ELSE
1193            evdw_m = evdw_m + evdwij
1194           END IF
1195 #else
1196           evdw = evdw
1197      &         + evdwij
1198 #endif
1199 c!-------------------------------------------------------------------
1200 c! Calculate some components of GGB
1201           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1202           fac    = -expon * (c1 + evdwij) * rij_shift
1203           sigder = fac * sigder
1204 c!          fac    = rij * fac
1205 c! Calculate distance derivative
1206 c!          gg(1) = xj * fac
1207 c!          gg(2) = yj * fac
1208 c!          gg(3) = zj * fac
1209           gg(1) = fac
1210           gg(2) = fac
1211           gg(3) = fac
1212 c!      write (*,*) "gg(1) = ", gg(1)
1213 c!      write (*,*) "gg(2) = ", gg(2)
1214 c!      write (*,*) "gg(3) = ", gg(3)
1215 c! The angular derivatives of GGB are brought together in sc_grad
1216 c!-------------------------------------------------------------------
1217 c! Fcav
1218 c!
1219 c! Catch gly-gly interactions to skip calculation of something that
1220 c! does not exist
1221
1222       IF (itypi.eq.10.and.itypj.eq.10) THEN
1223        Fcav = 0.0d0
1224        dFdR = 0.0d0
1225        dCAVdOM1  = 0.0d0
1226        dCAVdOM2  = 0.0d0
1227        dCAVdOM12 = 0.0d0
1228       ELSE
1229
1230 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1231        fac = chis1 * sqom1 + chis2 * sqom2
1232      &     - 2.0d0 * chis12 * om1 * om2 * om12
1233 c! we will use pom later in Gcav, so dont mess with it!
1234        pom = 1.0d0 - chis1 * chis2 * sqom12
1235
1236        Lambf = (1.0d0 - (fac / pom))
1237        Lambf = dsqrt(Lambf)
1238
1239
1240        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1241 c!       write (*,*) "sparrow = ", sparrow
1242        Chif = Rtail * sparrow
1243        ChiLambf = Chif * Lambf
1244        eagle = dsqrt(ChiLambf)
1245        bat = ChiLambf ** 11.0d0
1246
1247        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1248        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1249        botsq = bot * bot
1250
1251 c!      write (*,*) "sig1 = ",sig1
1252 c!      write (*,*) "sig2 = ",sig2
1253 c!      write (*,*) "Rtail = ",Rtail
1254 c!      write (*,*) "sparrow = ",sparrow
1255 c!      write (*,*) "Chis1 = ", chis1
1256 c!      write (*,*) "Chis2 = ", chis2
1257 c!      write (*,*) "Chis12 = ", chis12
1258 c!      write (*,*) "om1 = ", om1
1259 c!      write (*,*) "om2 = ", om2
1260 c!      write (*,*) "om12 = ", om12
1261 c!      write (*,*) "sqom1 = ", sqom1
1262 c!      write (*,*) "sqom2 = ", sqom2
1263 c!      write (*,*) "sqom12 = ", sqom12
1264 c!      write (*,*) "Lambf = ",Lambf
1265 c!      write (*,*) "b1 = ",b1
1266 c!      write (*,*) "b2 = ",b2
1267 c!      write (*,*) "b3 = ",b3
1268 c!      write (*,*) "b4 = ",b4
1269 c!      write (*,*) "top = ",top
1270 c!      write (*,*) "bot = ",bot
1271        Fcav = top / bot
1272 c!       Fcav = 0.0d0
1273 c!      write (*,*) "Fcav = ", Fcav
1274 c!-------------------------------------------------------------------
1275 c! derivative of Fcav is Gcav...
1276 c!---------------------------------------------------
1277
1278        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1279        dbot = 12.0d0 * b4 * bat * Lambf
1280        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1281 c!       dFdR = 0.0d0
1282 c!      write (*,*) "dFcav/dR = ", dFdR
1283
1284        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1285        dbot = 12.0d0 * b4 * bat * Chif
1286        eagle = Lambf * pom
1287        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1288        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1289        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1290      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1291
1292        dFdL = ((dtop * bot - top * dbot) / botsq)
1293 c!       dFdL = 0.0d0
1294        dCAVdOM1  = dFdL * ( dFdOM1 )
1295        dCAVdOM2  = dFdL * ( dFdOM2 )
1296        dCAVdOM12 = dFdL * ( dFdOM12 )
1297 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1298 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1299 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1300 c!      write (*,*) ""
1301 c!-------------------------------------------------------------------
1302 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1303 c! Pom is used here to project the gradient vector into
1304 c! cartesian coordinates and at the same time contains
1305 c! dXhb/dXsc derivative (for charged amino acids
1306 c! location of hydrophobic centre of interaction is not
1307 c! the same as geometric centre of side chain, this
1308 c! derivative takes that into account)
1309 c! derivatives of omega angles will be added in sc_grad
1310
1311        DO k= 1, 3
1312         ertail(k) = Rtail_distance(k)/Rtail
1313        END DO
1314        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1315        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1316        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1317        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1318        DO k = 1, 3
1319 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1320 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1321         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1322         gvdwx(k,i) = gvdwx(k,i)
1323      &             - (( dFdR + gg(k) ) * pom)
1324 c!     &             - ( dFdR * pom )
1325         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1326         gvdwx(k,j) = gvdwx(k,j)
1327      &             + (( dFdR + gg(k) ) * pom)
1328 c!     &             + ( dFdR * pom )
1329
1330         gvdwc(k,i) = gvdwc(k,i)
1331      &             - (( dFdR + gg(k) ) * ertail(k))
1332 c!     &             - ( dFdR * ertail(k))
1333
1334         gvdwc(k,j) = gvdwc(k,j)
1335      &             + (( dFdR + gg(k) ) * ertail(k))
1336 c!     &             + ( dFdR * ertail(k))
1337
1338         gg(k) = 0.0d0
1339 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1340 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1341       END DO
1342
1343 c!-------------------------------------------------------------------
1344 c! Compute head-head and head-tail energies for each state
1345
1346           isel = iabs(Qi) + iabs(Qj)
1347           IF (isel.eq.0) THEN
1348 c! No charges - do nothing
1349            eheadtail = 0.0d0
1350
1351           ELSE IF (isel.eq.4) THEN
1352 c! Calculate dipole-dipole interactions
1353            CALL edd(ecl)
1354            eheadtail = ECL
1355
1356           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1357 c! Charge-nonpolar interactions
1358            CALL eqn(epol)
1359            eheadtail = epol
1360
1361           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1362 c! Nonpolar-charge interactions
1363            CALL enq(epol)
1364            eheadtail = epol
1365
1366           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1367 c! Charge-dipole interactions
1368            CALL eqd(ecl, elj, epol)
1369            eheadtail = ECL + elj + epol
1370
1371           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1372 c! Dipole-charge interactions
1373            CALL edq(ecl, elj, epol)
1374            eheadtail = ECL + elj + epol
1375
1376           ELSE IF ((isel.eq.2.and.
1377      &          iabs(Qi).eq.1).and.
1378      &          nstate(itypi,itypj).eq.1) THEN
1379 c! Same charge-charge interaction ( +/+ or -/- )
1380            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1381            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1382
1383           ELSE IF ((isel.eq.2.and.
1384      &          iabs(Qi).eq.1).and.
1385      &          nstate(itypi,itypj).ne.1) THEN
1386 c! Different charge-charge interaction ( +/- or -/+ )
1387            CALL energy_quad
1388      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1389           END IF
1390        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1391 c!      write (*,*) "evdw = ", evdw
1392 c!      write (*,*) "Fcav = ", Fcav
1393 c!      write (*,*) "eheadtail = ", eheadtail
1394        evdw = evdw
1395      &      + Fcav
1396      &      + eheadtail
1397        ij=icant(itypi,itypj)
1398        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1399        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1400        eneps_temp(3,ij)=eheadtail
1401        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1402      &  restyp(itype(i)),i,restyp(itype(j)),j,
1403      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1404      &  Equad,evdw
1405        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1406      &  restyp(itype(i)),i,restyp(itype(j)),j,
1407      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1408      &  Equad,evdw
1409 #IFDEF CHECK_MOMO
1410        evdw = 0.0d0
1411        END DO ! troll
1412 #ENDIF
1413
1414 c!-------------------------------------------------------------------
1415 c! As all angular derivatives are done, now we sum them up,
1416 c! then transform and project into cartesian vectors and add to gvdwc
1417 c! We call sc_grad always, with the exception of +/- interaction.
1418 c! This is because energy_quad subroutine needs to handle
1419 c! this job in his own way.
1420 c! This IS probably not very efficient and SHOULD be optimised
1421 c! but it will require major restructurization of emomo
1422 c! so it will be left as it is for now
1423 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1424        IF (nstate(itypi,itypj).eq.1) THEN
1425 #ifdef TSCSC
1426         IF (bb(itypi,itypj).gt.0) THEN
1427          CALL sc_grad
1428         ELSE
1429          CALL sc_grad_T
1430         END IF
1431 #else
1432         CALL sc_grad
1433 #endif
1434        END IF
1435 c!-------------------------------------------------------------------
1436 c! NAPISY KONCOWE
1437          END DO   ! j
1438         END DO    ! iint
1439        END DO     ! i
1440 c      write (iout,*) "Number of loop steps in EGB:",ind
1441 c      energy_dec=.false.
1442        RETURN
1443       END SUBROUTINE emomo
1444 c! END OF MOMO
1445 C-----------------------------------------------------------------------------
1446       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1447        IMPLICIT NONE
1448        INCLUDE 'DIMENSIONS'
1449        INCLUDE 'DIMENSIONS.ZSCOPT'
1450        INCLUDE 'COMMON.CALC'
1451        INCLUDE 'COMMON.CHAIN'
1452        INCLUDE 'COMMON.CONTROL'
1453        INCLUDE 'COMMON.DERIV'
1454        INCLUDE 'COMMON.EMP'
1455        INCLUDE 'COMMON.GEO'
1456        INCLUDE 'COMMON.INTERACT'
1457        INCLUDE 'COMMON.IOUNITS'
1458        INCLUDE 'COMMON.LOCAL'
1459        INCLUDE 'COMMON.NAMES'
1460        INCLUDE 'COMMON.VAR'
1461        double precision scalar, facd3, facd4, federmaus, adler
1462 c! Epol and Gpol analytical parameters
1463        alphapol1 = alphapol(itypi,itypj)
1464        alphapol2 = alphapol(itypj,itypi)
1465 c! Fisocav and Gisocav analytical parameters
1466        al1  = alphiso(1,itypi,itypj)
1467        al2  = alphiso(2,itypi,itypj)
1468        al3  = alphiso(3,itypi,itypj)
1469        al4  = alphiso(4,itypi,itypj)
1470        csig = (1.0d0
1471      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1472      &      + sigiso2(itypi,itypj)**2.0d0))
1473 c!
1474        pis  = sig0head(itypi,itypj)
1475        eps_head = epshead(itypi,itypj)
1476        Rhead_sq = Rhead * Rhead
1477 c! R1 - distance between head of ith side chain and tail of jth sidechain
1478 c! R2 - distance between head of jth side chain and tail of ith sidechain
1479        R1 = 0.0d0
1480        R2 = 0.0d0
1481        DO k = 1, 3
1482 c! Calculate head-to-tail distances needed by Epol
1483         R1=R1+(ctail(k,2)-chead(k,1))**2
1484         R2=R2+(chead(k,2)-ctail(k,1))**2
1485        END DO
1486 c! Pitagoras
1487        R1 = dsqrt(R1)
1488        R2 = dsqrt(R2)
1489
1490 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1491 c!     &        +dhead(1,1,itypi,itypj))**2))
1492 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1493 c!     &        +dhead(2,1,itypi,itypj))**2))
1494 c!-------------------------------------------------------------------
1495 c! Coulomb electrostatic interaction
1496        Ecl = (332.0d0 * Qij) / Rhead
1497 c! derivative of Ecl is Gcl...
1498        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1499        dGCLdOM1 = 0.0d0
1500        dGCLdOM2 = 0.0d0
1501        dGCLdOM12 = 0.0d0
1502 c!-------------------------------------------------------------------
1503 c! Generalised Born Solvent Polarization
1504 c! Charged head polarizes the solvent
1505        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1506        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1507        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1508 c! Derivative of Egb is Ggb...
1509        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1510        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1511      &        / ( 2.0d0 * Fgb )
1512        dGGBdR = dGGBdFGB * dFGBdR
1513 c!-------------------------------------------------------------------
1514 c! Fisocav - isotropic cavity creation term
1515 c! or "how much energy it costs to put charged head in water"
1516        pom = Rhead * csig
1517        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1518        bot = (1.0d0 + al4 * pom**12.0d0)
1519        botsq = bot * bot
1520        FisoCav = top / bot
1521 c!      write (*,*) "Rhead = ",Rhead
1522 c!      write (*,*) "csig = ",csig
1523 c!      write (*,*) "pom = ",pom
1524 c!      write (*,*) "al1 = ",al1
1525 c!      write (*,*) "al2 = ",al2
1526 c!      write (*,*) "al3 = ",al3
1527 c!      write (*,*) "al4 = ",al4
1528 c!      write (*,*) "top = ",top
1529 c!      write (*,*) "bot = ",bot
1530 c! Derivative of Fisocav is GCV...
1531        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1532        dbot = 12.0d0 * al4 * pom ** 11.0d0
1533        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1534 c!-------------------------------------------------------------------
1535 c! Epol
1536 c! Polarization energy - charged heads polarize hydrophobic "neck"
1537        MomoFac1 = (1.0d0 - chi1 * sqom2)
1538        MomoFac2 = (1.0d0 - chi2 * sqom1)
1539        RR1  = ( R1 * R1 ) / MomoFac1
1540        RR2  = ( R2 * R2 ) / MomoFac2
1541        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1542        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1543        fgb1 = sqrt( RR1 + a12sq * ee1 )
1544        fgb2 = sqrt( RR2 + a12sq * ee2 )
1545        epol = 332.0d0 * eps_inout_fac * (
1546      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1547 c!       epol = 0.0d0
1548 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1549 c       write (*,*) "alphapol1 = ", alphapol1
1550 c       write (*,*) "alphapol2 = ", alphapol2
1551 c       write (*,*) "fgb1 = ", fgb1
1552 c       write (*,*) "fgb2 = ", fgb2
1553 c       write (*,*) "epol = ", epol
1554 c! derivative of Epol is Gpol...
1555        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1556      &          / (fgb1 ** 5.0d0)
1557        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1558      &          / (fgb2 ** 5.0d0)
1559        dFGBdR1 = ( (R1 / MomoFac1)
1560      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1561      &        / ( 2.0d0 * fgb1 )
1562        dFGBdR2 = ( (R2 / MomoFac2)
1563      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1564      &        / ( 2.0d0 * fgb2 )
1565        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1566      &          * ( 2.0d0 - 0.5d0 * ee1) )
1567      &          / ( 2.0d0 * fgb1 )
1568        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1569      &          * ( 2.0d0 - 0.5d0 * ee2) )
1570      &          / ( 2.0d0 * fgb2 )
1571        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1572 c!       dPOLdR1 = 0.0d0
1573        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1574 c!       dPOLdR2 = 0.0d0
1575        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1576 c!       dPOLdOM1 = 0.0d0
1577        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1578 c!       dPOLdOM2 = 0.0d0
1579 c!-------------------------------------------------------------------
1580 c! Elj
1581 c! Lennard-Jones 6-12 interaction between heads
1582        pom = (pis / Rhead)**6.0d0
1583        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1584 c! derivative of Elj is Glj
1585        dGLJdR = 4.0d0 * eps_head
1586      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1587      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1588 c!-------------------------------------------------------------------
1589 c! Return the results
1590 c! These things do the dRdX derivatives, that is
1591 c! allow us to change what we see from function that changes with
1592 c! distance to function that changes with LOCATION (of the interaction
1593 c! site)
1594        DO k = 1, 3
1595         erhead(k) = Rhead_distance(k)/Rhead
1596         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1597         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1598        END DO
1599
1600        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1601        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1602        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1603        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1604        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1605        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1606        facd1 = d1 * vbld_inv(i+nres)
1607        facd2 = d2 * vbld_inv(j+nres)
1608        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1609        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1610
1611 c! Now we add appropriate partial derivatives (one in each dimension)
1612        DO k = 1, 3
1613         hawk   = (erhead_tail(k,1) +
1614      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1615         condor = (erhead_tail(k,2) +
1616      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1617
1618         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1619         gvdwx(k,i) = gvdwx(k,i)
1620      &             - dGCLdR * pom
1621      &             - dGGBdR * pom
1622      &             - dGCVdR * pom
1623      &             - dPOLdR1 * hawk
1624      &             - dPOLdR2 * (erhead_tail(k,2)
1625      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1626      &             - dGLJdR * pom
1627
1628         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1629         gvdwx(k,j) = gvdwx(k,j)
1630      &             + dGCLdR * pom
1631      &             + dGGBdR * pom
1632      &             + dGCVdR * pom
1633      &             + dPOLdR1 * (erhead_tail(k,1)
1634      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1635      &             + dPOLdR2 * condor
1636      &             + dGLJdR * pom
1637
1638         gvdwc(k,i) = gvdwc(k,i)
1639      &             - dGCLdR * erhead(k)
1640      &             - dGGBdR * erhead(k)
1641      &             - dGCVdR * erhead(k)
1642      &             - dPOLdR1 * erhead_tail(k,1)
1643      &             - dPOLdR2 * erhead_tail(k,2)
1644      &             - dGLJdR * erhead(k)
1645
1646         gvdwc(k,j) = gvdwc(k,j)
1647      &             + dGCLdR * erhead(k)
1648      &             + dGGBdR * erhead(k)
1649      &             + dGCVdR * erhead(k)
1650      &             + dPOLdR1 * erhead_tail(k,1)
1651      &             + dPOLdR2 * erhead_tail(k,2)
1652      &             + dGLJdR * erhead(k)
1653
1654        END DO
1655        RETURN
1656       END SUBROUTINE eqq
1657 c!-------------------------------------------------------------------
1658       SUBROUTINE energy_quad
1659      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1660        IMPLICIT NONE
1661        INCLUDE 'DIMENSIONS'
1662        INCLUDE 'DIMENSIONS.ZSCOPT'
1663        INCLUDE 'COMMON.CALC'
1664        INCLUDE 'COMMON.CHAIN'
1665        INCLUDE 'COMMON.CONTROL'
1666        INCLUDE 'COMMON.DERIV'
1667        INCLUDE 'COMMON.EMP'
1668        INCLUDE 'COMMON.GEO'
1669        INCLUDE 'COMMON.INTERACT'
1670        INCLUDE 'COMMON.IOUNITS'
1671        INCLUDE 'COMMON.LOCAL'
1672        INCLUDE 'COMMON.NAMES'
1673        INCLUDE 'COMMON.VAR'
1674        double precision scalar
1675        double precision ener(4)
1676        double precision dcosom1(3),dcosom2(3)
1677 c! used in Epol derivatives
1678        double precision facd3, facd4
1679        double precision federmaus, adler
1680 c! Epol and Gpol analytical parameters
1681        alphapol1 = alphapol(itypi,itypj)
1682        alphapol2 = alphapol(itypj,itypi)
1683 c! Fisocav and Gisocav analytical parameters
1684        al1  = alphiso(1,itypi,itypj)
1685        al2  = alphiso(2,itypi,itypj)
1686        al3  = alphiso(3,itypi,itypj)
1687        al4  = alphiso(4,itypi,itypj)
1688        csig = (1.0d0
1689      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1690      &      + sigiso2(itypi,itypj)**2.0d0))
1691 c!
1692        w1   = wqdip(1,itypi,itypj)
1693        w2   = wqdip(2,itypi,itypj)
1694        pis  = sig0head(itypi,itypj)
1695        eps_head = epshead(itypi,itypj)
1696 c! First things first:
1697 c! We need to do sc_grad's job with GB and Fcav
1698        eom1  =
1699      &         eps2der * eps2rt_om1
1700      &       - 2.0D0 * alf1 * eps3der
1701      &       + sigder * sigsq_om1
1702      &       + dCAVdOM1
1703        eom2  =
1704      &         eps2der * eps2rt_om2
1705      &       + 2.0D0 * alf2 * eps3der
1706      &       + sigder * sigsq_om2
1707      &       + dCAVdOM2
1708        eom12 =
1709      &         evdwij  * eps1_om12
1710      &       + eps2der * eps2rt_om12
1711      &       - 2.0D0 * alf12 * eps3der
1712      &       + sigder *sigsq_om12
1713      &       + dCAVdOM12
1714 c! now some magical transformations to project gradient into
1715 c! three cartesian vectors
1716        DO k = 1, 3
1717         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1718         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1719         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1720 c! this acts on hydrophobic center of interaction
1721         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1722      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1723      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1724         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1725      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1726      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1727 c! this acts on Calpha
1728         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1729         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1730        END DO
1731 c! sc_grad is done, now we will compute
1732        eheadtail = 0.0d0
1733        eom1 = 0.0d0
1734        eom2 = 0.0d0
1735        eom12 = 0.0d0
1736
1737 c! ENERGY DEBUG
1738 c!       ii = 1
1739 c!       jj = 1
1740 c!       d1 = dhead(1, 1, itypi, itypj)
1741 c!       d2 = dhead(2, 1, itypi, itypj)
1742 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1743 c!     &        +dhead(1,ii,itypi,itypj))**2))
1744 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1745 c!     &        +dhead(2,jj,itypi,itypj))**2))
1746 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1747 c! END OF ENERGY DEBUG
1748 c*************************************************************
1749        DO istate = 1, nstate(itypi,itypj)
1750 c*************************************************************
1751         IF (istate.ne.1) THEN
1752          IF (istate.lt.3) THEN
1753           ii = 1
1754          ELSE
1755           ii = 2
1756          END IF
1757         jj = istate/ii
1758         d1 = dhead(1,ii,itypi,itypj)
1759         d2 = dhead(2,jj,itypi,itypj)
1760         DO k = 1,3
1761          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1762          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1763          Rhead_distance(k) = chead(k,2) - chead(k,1)
1764         END DO
1765 c! pitagoras (root of sum of squares)
1766         Rhead = dsqrt(
1767      &          (Rhead_distance(1)*Rhead_distance(1))
1768      &        + (Rhead_distance(2)*Rhead_distance(2))
1769      &        + (Rhead_distance(3)*Rhead_distance(3)))
1770         END IF
1771         Rhead_sq = Rhead * Rhead
1772
1773 c! R1 - distance between head of ith side chain and tail of jth sidechain
1774 c! R2 - distance between head of jth side chain and tail of ith sidechain
1775         R1 = 0.0d0
1776         R2 = 0.0d0
1777         DO k = 1, 3
1778 c! Calculate head-to-tail distances
1779          R1=R1+(ctail(k,2)-chead(k,1))**2
1780          R2=R2+(chead(k,2)-ctail(k,1))**2
1781         END DO
1782 c! Pitagoras
1783         R1 = dsqrt(R1)
1784         R2 = dsqrt(R2)
1785
1786 c! ENERGY DEBUG
1787 c!      write (*,*) "istate = ", istate
1788 c!      write (*,*) "ii = ", ii
1789 c!      write (*,*) "jj = ", jj
1790 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1791 c!     &        +dhead(1,ii,itypi,itypj))**2))
1792 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1793 c!     &        +dhead(2,jj,itypi,itypj))**2))
1794 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1795 c!      Rhead_sq = Rhead * Rhead
1796 c!      write (*,*) "d1 = ",d1
1797 c!      write (*,*) "d2 = ",d2
1798 c!      write (*,*) "R1 = ",R1
1799 c!      write (*,*) "R2 = ",R2
1800 c!      write (*,*) "Rhead = ",Rhead
1801 c! END OF ENERGY DEBUG
1802
1803 c!-------------------------------------------------------------------
1804 c! Coulomb electrostatic interaction
1805         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1806 c!        Ecl = 0.0d0
1807 c!        write (*,*) "Ecl = ", Ecl
1808 c! derivative of Ecl is Gcl...
1809         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1810 c!        dGCLdR = 0.0d0
1811         dGCLdOM1 = 0.0d0
1812         dGCLdOM2 = 0.0d0
1813         dGCLdOM12 = 0.0d0
1814 c!-------------------------------------------------------------------
1815 c! Generalised Born Solvent Polarization
1816         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1817         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1818         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1819 c!        Egb = 0.0d0
1820 c!      write (*,*) "a1*a2 = ", a12sq
1821 c!      write (*,*) "Rhead = ", Rhead
1822 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1823 c!      write (*,*) "ee = ", ee
1824 c!      write (*,*) "Fgb = ", Fgb
1825 c!      write (*,*) "fac = ", eps_inout_fac
1826 c!      write (*,*) "Qij = ", Qij
1827 c!      write (*,*) "Egb = ", Egb
1828 c! Derivative of Egb is Ggb...
1829 c! dFGBdR is used by Quad's later...
1830         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1831         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1832      &         / ( 2.0d0 * Fgb )
1833         dGGBdR = dGGBdFGB * dFGBdR
1834 c!        dGGBdR = 0.0d0
1835 c!-------------------------------------------------------------------
1836 c! Fisocav - isotropic cavity creation term
1837         pom = Rhead * csig
1838         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1839         bot = (1.0d0 + al4 * pom**12.0d0)
1840         botsq = bot * bot
1841         FisoCav = top / bot
1842 c!        FisoCav = 0.0d0
1843 c!      write (*,*) "pom = ",pom
1844 c!      write (*,*) "al1 = ",al1
1845 c!      write (*,*) "al2 = ",al2
1846 c!      write (*,*) "al3 = ",al3
1847 c!      write (*,*) "al4 = ",al4
1848 c!      write (*,*) "top = ",top
1849 c!      write (*,*) "bot = ",bot
1850 c!      write (*,*) "Fisocav = ", Fisocav
1851
1852 c! Derivative of Fisocav is GCV...
1853         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1854         dbot = 12.0d0 * al4 * pom ** 11.0d0
1855         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1856 c!        dGCVdR = 0.0d0
1857 c!-------------------------------------------------------------------
1858 c! Polarization energy
1859 c! Epol
1860         MomoFac1 = (1.0d0 - chi1 * sqom2)
1861         MomoFac2 = (1.0d0 - chi2 * sqom1)
1862         RR1  = ( R1 * R1 ) / MomoFac1
1863         RR2  = ( R2 * R2 ) / MomoFac2
1864         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1865         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1866         fgb1 = sqrt( RR1 + a12sq * ee1 )
1867         fgb2 = sqrt( RR2 + a12sq * ee2 )
1868         epol = 332.0d0 * eps_inout_fac * (
1869      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1870 c!        epol = 0.0d0
1871 c! derivative of Epol is Gpol...
1872         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1873      &            / (fgb1 ** 5.0d0)
1874         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1875      &            / (fgb2 ** 5.0d0)
1876         dFGBdR1 = ( (R1 / MomoFac1)
1877      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1878      &          / ( 2.0d0 * fgb1 )
1879         dFGBdR2 = ( (R2 / MomoFac2)
1880      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1881      &          / ( 2.0d0 * fgb2 )
1882         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1883      &           * ( 2.0d0 - 0.5d0 * ee1) )
1884      &           / ( 2.0d0 * fgb1 )
1885         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1886      &           * ( 2.0d0 - 0.5d0 * ee2) )
1887      &           / ( 2.0d0 * fgb2 )
1888         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1889 c!        dPOLdR1 = 0.0d0
1890         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1891 c!        dPOLdR2 = 0.0d0
1892         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1893 c!        dPOLdOM1 = 0.0d0
1894         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1895 c!        dPOLdOM2 = 0.0d0
1896 c!-------------------------------------------------------------------
1897 c! Elj
1898         pom = (pis / Rhead)**6.0d0
1899         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1900 c!        Elj = 0.0d0
1901 c! derivative of Elj is Glj
1902         dGLJdR = 4.0d0 * eps_head
1903      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1904      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1905 c!        dGLJdR = 0.0d0
1906 c!-------------------------------------------------------------------
1907 c! Equad
1908        IF (Wqd.ne.0.0d0) THEN
1909         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1910      &        - 37.5d0  * ( sqom1 + sqom2 )
1911      &        + 157.5d0 * ( sqom1 * sqom2 )
1912      &        - 45.0d0  * om1*om2*om12
1913         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1914         Equad = fac * Beta1
1915 c!        Equad = 0.0d0
1916 c! derivative of Equad...
1917         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1918 c!        dQUADdR = 0.0d0
1919         dQUADdOM1 = fac
1920      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1921 c!        dQUADdOM1 = 0.0d0
1922         dQUADdOM2 = fac
1923      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1924 c!        dQUADdOM2 = 0.0d0
1925         dQUADdOM12 = fac
1926      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1927 c!        dQUADdOM12 = 0.0d0
1928         ELSE
1929          Beta1 = 0.0d0
1930          Equad = 0.0d0
1931         END IF
1932 c!-------------------------------------------------------------------
1933 c! Return the results
1934 c! Angular stuff
1935         eom1 = dPOLdOM1 + dQUADdOM1
1936         eom2 = dPOLdOM2 + dQUADdOM2
1937         eom12 = dQUADdOM12
1938 c! now some magical transformations to project gradient into
1939 c! three cartesian vectors
1940         DO k = 1, 3
1941          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1942          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1943          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1944         END DO
1945 c! Radial stuff
1946         DO k = 1, 3
1947          erhead(k) = Rhead_distance(k)/Rhead
1948          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1949          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1950         END DO
1951         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1952         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1953         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1954         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1955         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1956         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1957         facd1 = d1 * vbld_inv(i+nres)
1958         facd2 = d2 * vbld_inv(j+nres)
1959         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1960         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1961 c! Throw the results into gheadtail which holds gradients
1962 c! for each micro-state
1963         DO k = 1, 3
1964          hawk   = erhead_tail(k,1) +
1965      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1966          condor = erhead_tail(k,2) +
1967      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1968
1969          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1970 c! this acts on hydrophobic center of interaction
1971          gheadtail(k,1,1) = gheadtail(k,1,1)
1972      &                    - dGCLdR * pom
1973      &                    - dGGBdR * pom
1974      &                    - dGCVdR * pom
1975      &                    - dPOLdR1 * hawk
1976      &                    - dPOLdR2 * (erhead_tail(k,2)
1977      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1978      &                    - dGLJdR * pom
1979      &                    - dQUADdR * pom
1980      &                    - tuna(k)
1981      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1982      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1983
1984          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1985 c! this acts on hydrophobic center of interaction
1986          gheadtail(k,2,1) = gheadtail(k,2,1)
1987      &                    + dGCLdR * pom
1988      &                    + dGGBdR * pom
1989      &                    + dGCVdR * pom
1990      &                    + dPOLdR1 * (erhead_tail(k,1)
1991      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1992      &                    + dPOLdR2 * condor
1993      &                    + dGLJdR * pom
1994      &                    + dQUADdR * pom
1995      &                    + tuna(k)
1996      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1997      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1998
1999 c! this acts on Calpha
2000          gheadtail(k,3,1) = gheadtail(k,3,1)
2001      &                    - dGCLdR * erhead(k)
2002      &                    - dGGBdR * erhead(k)
2003      &                    - dGCVdR * erhead(k)
2004      &                    - dPOLdR1 * erhead_tail(k,1)
2005      &                    - dPOLdR2 * erhead_tail(k,2)
2006      &                    - dGLJdR * erhead(k)
2007      &                    - dQUADdR * erhead(k)
2008      &                    - tuna(k)
2009
2010 c! this acts on Calpha
2011          gheadtail(k,4,1) = gheadtail(k,4,1)
2012      &                    + dGCLdR * erhead(k)
2013      &                    + dGGBdR * erhead(k)
2014      &                    + dGCVdR * erhead(k)
2015      &                    + dPOLdR1 * erhead_tail(k,1)
2016      &                    + dPOLdR2 * erhead_tail(k,2)
2017      &                    + dGLJdR * erhead(k)
2018      &                    + dQUADdR * erhead(k)
2019      &                    + tuna(k)
2020         END DO
2021 c!      write(*,*) "ECL = ", Ecl
2022 c!      write(*,*) "Egb = ", Egb
2023 c!      write(*,*) "Epol = ", Epol
2024 c!      write(*,*) "Fisocav = ", Fisocav
2025 c!      write(*,*) "Elj = ", Elj
2026 c!      write(*,*) "Equad = ", Equad
2027 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2028 c!      write(*,*) "eheadtail = ", eheadtail
2029 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2030 c!      write(*,*) "dGCLdR = ", dGCLdR
2031 c!      write(*,*) "dGGBdR = ", dGGBdR
2032 c!      write(*,*) "dGCVdR = ", dGCVdR
2033 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2034 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2035 c!      write(*,*) "dGLJdR = ", dGLJdR
2036 c!      write(*,*) "dQUADdR = ", dQUADdR
2037 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2038         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2039         eheadtail = eheadtail
2040      &            + wstate(istate, itypi, itypj)
2041      &            * dexp(-betaT * ener(istate))
2042 c! foreach cartesian dimension
2043         DO k = 1, 3
2044 c! foreach of two gvdwx and gvdwc
2045          DO l = 1, 4
2046           gheadtail(k,l,2) = gheadtail(k,l,2)
2047      &                     + wstate( istate, itypi, itypj )
2048      &                     * dexp(-betaT * ener(istate))
2049      &                     * gheadtail(k,l,1)
2050           gheadtail(k,l,1) = 0.0d0
2051          END DO
2052         END DO
2053        END DO
2054 c! Here ended the gigantic DO istate = 1, 4, which starts
2055 c! at the beggining of the subroutine
2056
2057        DO k = 1, 3
2058         DO l = 1, 4
2059          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2060         END DO
2061         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2062         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2063         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2064         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2065         DO l = 1, 4
2066          gheadtail(k,l,1) = 0.0d0
2067          gheadtail(k,l,2) = 0.0d0
2068         END DO
2069        END DO
2070        eheadtail = (-dlog(eheadtail)) / betaT
2071        dPOLdOM1 = 0.0d0
2072        dPOLdOM2 = 0.0d0
2073        dQUADdOM1 = 0.0d0
2074        dQUADdOM2 = 0.0d0
2075        dQUADdOM12 = 0.0d0
2076        RETURN
2077       END SUBROUTINE energy_quad
2078 c!-------------------------------------------------------------------
2079       SUBROUTINE eqn(Epol)
2080       IMPLICIT NONE
2081       INCLUDE 'DIMENSIONS'
2082       INCLUDE 'DIMENSIONS.ZSCOPT'
2083       INCLUDE 'COMMON.CALC'
2084       INCLUDE 'COMMON.CHAIN'
2085       INCLUDE 'COMMON.CONTROL'
2086       INCLUDE 'COMMON.DERIV'
2087       INCLUDE 'COMMON.EMP'
2088       INCLUDE 'COMMON.GEO'
2089       INCLUDE 'COMMON.INTERACT'
2090       INCLUDE 'COMMON.IOUNITS'
2091       INCLUDE 'COMMON.LOCAL'
2092       INCLUDE 'COMMON.NAMES'
2093       INCLUDE 'COMMON.VAR'
2094       double precision scalar, facd4, federmaus
2095       alphapol1 = alphapol(itypi,itypj)
2096 c! R1 - distance between head of ith side chain and tail of jth sidechain
2097        R1 = 0.0d0
2098        DO k = 1, 3
2099 c! Calculate head-to-tail distances
2100         R1=R1+(ctail(k,2)-chead(k,1))**2
2101        END DO
2102 c! Pitagoras
2103        R1 = dsqrt(R1)
2104
2105 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2106 c!     &        +dhead(1,1,itypi,itypj))**2))
2107 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2108 c!     &        +dhead(2,1,itypi,itypj))**2))
2109 c--------------------------------------------------------------------
2110 c Polarization energy
2111 c Epol
2112        MomoFac1 = (1.0d0 - chi1 * sqom2)
2113        RR1  = R1 * R1 / MomoFac1
2114        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2115        fgb1 = sqrt( RR1 + a12sq * ee1)
2116        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2117 c!       epol = 0.0d0
2118 c!------------------------------------------------------------------
2119 c! derivative of Epol is Gpol...
2120        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2121      &          / (fgb1 ** 5.0d0)
2122        dFGBdR1 = ( (R1 / MomoFac1)
2123      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2124      &        / ( 2.0d0 * fgb1 )
2125        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2126      &          * (2.0d0 - 0.5d0 * ee1) )
2127      &          / (2.0d0 * fgb1)
2128        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2129 c!       dPOLdR1 = 0.0d0
2130        dPOLdOM1 = 0.0d0
2131        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2132 c!       dPOLdOM2 = 0.0d0
2133 c!-------------------------------------------------------------------
2134 c! Return the results
2135 c! (see comments in Eqq)
2136        DO k = 1, 3
2137         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2138        END DO
2139        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2140        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2141        facd1 = d1 * vbld_inv(i+nres)
2142        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2143
2144        DO k = 1, 3
2145         hawk = (erhead_tail(k,1) +
2146      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2147
2148         gvdwx(k,i) = gvdwx(k,i)
2149      &             - dPOLdR1 * hawk
2150         gvdwx(k,j) = gvdwx(k,j)
2151      &             + dPOLdR1 * (erhead_tail(k,1)
2152      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2153
2154         gvdwc(k,i) = gvdwc(k,i)
2155      &             - dPOLdR1 * erhead_tail(k,1)
2156         gvdwc(k,j) = gvdwc(k,j)
2157      &             + dPOLdR1 * erhead_tail(k,1)
2158
2159        END DO
2160        RETURN
2161       END SUBROUTINE eqn
2162
2163
2164 c!-------------------------------------------------------------------
2165
2166
2167
2168       SUBROUTINE enq(Epol)
2169        IMPLICIT NONE
2170        INCLUDE 'DIMENSIONS'
2171        INCLUDE 'DIMENSIONS.ZSCOPT'
2172        INCLUDE 'COMMON.CALC'
2173        INCLUDE 'COMMON.CHAIN'
2174        INCLUDE 'COMMON.CONTROL'
2175        INCLUDE 'COMMON.DERIV'
2176        INCLUDE 'COMMON.EMP'
2177        INCLUDE 'COMMON.GEO'
2178        INCLUDE 'COMMON.INTERACT'
2179        INCLUDE 'COMMON.IOUNITS'
2180        INCLUDE 'COMMON.LOCAL'
2181        INCLUDE 'COMMON.NAMES'
2182        INCLUDE 'COMMON.VAR'
2183        double precision scalar, facd3, adler
2184        alphapol2 = alphapol(itypj,itypi)
2185 c! R2 - distance between head of jth side chain and tail of ith sidechain
2186        R2 = 0.0d0
2187        DO k = 1, 3
2188 c! Calculate head-to-tail distances
2189         R2=R2+(chead(k,2)-ctail(k,1))**2
2190        END DO
2191 c! Pitagoras
2192        R2 = dsqrt(R2)
2193
2194 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2195 c!     &        +dhead(1,1,itypi,itypj))**2))
2196 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2197 c!     &        +dhead(2,1,itypi,itypj))**2))
2198 c------------------------------------------------------------------------
2199 c Polarization energy
2200        MomoFac2 = (1.0d0 - chi2 * sqom1)
2201        RR2  = R2 * R2 / MomoFac2
2202        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2203        fgb2 = sqrt(RR2  + a12sq * ee2)
2204        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2205 c!       epol = 0.0d0
2206 c!-------------------------------------------------------------------
2207 c! derivative of Epol is Gpol...
2208        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2209      &          / (fgb2 ** 5.0d0)
2210        dFGBdR2 = ( (R2 / MomoFac2)
2211      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2212      &        / (2.0d0 * fgb2)
2213        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2214      &          * (2.0d0 - 0.5d0 * ee2) )
2215      &          / (2.0d0 * fgb2)
2216        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2217 c!       dPOLdR2 = 0.0d0
2218        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2219 c!       dPOLdOM1 = 0.0d0
2220        dPOLdOM2 = 0.0d0
2221 c!-------------------------------------------------------------------
2222 c! Return the results
2223 c! (See comments in Eqq)
2224        DO k = 1, 3
2225         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2226        END DO
2227        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2228        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2229        facd2 = d2 * vbld_inv(j+nres)
2230        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2231        DO k = 1, 3
2232         condor = (erhead_tail(k,2)
2233      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2234
2235         gvdwx(k,i) = gvdwx(k,i)
2236      &             - dPOLdR2 * (erhead_tail(k,2)
2237      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2238         gvdwx(k,j) = gvdwx(k,j)
2239      &             + dPOLdR2 * condor
2240
2241         gvdwc(k,i) = gvdwc(k,i)
2242      &             - dPOLdR2 * erhead_tail(k,2)
2243         gvdwc(k,j) = gvdwc(k,j)
2244      &             + dPOLdR2 * erhead_tail(k,2)
2245
2246        END DO
2247       RETURN
2248       END SUBROUTINE enq
2249
2250
2251 c!-------------------------------------------------------------------
2252
2253
2254       SUBROUTINE eqd(Ecl,Elj,Epol)
2255        IMPLICIT NONE
2256        INCLUDE 'DIMENSIONS'
2257        INCLUDE 'DIMENSIONS.ZSCOPT'
2258        INCLUDE 'COMMON.CALC'
2259        INCLUDE 'COMMON.CHAIN'
2260        INCLUDE 'COMMON.CONTROL'
2261        INCLUDE 'COMMON.DERIV'
2262        INCLUDE 'COMMON.EMP'
2263        INCLUDE 'COMMON.GEO'
2264        INCLUDE 'COMMON.INTERACT'
2265        INCLUDE 'COMMON.IOUNITS'
2266        INCLUDE 'COMMON.LOCAL'
2267        INCLUDE 'COMMON.NAMES'
2268        INCLUDE 'COMMON.VAR'
2269        double precision scalar, facd4, federmaus
2270        alphapol1 = alphapol(itypi,itypj)
2271        w1        = wqdip(1,itypi,itypj)
2272        w2        = wqdip(2,itypi,itypj)
2273        pis       = sig0head(itypi,itypj)
2274        eps_head   = epshead(itypi,itypj)
2275 c!-------------------------------------------------------------------
2276 c! R1 - distance between head of ith side chain and tail of jth sidechain
2277        R1 = 0.0d0
2278        DO k = 1, 3
2279 c! Calculate head-to-tail distances
2280         R1=R1+(ctail(k,2)-chead(k,1))**2
2281        END DO
2282 c! Pitagoras
2283        R1 = dsqrt(R1)
2284
2285 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2286 c!     &        +dhead(1,1,itypi,itypj))**2))
2287 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2288 c!     &        +dhead(2,1,itypi,itypj))**2))
2289
2290 c!-------------------------------------------------------------------
2291 c! ecl
2292        sparrow  = w1 * Qi * om1
2293        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2294        Ecl = sparrow / Rhead**2.0d0
2295      &     - hawk    / Rhead**4.0d0
2296 c!-------------------------------------------------------------------
2297 c! derivative of ecl is Gcl
2298 c! dF/dr part
2299        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2300      &           + 4.0d0 * hawk    / Rhead**5.0d0
2301 c! dF/dom1
2302        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2303 c! dF/dom2
2304        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2305 c--------------------------------------------------------------------
2306 c Polarization energy
2307 c Epol
2308        MomoFac1 = (1.0d0 - chi1 * sqom2)
2309        RR1  = R1 * R1 / MomoFac1
2310        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2311        fgb1 = sqrt( RR1 + a12sq * ee1)
2312        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2313 c!       epol = 0.0d0
2314 c!------------------------------------------------------------------
2315 c! derivative of Epol is Gpol...
2316        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2317      &          / (fgb1 ** 5.0d0)
2318        dFGBdR1 = ( (R1 / MomoFac1)
2319      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2320      &        / ( 2.0d0 * fgb1 )
2321        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2322      &          * (2.0d0 - 0.5d0 * ee1) )
2323      &          / (2.0d0 * fgb1)
2324        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2325 c!       dPOLdR1 = 0.0d0
2326        dPOLdOM1 = 0.0d0
2327        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2328 c!       dPOLdOM2 = 0.0d0
2329 c!-------------------------------------------------------------------
2330 c! Elj
2331        pom = (pis / Rhead)**6.0d0
2332        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2333 c! derivative of Elj is Glj
2334        dGLJdR = 4.0d0 * eps_head
2335      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2336      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2337 c!-------------------------------------------------------------------
2338 c! Return the results
2339        DO k = 1, 3
2340         erhead(k) = Rhead_distance(k)/Rhead
2341         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2342        END DO
2343
2344        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2345        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2346        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2347        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2348        facd1 = d1 * vbld_inv(i+nres)
2349        facd2 = d2 * vbld_inv(j+nres)
2350        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2351
2352        DO k = 1, 3
2353         hawk = (erhead_tail(k,1) +
2354      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2355
2356         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2357         gvdwx(k,i) = gvdwx(k,i)
2358      &             - dGCLdR * pom
2359      &             - dPOLdR1 * hawk
2360      &             - dGLJdR * pom
2361
2362         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2363         gvdwx(k,j) = gvdwx(k,j)
2364      &             + dGCLdR * pom
2365      &             + dPOLdR1 * (erhead_tail(k,1)
2366      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2367      &             + dGLJdR * pom
2368
2369
2370         gvdwc(k,i) = gvdwc(k,i)
2371      &             - dGCLdR * erhead(k)
2372      &             - dPOLdR1 * erhead_tail(k,1)
2373      &             - dGLJdR * erhead(k)
2374
2375         gvdwc(k,j) = gvdwc(k,j)
2376      &             + dGCLdR * erhead(k)
2377      &             + dPOLdR1 * erhead_tail(k,1)
2378      &             + dGLJdR * erhead(k)
2379
2380        END DO
2381        RETURN
2382       END SUBROUTINE eqd
2383
2384
2385 c!-------------------------------------------------------------------
2386
2387
2388       SUBROUTINE edq(Ecl,Elj,Epol)
2389        IMPLICIT NONE
2390        INCLUDE 'DIMENSIONS'
2391        INCLUDE 'DIMENSIONS.ZSCOPT'
2392        INCLUDE 'COMMON.CALC'
2393        INCLUDE 'COMMON.CHAIN'
2394        INCLUDE 'COMMON.CONTROL'
2395        INCLUDE 'COMMON.DERIV'
2396        INCLUDE 'COMMON.EMP'
2397        INCLUDE 'COMMON.GEO'
2398        INCLUDE 'COMMON.INTERACT'
2399        INCLUDE 'COMMON.IOUNITS'
2400        INCLUDE 'COMMON.LOCAL'
2401        INCLUDE 'COMMON.NAMES'
2402        INCLUDE 'COMMON.VAR'
2403        double precision scalar, facd3, adler
2404        alphapol2 = alphapol(itypj,itypi)
2405        w1        = wqdip(1,itypi,itypj)
2406        w2        = wqdip(2,itypi,itypj)
2407        pis       = sig0head(itypi,itypj)
2408        eps_head  = epshead(itypi,itypj)
2409 c!-------------------------------------------------------------------
2410 c! R2 - distance between head of jth side chain and tail of ith sidechain
2411        R2 = 0.0d0
2412        DO k = 1, 3
2413 c! Calculate head-to-tail distances
2414         R2=R2+(chead(k,2)-ctail(k,1))**2
2415        END DO
2416 c! Pitagoras
2417        R2 = dsqrt(R2)
2418
2419 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2420 c!     &        +dhead(1,1,itypi,itypj))**2))
2421 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2422 c!     &        +dhead(2,1,itypi,itypj))**2))
2423
2424
2425 c!-------------------------------------------------------------------
2426 c! ecl
2427        sparrow  = w1 * Qi * om1
2428        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2429        ECL = sparrow / Rhead**2.0d0
2430      &     - hawk    / Rhead**4.0d0
2431 c!-------------------------------------------------------------------
2432 c! derivative of ecl is Gcl
2433 c! dF/dr part
2434        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2435      &           + 4.0d0 * hawk    / Rhead**5.0d0
2436 c! dF/dom1
2437        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2438 c! dF/dom2
2439        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2440 c--------------------------------------------------------------------
2441 c Polarization energy
2442 c Epol
2443        MomoFac2 = (1.0d0 - chi2 * sqom1)
2444        RR2  = R2 * R2 / MomoFac2
2445        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2446        fgb2 = sqrt(RR2  + a12sq * ee2)
2447        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2448 c!       epol = 0.0d0
2449 c! derivative of Epol is Gpol...
2450        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2451      &          / (fgb2 ** 5.0d0)
2452        dFGBdR2 = ( (R2 / MomoFac2)
2453      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2454      &        / (2.0d0 * fgb2)
2455        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2456      &          * (2.0d0 - 0.5d0 * ee2) )
2457      &          / (2.0d0 * fgb2)
2458        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2459 c!       dPOLdR2 = 0.0d0
2460        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2461 c!       dPOLdOM1 = 0.0d0
2462        dPOLdOM2 = 0.0d0
2463 c!-------------------------------------------------------------------
2464 c! Elj
2465        pom = (pis / Rhead)**6.0d0
2466        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2467 c! derivative of Elj is Glj
2468        dGLJdR = 4.0d0 * eps_head
2469      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2470      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2471 c!-------------------------------------------------------------------
2472 c! Return the results
2473 c! (see comments in Eqq)
2474        DO k = 1, 3
2475         erhead(k) = Rhead_distance(k)/Rhead
2476         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2477        END DO
2478        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2479        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2480        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2481        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2482        facd1 = d1 * vbld_inv(i+nres)
2483        facd2 = d2 * vbld_inv(j+nres)
2484        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2485
2486        DO k = 1, 3
2487         condor = (erhead_tail(k,2)
2488      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2489
2490         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2491         gvdwx(k,i) = gvdwx(k,i)
2492      &             - dGCLdR * pom
2493      &             - dPOLdR2 * (erhead_tail(k,2)
2494      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2495      &             - dGLJdR * pom
2496
2497         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2498         gvdwx(k,j) = gvdwx(k,j)
2499      &             + dGCLdR * pom
2500      &             + dPOLdR2 * condor
2501      &             + dGLJdR * pom
2502
2503
2504         gvdwc(k,i) = gvdwc(k,i)
2505      &             - dGCLdR * erhead(k)
2506      &             - dPOLdR2 * erhead_tail(k,2)
2507      &             - dGLJdR * erhead(k)
2508
2509         gvdwc(k,j) = gvdwc(k,j)
2510      &             + dGCLdR * erhead(k)
2511      &             + dPOLdR2 * erhead_tail(k,2)
2512      &             + dGLJdR * erhead(k)
2513
2514        END DO
2515        RETURN
2516       END SUBROUTINE edq
2517
2518
2519 C--------------------------------------------------------------------
2520
2521
2522       SUBROUTINE edd(ECL)
2523        IMPLICIT NONE
2524        INCLUDE 'DIMENSIONS'
2525        INCLUDE 'DIMENSIONS.ZSCOPT'
2526        INCLUDE 'COMMON.CALC'
2527        INCLUDE 'COMMON.CHAIN'
2528        INCLUDE 'COMMON.CONTROL'
2529        INCLUDE 'COMMON.DERIV'
2530        INCLUDE 'COMMON.EMP'
2531        INCLUDE 'COMMON.GEO'
2532        INCLUDE 'COMMON.INTERACT'
2533        INCLUDE 'COMMON.IOUNITS'
2534        INCLUDE 'COMMON.LOCAL'
2535        INCLUDE 'COMMON.NAMES'
2536        INCLUDE 'COMMON.VAR'
2537        double precision scalar
2538 c!       csig = sigiso(itypi,itypj)
2539        w1 = wqdip(1,itypi,itypj)
2540        w2 = wqdip(2,itypi,itypj)
2541 c!-------------------------------------------------------------------
2542 c! ECL
2543        fac = (om12 - 3.0d0 * om1 * om2)
2544        c1 = (w1 / (Rhead**3.0d0)) * fac
2545        c2 = (w2 / Rhead ** 6.0d0)
2546      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2547        ECL = c1 - c2
2548 c!       write (*,*) "w1 = ", w1
2549 c!       write (*,*) "w2 = ", w2
2550 c!       write (*,*) "om1 = ", om1
2551 c!       write (*,*) "om2 = ", om2
2552 c!       write (*,*) "om12 = ", om12
2553 c!       write (*,*) "fac = ", fac
2554 c!       write (*,*) "c1 = ", c1
2555 c!       write (*,*) "c2 = ", c2
2556 c!       write (*,*) "Ecl = ", Ecl
2557 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2558 c!       write (*,*) "c2_2 = ",
2559 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2560 c!-------------------------------------------------------------------
2561 c! dervative of ECL is GCL...
2562 c! dECL/dr
2563        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2564        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2565      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2566        dGCLdR = c1 - c2
2567 c! dECL/dom1
2568        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2569        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2570      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2571        dGCLdOM1 = c1 - c2
2572 c! dECL/dom2
2573        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2574        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2575      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2576        dGCLdOM2 = c1 - c2
2577 c! dECL/dom12
2578        c1 = w1 / (Rhead ** 3.0d0)
2579        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2580        dGCLdOM12 = c1 - c2
2581 c!-------------------------------------------------------------------
2582 c! Return the results
2583 c! (see comments in Eqq)
2584        DO k= 1, 3
2585         erhead(k) = Rhead_distance(k)/Rhead
2586        END DO
2587        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2588        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2589        facd1 = d1 * vbld_inv(i+nres)
2590        facd2 = d2 * vbld_inv(j+nres)
2591        DO k = 1, 3
2592
2593         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2594         gvdwx(k,i) = gvdwx(k,i)
2595      &             - dGCLdR * pom
2596         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2597         gvdwx(k,j) = gvdwx(k,j)
2598      &             + dGCLdR * pom
2599
2600         gvdwc(k,i) = gvdwc(k,i)
2601      &             - dGCLdR * erhead(k)
2602         gvdwc(k,j) = gvdwc(k,j)
2603      &             + dGCLdR * erhead(k)
2604        END DO
2605        RETURN
2606       END SUBROUTINE edd
2607
2608
2609 c!-------------------------------------------------------------------
2610
2611
2612       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2613        IMPLICIT NONE
2614 c! maxres
2615        INCLUDE 'DIMENSIONS'
2616        INCLUDE 'DIMENSIONS.ZSCOPT'
2617 c! itypi, itypj, i, j, k, l, chead,
2618        INCLUDE 'COMMON.CALC'
2619 c! c, nres, dc_norm
2620        INCLUDE 'COMMON.CHAIN'
2621 c! gradc, gradx
2622        INCLUDE 'COMMON.DERIV'
2623 c! electrostatic gradients-specific variables
2624        INCLUDE 'COMMON.EMP'
2625 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2626        INCLUDE 'COMMON.INTERACT'
2627 c! t_bath, Rb
2628 c       INCLUDE 'COMMON.MD'
2629 c! io for debug, disable it in final builds
2630        INCLUDE 'COMMON.IOUNITS'
2631        double precision Rb /1.987D-3/
2632 c!-------------------------------------------------------------------
2633 c! Variable Init
2634
2635 c! what amino acid is the aminoacid j'th?
2636        itypj = itype(j)
2637 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2638 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2639 c!       t_bath = 300
2640 c!       BetaT = 1.0d0 / (t_bath * Rb)
2641        BetaT = 1.0d0 / (298.0d0 * Rb)
2642 c! Gay-berne var's
2643        sig0ij = sigma( itypi,itypj )
2644        chi1   = chi( itypi, itypj )
2645        chi2   = chi( itypj, itypi )
2646        chi12  = chi1 * chi2
2647        chip1  = chipp( itypi, itypj )
2648        chip2  = chipp( itypj, itypi )
2649        chip12 = chip1 * chip2
2650 c! not used by momo potential, but needed by sc_angular which is shared
2651 c! by all energy_potential subroutines
2652        alf1   = 0.0d0
2653        alf2   = 0.0d0
2654        alf12  = 0.0d0
2655 c! location, location, location
2656        xj  = c( 1, nres+j ) - xi
2657        yj  = c( 2, nres+j ) - yi
2658        zj  = c( 3, nres+j ) - zi
2659        dxj = dc_norm( 1, nres+j )
2660        dyj = dc_norm( 2, nres+j )
2661        dzj = dc_norm( 3, nres+j )
2662 c! distance from center of chain(?) to polar/charged head
2663 c!       write (*,*) "istate = ", 1
2664 c!       write (*,*) "ii = ", 1
2665 c!       write (*,*) "jj = ", 1
2666        d1 = dhead(1, 1, itypi, itypj)
2667        d2 = dhead(2, 1, itypi, itypj)
2668 c! ai*aj from Fgb
2669        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2670 c!       a12sq = a12sq * a12sq
2671 c! charge of amino acid itypi is...
2672        Qi  = icharge(itypi)
2673        Qj  = icharge(itypj)
2674        Qij = Qi * Qj
2675 c! chis1,2,12
2676        chis1 = chis(itypi,itypj)
2677        chis2 = chis(itypj,itypi)
2678        chis12 = chis1 * chis2
2679        sig1 = sigmap1(itypi,itypj)
2680        sig2 = sigmap2(itypi,itypj)
2681 c!       write (*,*) "sig1 = ", sig1
2682 c!       write (*,*) "sig2 = ", sig2
2683 c! alpha factors from Fcav/Gcav
2684        b1 = alphasur(1,itypi,itypj)
2685        b2 = alphasur(2,itypi,itypj)
2686        b3 = alphasur(3,itypi,itypj)
2687        b4 = alphasur(4,itypi,itypj)
2688 c! used to determine whether we want to do quadrupole calculations
2689        wqd = wquad(itypi, itypj)
2690 c! used by Fgb
2691        eps_in = epsintab(itypi,itypj)
2692        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2693 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2694 c!-------------------------------------------------------------------
2695 c! tail location and distance calculations
2696        Rtail = 0.0d0
2697        DO k = 1, 3
2698         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2699         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2700        END DO
2701 c! tail distances will be themselves usefull elswhere
2702 c1 (in Gcav, for example)
2703        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2704        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2705        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2706        Rtail = dsqrt(
2707      &     (Rtail_distance(1)*Rtail_distance(1))
2708      &   + (Rtail_distance(2)*Rtail_distance(2))
2709      &   + (Rtail_distance(3)*Rtail_distance(3)))
2710 c!-------------------------------------------------------------------
2711 c! Calculate location and distance between polar heads
2712 c! distance between heads
2713 c! for each one of our three dimensional space...
2714        DO k = 1,3
2715 c! location of polar head is computed by taking hydrophobic centre
2716 c! and moving by a d1 * dc_norm vector
2717 c! see unres publications for very informative images
2718         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2719         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2720 c! distance
2721 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2722 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2723         Rhead_distance(k) = chead(k,2) - chead(k,1)
2724        END DO
2725 c! pitagoras (root of sum of squares)
2726        Rhead = dsqrt(
2727      &     (Rhead_distance(1)*Rhead_distance(1))
2728      &   + (Rhead_distance(2)*Rhead_distance(2))
2729      &   + (Rhead_distance(3)*Rhead_distance(3)))
2730 c!-------------------------------------------------------------------
2731 c! zero everything that should be zero'ed
2732        Egb = 0.0d0
2733        ECL = 0.0d0
2734        Elj = 0.0d0
2735        Equad = 0.0d0
2736        Epol = 0.0d0
2737        eheadtail = 0.0d0
2738        dGCLdOM1 = 0.0d0
2739        dGCLdOM2 = 0.0d0
2740        dGCLdOM12 = 0.0d0
2741        dPOLdOM1 = 0.0d0
2742        dPOLdOM2 = 0.0d0
2743        RETURN
2744       END SUBROUTINE elgrad_init
2745
2746
2747 C-----------------------------------------------------------------------------
2748       subroutine sc_angular
2749 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2750 C om12. Called by ebp, egb, and egbv.
2751       implicit none
2752       include 'COMMON.CALC'
2753       erij(1)=xj*rij
2754       erij(2)=yj*rij
2755       erij(3)=zj*rij
2756       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2757       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2758       om12=dxi*dxj+dyi*dyj+dzi*dzj
2759       chiom12=chi12*om12
2760 C Calculate eps1(om12) and its derivative in om12
2761       faceps1=1.0D0-om12*chiom12
2762       faceps1_inv=1.0D0/faceps1
2763       eps1=dsqrt(faceps1_inv)
2764 C Following variable is eps1*deps1/dom12
2765       eps1_om12=faceps1_inv*chiom12
2766 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2767 C and om12.
2768       om1om2=om1*om2
2769       chiom1=chi1*om1
2770       chiom2=chi2*om2
2771       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2772       sigsq=1.0D0-facsig*faceps1_inv
2773       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2774       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2775       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2776 C Calculate eps2 and its derivatives in om1, om2, and om12.
2777       chipom1=chip1*om1
2778       chipom2=chip2*om2
2779       chipom12=chip12*om12
2780       facp=1.0D0-om12*chipom12
2781       facp_inv=1.0D0/facp
2782       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2783 C Following variable is the square root of eps2
2784       eps2rt=1.0D0-facp1*facp_inv
2785 C Following three variables are the derivatives of the square root of eps
2786 C in om1, om2, and om12.
2787       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2788       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2789       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2790 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2791       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2792 C Calculate whole angle-dependent part of epsilon and contributions
2793 C to its derivatives
2794       return
2795       end
2796 C----------------------------------------------------------------------------
2797       subroutine sc_grad
2798       implicit real*8 (a-h,o-z)
2799       include 'DIMENSIONS'
2800       include 'DIMENSIONS.ZSCOPT'
2801       include 'COMMON.CHAIN'
2802       include 'COMMON.DERIV'
2803       include 'COMMON.CALC'
2804       double precision dcosom1(3),dcosom2(3)
2805       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2806       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2807       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2808      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2809       do k=1,3
2810         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2811         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2812       enddo
2813       do k=1,3
2814         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2815       enddo
2816       do k=1,3
2817         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2818      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2819      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2820         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2821      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2822      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2823       enddo
2824 C
2825 C Calculate the components of the gradient in DC and X
2826 C
2827       do k=i,j-1
2828         do l=1,3
2829           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2830         enddo
2831       enddo
2832       return
2833       end
2834 c------------------------------------------------------------------------------
2835       subroutine vec_and_deriv
2836       implicit real*8 (a-h,o-z)
2837       include 'DIMENSIONS'
2838       include 'DIMENSIONS.ZSCOPT'
2839       include 'COMMON.IOUNITS'
2840       include 'COMMON.GEO'
2841       include 'COMMON.VAR'
2842       include 'COMMON.LOCAL'
2843       include 'COMMON.CHAIN'
2844       include 'COMMON.VECTORS'
2845       include 'COMMON.DERIV'
2846       include 'COMMON.INTERACT'
2847       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2848 C Compute the local reference systems. For reference system (i), the
2849 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2850 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2851       do i=1,nres-1
2852 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2853           if (i.eq.nres-1) then
2854 C Case of the last full residue
2855 C Compute the Z-axis
2856             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2857             costh=dcos(pi-theta(nres))
2858             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2859             do k=1,3
2860               uz(k,i)=fac*uz(k,i)
2861             enddo
2862             if (calc_grad) then
2863 C Compute the derivatives of uz
2864             uzder(1,1,1)= 0.0d0
2865             uzder(2,1,1)=-dc_norm(3,i-1)
2866             uzder(3,1,1)= dc_norm(2,i-1)
2867             uzder(1,2,1)= dc_norm(3,i-1)
2868             uzder(2,2,1)= 0.0d0
2869             uzder(3,2,1)=-dc_norm(1,i-1)
2870             uzder(1,3,1)=-dc_norm(2,i-1)
2871             uzder(2,3,1)= dc_norm(1,i-1)
2872             uzder(3,3,1)= 0.0d0
2873             uzder(1,1,2)= 0.0d0
2874             uzder(2,1,2)= dc_norm(3,i)
2875             uzder(3,1,2)=-dc_norm(2,i)
2876             uzder(1,2,2)=-dc_norm(3,i)
2877             uzder(2,2,2)= 0.0d0
2878             uzder(3,2,2)= dc_norm(1,i)
2879             uzder(1,3,2)= dc_norm(2,i)
2880             uzder(2,3,2)=-dc_norm(1,i)
2881             uzder(3,3,2)= 0.0d0
2882             endif
2883 C Compute the Y-axis
2884             facy=fac
2885             do k=1,3
2886               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2887             enddo
2888             if (calc_grad) then
2889 C Compute the derivatives of uy
2890             do j=1,3
2891               do k=1,3
2892                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2893      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2894                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2895               enddo
2896               uyder(j,j,1)=uyder(j,j,1)-costh
2897               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2898             enddo
2899             do j=1,2
2900               do k=1,3
2901                 do l=1,3
2902                   uygrad(l,k,j,i)=uyder(l,k,j)
2903                   uzgrad(l,k,j,i)=uzder(l,k,j)
2904                 enddo
2905               enddo
2906             enddo
2907             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2908             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2909             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2910             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2911             endif
2912           else
2913 C Other residues
2914 C Compute the Z-axis
2915             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2916             costh=dcos(pi-theta(i+2))
2917             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2918             do k=1,3
2919               uz(k,i)=fac*uz(k,i)
2920             enddo
2921             if (calc_grad) then
2922 C Compute the derivatives of uz
2923             uzder(1,1,1)= 0.0d0
2924             uzder(2,1,1)=-dc_norm(3,i+1)
2925             uzder(3,1,1)= dc_norm(2,i+1)
2926             uzder(1,2,1)= dc_norm(3,i+1)
2927             uzder(2,2,1)= 0.0d0
2928             uzder(3,2,1)=-dc_norm(1,i+1)
2929             uzder(1,3,1)=-dc_norm(2,i+1)
2930             uzder(2,3,1)= dc_norm(1,i+1)
2931             uzder(3,3,1)= 0.0d0
2932             uzder(1,1,2)= 0.0d0
2933             uzder(2,1,2)= dc_norm(3,i)
2934             uzder(3,1,2)=-dc_norm(2,i)
2935             uzder(1,2,2)=-dc_norm(3,i)
2936             uzder(2,2,2)= 0.0d0
2937             uzder(3,2,2)= dc_norm(1,i)
2938             uzder(1,3,2)= dc_norm(2,i)
2939             uzder(2,3,2)=-dc_norm(1,i)
2940             uzder(3,3,2)= 0.0d0
2941             endif
2942 C Compute the Y-axis
2943             facy=fac
2944             do k=1,3
2945               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2946             enddo
2947             if (calc_grad) then
2948 C Compute the derivatives of uy
2949             do j=1,3
2950               do k=1,3
2951                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2952      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2953                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2954               enddo
2955               uyder(j,j,1)=uyder(j,j,1)-costh
2956               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2957             enddo
2958             do j=1,2
2959               do k=1,3
2960                 do l=1,3
2961                   uygrad(l,k,j,i)=uyder(l,k,j)
2962                   uzgrad(l,k,j,i)=uzder(l,k,j)
2963                 enddo
2964               enddo
2965             enddo
2966             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2967             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2968             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2969             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2970           endif
2971           endif
2972       enddo
2973       if (calc_grad) then
2974       do i=1,nres-1
2975         vbld_inv_temp(1)=vbld_inv(i+1)
2976         if (i.lt.nres-1) then
2977           vbld_inv_temp(2)=vbld_inv(i+2)
2978         else
2979           vbld_inv_temp(2)=vbld_inv(i)
2980         endif
2981         do j=1,2
2982           do k=1,3
2983             do l=1,3
2984               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2985               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2986             enddo
2987           enddo
2988         enddo
2989       enddo
2990       endif
2991       return
2992       end
2993 C-----------------------------------------------------------------------------
2994       subroutine vec_and_deriv_test
2995       implicit real*8 (a-h,o-z)
2996       include 'DIMENSIONS'
2997       include 'DIMENSIONS.ZSCOPT'
2998       include 'COMMON.IOUNITS'
2999       include 'COMMON.GEO'
3000       include 'COMMON.VAR'
3001       include 'COMMON.LOCAL'
3002       include 'COMMON.CHAIN'
3003       include 'COMMON.VECTORS'
3004       dimension uyder(3,3,2),uzder(3,3,2)
3005 C Compute the local reference systems. For reference system (i), the
3006 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3007 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3008       do i=1,nres-1
3009           if (i.eq.nres-1) then
3010 C Case of the last full residue
3011 C Compute the Z-axis
3012             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3013             costh=dcos(pi-theta(nres))
3014             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3015 c            write (iout,*) 'fac',fac,
3016 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3017             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3018             do k=1,3
3019               uz(k,i)=fac*uz(k,i)
3020             enddo
3021 C Compute the derivatives of uz
3022             uzder(1,1,1)= 0.0d0
3023             uzder(2,1,1)=-dc_norm(3,i-1)
3024             uzder(3,1,1)= dc_norm(2,i-1)
3025             uzder(1,2,1)= dc_norm(3,i-1)
3026             uzder(2,2,1)= 0.0d0
3027             uzder(3,2,1)=-dc_norm(1,i-1)
3028             uzder(1,3,1)=-dc_norm(2,i-1)
3029             uzder(2,3,1)= dc_norm(1,i-1)
3030             uzder(3,3,1)= 0.0d0
3031             uzder(1,1,2)= 0.0d0
3032             uzder(2,1,2)= dc_norm(3,i)
3033             uzder(3,1,2)=-dc_norm(2,i)
3034             uzder(1,2,2)=-dc_norm(3,i)
3035             uzder(2,2,2)= 0.0d0
3036             uzder(3,2,2)= dc_norm(1,i)
3037             uzder(1,3,2)= dc_norm(2,i)
3038             uzder(2,3,2)=-dc_norm(1,i)
3039             uzder(3,3,2)= 0.0d0
3040 C Compute the Y-axis
3041             do k=1,3
3042               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3043             enddo
3044             facy=fac
3045             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3046      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
3047      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
3048             do k=1,3
3049 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3050               uy(k,i)=
3051 c     &        facy*(
3052      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
3053      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
3054 c     &        )
3055             enddo
3056 c            write (iout,*) 'facy',facy,
3057 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3058             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3059             do k=1,3
3060               uy(k,i)=facy*uy(k,i)
3061             enddo
3062 C Compute the derivatives of uy
3063             do j=1,3
3064               do k=1,3
3065                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3066      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3067                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3068               enddo
3069 c              uyder(j,j,1)=uyder(j,j,1)-costh
3070 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3071               uyder(j,j,1)=uyder(j,j,1)
3072      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3073               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3074      &          +uyder(j,j,2)
3075             enddo
3076             do j=1,2
3077               do k=1,3
3078                 do l=1,3
3079                   uygrad(l,k,j,i)=uyder(l,k,j)
3080                   uzgrad(l,k,j,i)=uzder(l,k,j)
3081                 enddo
3082               enddo
3083             enddo
3084             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3085             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3086             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3087             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3088           else
3089 C Other residues
3090 C Compute the Z-axis
3091             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3092             costh=dcos(pi-theta(i+2))
3093             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3094             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3095             do k=1,3
3096               uz(k,i)=fac*uz(k,i)
3097             enddo
3098 C Compute the derivatives of uz
3099             uzder(1,1,1)= 0.0d0
3100             uzder(2,1,1)=-dc_norm(3,i+1)
3101             uzder(3,1,1)= dc_norm(2,i+1)
3102             uzder(1,2,1)= dc_norm(3,i+1)
3103             uzder(2,2,1)= 0.0d0
3104             uzder(3,2,1)=-dc_norm(1,i+1)
3105             uzder(1,3,1)=-dc_norm(2,i+1)
3106             uzder(2,3,1)= dc_norm(1,i+1)
3107             uzder(3,3,1)= 0.0d0
3108             uzder(1,1,2)= 0.0d0
3109             uzder(2,1,2)= dc_norm(3,i)
3110             uzder(3,1,2)=-dc_norm(2,i)
3111             uzder(1,2,2)=-dc_norm(3,i)
3112             uzder(2,2,2)= 0.0d0
3113             uzder(3,2,2)= dc_norm(1,i)
3114             uzder(1,3,2)= dc_norm(2,i)
3115             uzder(2,3,2)=-dc_norm(1,i)
3116             uzder(3,3,2)= 0.0d0
3117 C Compute the Y-axis
3118             facy=fac
3119             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3120      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3121      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3122             do k=1,3
3123 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3124               uy(k,i)=
3125 c     &        facy*(
3126      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3127      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3128 c     &        )
3129             enddo
3130 c            write (iout,*) 'facy',facy,
3131 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3132             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3133             do k=1,3
3134               uy(k,i)=facy*uy(k,i)
3135             enddo
3136 C Compute the derivatives of uy
3137             do j=1,3
3138               do k=1,3
3139                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3140      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3141                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3142               enddo
3143 c              uyder(j,j,1)=uyder(j,j,1)-costh
3144 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3145               uyder(j,j,1)=uyder(j,j,1)
3146      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3147               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3148      &          +uyder(j,j,2)
3149             enddo
3150             do j=1,2
3151               do k=1,3
3152                 do l=1,3
3153                   uygrad(l,k,j,i)=uyder(l,k,j)
3154                   uzgrad(l,k,j,i)=uzder(l,k,j)
3155                 enddo
3156               enddo
3157             enddo
3158             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3159             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3160             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3161             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3162           endif
3163       enddo
3164       do i=1,nres-1
3165         do j=1,2
3166           do k=1,3
3167             do l=1,3
3168               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3169               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3170             enddo
3171           enddo
3172         enddo
3173       enddo
3174       return
3175       end
3176 C-----------------------------------------------------------------------------
3177       subroutine check_vecgrad
3178       implicit real*8 (a-h,o-z)
3179       include 'DIMENSIONS'
3180       include 'DIMENSIONS.ZSCOPT'
3181       include 'COMMON.IOUNITS'
3182       include 'COMMON.GEO'
3183       include 'COMMON.VAR'
3184       include 'COMMON.LOCAL'
3185       include 'COMMON.CHAIN'
3186       include 'COMMON.VECTORS'
3187       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3188       dimension uyt(3,maxres),uzt(3,maxres)
3189       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3190       double precision delta /1.0d-7/
3191       call vec_and_deriv
3192 cd      do i=1,nres
3193 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3194 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3195 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3196 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3197 cd     &     (dc_norm(if90,i),if90=1,3)
3198 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3199 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3200 cd          write(iout,'(a)')
3201 cd      enddo
3202       do i=1,nres
3203         do j=1,2
3204           do k=1,3
3205             do l=1,3
3206               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3207               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3208             enddo
3209           enddo
3210         enddo
3211       enddo
3212       call vec_and_deriv
3213       do i=1,nres
3214         do j=1,3
3215           uyt(j,i)=uy(j,i)
3216           uzt(j,i)=uz(j,i)
3217         enddo
3218       enddo
3219       do i=1,nres
3220 cd        write (iout,*) 'i=',i
3221         do k=1,3
3222           erij(k)=dc_norm(k,i)
3223         enddo
3224         do j=1,3
3225           do k=1,3
3226             dc_norm(k,i)=erij(k)
3227           enddo
3228           dc_norm(j,i)=dc_norm(j,i)+delta
3229 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3230 c          do k=1,3
3231 c            dc_norm(k,i)=dc_norm(k,i)/fac
3232 c          enddo
3233 c          write (iout,*) (dc_norm(k,i),k=1,3)
3234 c          write (iout,*) (erij(k),k=1,3)
3235           call vec_and_deriv
3236           do k=1,3
3237             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3238             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3239             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3240             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3241           enddo
3242 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3243 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3244 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3245         enddo
3246         do k=1,3
3247           dc_norm(k,i)=erij(k)
3248         enddo
3249 cd        do k=1,3
3250 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3251 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3252 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3253 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3254 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3255 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3256 cd          write (iout,'(a)')
3257 cd        enddo
3258       enddo
3259       return
3260       end
3261 C--------------------------------------------------------------------------
3262       subroutine set_matrices
3263       implicit real*8 (a-h,o-z)
3264       include 'DIMENSIONS'
3265       include 'DIMENSIONS.ZSCOPT'
3266       include 'COMMON.IOUNITS'
3267       include 'COMMON.GEO'
3268       include 'COMMON.VAR'
3269       include 'COMMON.LOCAL'
3270       include 'COMMON.CHAIN'
3271       include 'COMMON.DERIV'
3272       include 'COMMON.INTERACT'
3273       include 'COMMON.CONTACTS'
3274       include 'COMMON.TORSION'
3275       include 'COMMON.VECTORS'
3276       include 'COMMON.FFIELD'
3277       double precision auxvec(2),auxmat(2,2)
3278 C
3279 C Compute the virtual-bond-torsional-angle dependent quantities needed
3280 C to calculate the el-loc multibody terms of various order.
3281 C
3282       do i=3,nres+1
3283         if (i .lt. nres+1) then
3284           sin1=dsin(phi(i))
3285           cos1=dcos(phi(i))
3286           sintab(i-2)=sin1
3287           costab(i-2)=cos1
3288           obrot(1,i-2)=cos1
3289           obrot(2,i-2)=sin1
3290           sin2=dsin(2*phi(i))
3291           cos2=dcos(2*phi(i))
3292           sintab2(i-2)=sin2
3293           costab2(i-2)=cos2
3294           obrot2(1,i-2)=cos2
3295           obrot2(2,i-2)=sin2
3296           Ug(1,1,i-2)=-cos1
3297           Ug(1,2,i-2)=-sin1
3298           Ug(2,1,i-2)=-sin1
3299           Ug(2,2,i-2)= cos1
3300           Ug2(1,1,i-2)=-cos2
3301           Ug2(1,2,i-2)=-sin2
3302           Ug2(2,1,i-2)=-sin2
3303           Ug2(2,2,i-2)= cos2
3304         else
3305           costab(i-2)=1.0d0
3306           sintab(i-2)=0.0d0
3307           obrot(1,i-2)=1.0d0
3308           obrot(2,i-2)=0.0d0
3309           obrot2(1,i-2)=0.0d0
3310           obrot2(2,i-2)=0.0d0
3311           Ug(1,1,i-2)=1.0d0
3312           Ug(1,2,i-2)=0.0d0
3313           Ug(2,1,i-2)=0.0d0
3314           Ug(2,2,i-2)=1.0d0
3315           Ug2(1,1,i-2)=0.0d0
3316           Ug2(1,2,i-2)=0.0d0
3317           Ug2(2,1,i-2)=0.0d0
3318           Ug2(2,2,i-2)=0.0d0
3319         endif
3320         if (i .gt. 3 .and. i .lt. nres+1) then
3321           obrot_der(1,i-2)=-sin1
3322           obrot_der(2,i-2)= cos1
3323           Ugder(1,1,i-2)= sin1
3324           Ugder(1,2,i-2)=-cos1
3325           Ugder(2,1,i-2)=-cos1
3326           Ugder(2,2,i-2)=-sin1
3327           dwacos2=cos2+cos2
3328           dwasin2=sin2+sin2
3329           obrot2_der(1,i-2)=-dwasin2
3330           obrot2_der(2,i-2)= dwacos2
3331           Ug2der(1,1,i-2)= dwasin2
3332           Ug2der(1,2,i-2)=-dwacos2
3333           Ug2der(2,1,i-2)=-dwacos2
3334           Ug2der(2,2,i-2)=-dwasin2
3335         else
3336           obrot_der(1,i-2)=0.0d0
3337           obrot_der(2,i-2)=0.0d0
3338           Ugder(1,1,i-2)=0.0d0
3339           Ugder(1,2,i-2)=0.0d0
3340           Ugder(2,1,i-2)=0.0d0
3341           Ugder(2,2,i-2)=0.0d0
3342           obrot2_der(1,i-2)=0.0d0
3343           obrot2_der(2,i-2)=0.0d0
3344           Ug2der(1,1,i-2)=0.0d0
3345           Ug2der(1,2,i-2)=0.0d0
3346           Ug2der(2,1,i-2)=0.0d0
3347           Ug2der(2,2,i-2)=0.0d0
3348         endif
3349         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3350           iti = itortyp(itype(i-2))
3351         else
3352           iti=ntortyp+1
3353         endif
3354         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3355           iti1 = itortyp(itype(i-1))
3356         else
3357           iti1=ntortyp+1
3358         endif
3359 cd        write (iout,*) '*******i',i,' iti1',iti
3360 cd        write (iout,*) 'b1',b1(:,iti)
3361 cd        write (iout,*) 'b2',b2(:,iti)
3362 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3363         if (i .gt. iatel_s+2) then
3364           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
3365           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3366           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3367           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3368           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3369           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3370           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3371         else
3372           do k=1,2
3373             Ub2(k,i-2)=0.0d0
3374             Ctobr(k,i-2)=0.0d0
3375             Dtobr2(k,i-2)=0.0d0
3376             do l=1,2
3377               EUg(l,k,i-2)=0.0d0
3378               CUg(l,k,i-2)=0.0d0
3379               DUg(l,k,i-2)=0.0d0
3380               DtUg2(l,k,i-2)=0.0d0
3381             enddo
3382           enddo
3383         endif
3384         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
3385         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3386         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3387         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3388         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3389         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3390         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3391         do k=1,2
3392           muder(k,i-2)=Ub2der(k,i-2)
3393         enddo
3394         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3395           iti1 = itortyp(itype(i-1))
3396         else
3397           iti1=ntortyp+1
3398         endif
3399         do k=1,2
3400           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
3401         enddo
3402 C Vectors and matrices dependent on a single virtual-bond dihedral.
3403         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
3404         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3405         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3406         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3407         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3408         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3409         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3410         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3411         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3412 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3413 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3414       enddo
3415 C Matrices dependent on two consecutive virtual-bond dihedrals.
3416 C The order of matrices is from left to right.
3417       do i=2,nres-1
3418         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3419         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3420         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3421         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3422         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3423         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3424         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3425         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3426       enddo
3427 cd      do i=1,nres
3428 cd        iti = itortyp(itype(i))
3429 cd        write (iout,*) i
3430 cd        do j=1,2
3431 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3432 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3433 cd        enddo
3434 cd      enddo
3435       return
3436       end
3437 C--------------------------------------------------------------------------
3438       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3439 C
3440 C This subroutine calculates the average interaction energy and its gradient
3441 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3442 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3443 C The potential depends both on the distance of peptide-group centers and on
3444 C the orientation of the CA-CA virtual bonds.
3445 C
3446       implicit real*8 (a-h,o-z)
3447       include 'DIMENSIONS'
3448       include 'DIMENSIONS.ZSCOPT'
3449       include 'COMMON.CONTROL'
3450       include 'COMMON.IOUNITS'
3451       include 'COMMON.GEO'
3452       include 'COMMON.VAR'
3453       include 'COMMON.LOCAL'
3454       include 'COMMON.CHAIN'
3455       include 'COMMON.DERIV'
3456       include 'COMMON.INTERACT'
3457       include 'COMMON.CONTACTS'
3458       include 'COMMON.TORSION'
3459       include 'COMMON.VECTORS'
3460       include 'COMMON.FFIELD'
3461       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3462      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3463       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3464      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3465       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3466 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3467       double precision scal_el /0.5d0/
3468 C 12/13/98
3469 C 13-go grudnia roku pamietnego...
3470       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3471      &                   0.0d0,1.0d0,0.0d0,
3472      &                   0.0d0,0.0d0,1.0d0/
3473 cd      write(iout,*) 'In EELEC'
3474 cd      do i=1,nloctyp
3475 cd        write(iout,*) 'Type',i
3476 cd        write(iout,*) 'B1',B1(:,i)
3477 cd        write(iout,*) 'B2',B2(:,i)
3478 cd        write(iout,*) 'CC',CC(:,:,i)
3479 cd        write(iout,*) 'DD',DD(:,:,i)
3480 cd        write(iout,*) 'EE',EE(:,:,i)
3481 cd      enddo
3482 cd      call check_vecgrad
3483 cd      stop
3484       if (icheckgrad.eq.1) then
3485         do i=1,nres-1
3486           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3487           do k=1,3
3488             dc_norm(k,i)=dc(k,i)*fac
3489           enddo
3490 c          write (iout,*) 'i',i,' fac',fac
3491         enddo
3492       endif
3493       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3494      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3495      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3496 cd      if (wel_loc.gt.0.0d0) then
3497         if (icheckgrad.eq.1) then
3498         call vec_and_deriv_test
3499         else
3500         call vec_and_deriv
3501         endif
3502         call set_matrices
3503       endif
3504 cd      do i=1,nres-1
3505 cd        write (iout,*) 'i=',i
3506 cd        do k=1,3
3507 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3508 cd        enddo
3509 cd        do k=1,3
3510 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3511 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3512 cd        enddo
3513 cd      enddo
3514       num_conti_hb=0
3515       ees=0.0D0
3516       evdw1=0.0D0
3517       eel_loc=0.0d0
3518       eello_turn3=0.0d0
3519       eello_turn4=0.0d0
3520       ind=0
3521       do i=1,nres
3522         num_cont_hb(i)=0
3523       enddo
3524 cd      print '(a)','Enter EELEC'
3525 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3526       do i=1,nres
3527         gel_loc_loc(i)=0.0d0
3528         gcorr_loc(i)=0.0d0
3529       enddo
3530       do i=iatel_s,iatel_e
3531         if (itel(i).eq.0) goto 1215
3532         dxi=dc(1,i)
3533         dyi=dc(2,i)
3534         dzi=dc(3,i)
3535         dx_normi=dc_norm(1,i)
3536         dy_normi=dc_norm(2,i)
3537         dz_normi=dc_norm(3,i)
3538         xmedi=c(1,i)+0.5d0*dxi
3539         ymedi=c(2,i)+0.5d0*dyi
3540         zmedi=c(3,i)+0.5d0*dzi
3541         num_conti=0
3542 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3543         do j=ielstart(i),ielend(i)
3544           if (itel(j).eq.0) goto 1216
3545           ind=ind+1
3546           iteli=itel(i)
3547           itelj=itel(j)
3548           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3549           aaa=app(iteli,itelj)
3550           bbb=bpp(iteli,itelj)
3551 C Diagnostics only!!!
3552 c         aaa=0.0D0
3553 c         bbb=0.0D0
3554 c         ael6i=0.0D0
3555 c         ael3i=0.0D0
3556 C End diagnostics
3557           ael6i=ael6(iteli,itelj)
3558           ael3i=ael3(iteli,itelj)
3559           dxj=dc(1,j)
3560           dyj=dc(2,j)
3561           dzj=dc(3,j)
3562           dx_normj=dc_norm(1,j)
3563           dy_normj=dc_norm(2,j)
3564           dz_normj=dc_norm(3,j)
3565           xj=c(1,j)+0.5D0*dxj-xmedi
3566           yj=c(2,j)+0.5D0*dyj-ymedi
3567           zj=c(3,j)+0.5D0*dzj-zmedi
3568           rij=xj*xj+yj*yj+zj*zj
3569           rrmij=1.0D0/rij
3570           rij=dsqrt(rij)
3571           rmij=1.0D0/rij
3572           r3ij=rrmij*rmij
3573           r6ij=r3ij*r3ij
3574           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3575           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3576           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3577           fac=cosa-3.0D0*cosb*cosg
3578           ev1=aaa*r6ij*r6ij
3579 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3580           if (j.eq.i+2) ev1=scal_el*ev1
3581           ev2=bbb*r6ij
3582           fac3=ael6i*r6ij
3583           fac4=ael3i*r3ij
3584           evdwij=ev1+ev2
3585           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3586           el2=fac4*fac
3587           eesij=el1+el2
3588 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3589 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3590           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3591           ees=ees+eesij
3592           evdw1=evdw1+evdwij
3593 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3594 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3595 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3596 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3597 C
3598 C Calculate contributions to the Cartesian gradient.
3599 C
3600 #ifdef SPLITELE
3601           facvdw=-6*rrmij*(ev1+evdwij)
3602           facel=-3*rrmij*(el1+eesij)
3603           fac1=fac
3604           erij(1)=xj*rmij
3605           erij(2)=yj*rmij
3606           erij(3)=zj*rmij
3607           if (calc_grad) then
3608 *
3609 * Radial derivatives. First process both termini of the fragment (i,j)
3610 *
3611           ggg(1)=facel*xj
3612           ggg(2)=facel*yj
3613           ggg(3)=facel*zj
3614           do k=1,3
3615             ghalf=0.5D0*ggg(k)
3616             gelc(k,i)=gelc(k,i)+ghalf
3617             gelc(k,j)=gelc(k,j)+ghalf
3618           enddo
3619 *
3620 * Loop over residues i+1 thru j-1.
3621 *
3622           do k=i+1,j-1
3623             do l=1,3
3624               gelc(l,k)=gelc(l,k)+ggg(l)
3625             enddo
3626           enddo
3627           ggg(1)=facvdw*xj
3628           ggg(2)=facvdw*yj
3629           ggg(3)=facvdw*zj
3630           do k=1,3
3631             ghalf=0.5D0*ggg(k)
3632             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3633             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3634           enddo
3635 *
3636 * Loop over residues i+1 thru j-1.
3637 *
3638           do k=i+1,j-1
3639             do l=1,3
3640               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3641             enddo
3642           enddo
3643 #else
3644           facvdw=ev1+evdwij
3645           facel=el1+eesij
3646           fac1=fac
3647           fac=-3*rrmij*(facvdw+facvdw+facel)
3648           erij(1)=xj*rmij
3649           erij(2)=yj*rmij
3650           erij(3)=zj*rmij
3651           if (calc_grad) then
3652 *
3653 * Radial derivatives. First process both termini of the fragment (i,j)
3654 *
3655           ggg(1)=fac*xj
3656           ggg(2)=fac*yj
3657           ggg(3)=fac*zj
3658           do k=1,3
3659             ghalf=0.5D0*ggg(k)
3660             gelc(k,i)=gelc(k,i)+ghalf
3661             gelc(k,j)=gelc(k,j)+ghalf
3662           enddo
3663 *
3664 * Loop over residues i+1 thru j-1.
3665 *
3666           do k=i+1,j-1
3667             do l=1,3
3668               gelc(l,k)=gelc(l,k)+ggg(l)
3669             enddo
3670           enddo
3671 #endif
3672 *
3673 * Angular part
3674 *
3675           ecosa=2.0D0*fac3*fac1+fac4
3676           fac4=-3.0D0*fac4
3677           fac3=-6.0D0*fac3
3678           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3679           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3680           do k=1,3
3681             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3682             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3683           enddo
3684 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3685 cd   &          (dcosg(k),k=1,3)
3686           do k=1,3
3687             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3688           enddo
3689           do k=1,3
3690             ghalf=0.5D0*ggg(k)
3691             gelc(k,i)=gelc(k,i)+ghalf
3692      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3693      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3694             gelc(k,j)=gelc(k,j)+ghalf
3695      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3696      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3697           enddo
3698           do k=i+1,j-1
3699             do l=1,3
3700               gelc(l,k)=gelc(l,k)+ggg(l)
3701             enddo
3702           enddo
3703           endif
3704
3705           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3706      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3707      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3708 C
3709 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3710 C   energy of a peptide unit is assumed in the form of a second-order
3711 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3712 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3713 C   are computed for EVERY pair of non-contiguous peptide groups.
3714 C
3715           if (j.lt.nres-1) then
3716             j1=j+1
3717             j2=j-1
3718           else
3719             j1=j-1
3720             j2=j-2
3721           endif
3722           kkk=0
3723           do k=1,2
3724             do l=1,2
3725               kkk=kkk+1
3726               muij(kkk)=mu(k,i)*mu(l,j)
3727             enddo
3728           enddo
3729 cd         write (iout,*) 'EELEC: i',i,' j',j
3730 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3731 cd          write(iout,*) 'muij',muij
3732           ury=scalar(uy(1,i),erij)
3733           urz=scalar(uz(1,i),erij)
3734           vry=scalar(uy(1,j),erij)
3735           vrz=scalar(uz(1,j),erij)
3736           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3737           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3738           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3739           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3740 C For diagnostics only
3741 cd          a22=1.0d0
3742 cd          a23=1.0d0
3743 cd          a32=1.0d0
3744 cd          a33=1.0d0
3745           fac=dsqrt(-ael6i)*r3ij
3746 cd          write (2,*) 'fac=',fac
3747 C For diagnostics only
3748 cd          fac=1.0d0
3749           a22=a22*fac
3750           a23=a23*fac
3751           a32=a32*fac
3752           a33=a33*fac
3753 cd          write (iout,'(4i5,4f10.5)')
3754 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3755 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3756 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3757 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3758 cd          write (iout,'(4f10.5)')
3759 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3760 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3761 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3762 cd           write (iout,'(2i3,9f10.5/)') i,j,
3763 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3764           if (calc_grad) then
3765 C Derivatives of the elements of A in virtual-bond vectors
3766           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3767 cd          do k=1,3
3768 cd            do l=1,3
3769 cd              erder(k,l)=0.0d0
3770 cd            enddo
3771 cd          enddo
3772           do k=1,3
3773             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3774             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3775             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3776             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3777             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3778             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3779             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3780             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3781             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3782             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3783             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3784             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3785           enddo
3786 cd          do k=1,3
3787 cd            do l=1,3
3788 cd              uryg(k,l)=0.0d0
3789 cd              urzg(k,l)=0.0d0
3790 cd              vryg(k,l)=0.0d0
3791 cd              vrzg(k,l)=0.0d0
3792 cd            enddo
3793 cd          enddo
3794 C Compute radial contributions to the gradient
3795           facr=-3.0d0*rrmij
3796           a22der=a22*facr
3797           a23der=a23*facr
3798           a32der=a32*facr
3799           a33der=a33*facr
3800 cd          a22der=0.0d0
3801 cd          a23der=0.0d0
3802 cd          a32der=0.0d0
3803 cd          a33der=0.0d0
3804           agg(1,1)=a22der*xj
3805           agg(2,1)=a22der*yj
3806           agg(3,1)=a22der*zj
3807           agg(1,2)=a23der*xj
3808           agg(2,2)=a23der*yj
3809           agg(3,2)=a23der*zj
3810           agg(1,3)=a32der*xj
3811           agg(2,3)=a32der*yj
3812           agg(3,3)=a32der*zj
3813           agg(1,4)=a33der*xj
3814           agg(2,4)=a33der*yj
3815           agg(3,4)=a33der*zj
3816 C Add the contributions coming from er
3817           fac3=-3.0d0*fac
3818           do k=1,3
3819             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3820             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3821             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3822             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3823           enddo
3824           do k=1,3
3825 C Derivatives in DC(i)
3826             ghalf1=0.5d0*agg(k,1)
3827             ghalf2=0.5d0*agg(k,2)
3828             ghalf3=0.5d0*agg(k,3)
3829             ghalf4=0.5d0*agg(k,4)
3830             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3831      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3832             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3833      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3834             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3835      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3836             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3837      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3838 C Derivatives in DC(i+1)
3839             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3840      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3841             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3842      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3843             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3844      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3845             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3846      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3847 C Derivatives in DC(j)
3848             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3849      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3850             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3851      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3852             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3853      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3854             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3855      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3856 C Derivatives in DC(j+1) or DC(nres-1)
3857             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3858      &      -3.0d0*vryg(k,3)*ury)
3859             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3860      &      -3.0d0*vrzg(k,3)*ury)
3861             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3862      &      -3.0d0*vryg(k,3)*urz)
3863             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3864      &      -3.0d0*vrzg(k,3)*urz)
3865 cd            aggi(k,1)=ghalf1
3866 cd            aggi(k,2)=ghalf2
3867 cd            aggi(k,3)=ghalf3
3868 cd            aggi(k,4)=ghalf4
3869 C Derivatives in DC(i+1)
3870 cd            aggi1(k,1)=agg(k,1)
3871 cd            aggi1(k,2)=agg(k,2)
3872 cd            aggi1(k,3)=agg(k,3)
3873 cd            aggi1(k,4)=agg(k,4)
3874 C Derivatives in DC(j)
3875 cd            aggj(k,1)=ghalf1
3876 cd            aggj(k,2)=ghalf2
3877 cd            aggj(k,3)=ghalf3
3878 cd            aggj(k,4)=ghalf4
3879 C Derivatives in DC(j+1)
3880 cd            aggj1(k,1)=0.0d0
3881 cd            aggj1(k,2)=0.0d0
3882 cd            aggj1(k,3)=0.0d0
3883 cd            aggj1(k,4)=0.0d0
3884             if (j.eq.nres-1 .and. i.lt.j-2) then
3885               do l=1,4
3886                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3887 cd                aggj1(k,l)=agg(k,l)
3888               enddo
3889             endif
3890           enddo
3891           endif
3892 c          goto 11111
3893 C Check the loc-el terms by numerical integration
3894           acipa(1,1)=a22
3895           acipa(1,2)=a23
3896           acipa(2,1)=a32
3897           acipa(2,2)=a33
3898           a22=-a22
3899           a23=-a23
3900           do l=1,2
3901             do k=1,3
3902               agg(k,l)=-agg(k,l)
3903               aggi(k,l)=-aggi(k,l)
3904               aggi1(k,l)=-aggi1(k,l)
3905               aggj(k,l)=-aggj(k,l)
3906               aggj1(k,l)=-aggj1(k,l)
3907             enddo
3908           enddo
3909           if (j.lt.nres-1) then
3910             a22=-a22
3911             a32=-a32
3912             do l=1,3,2
3913               do k=1,3
3914                 agg(k,l)=-agg(k,l)
3915                 aggi(k,l)=-aggi(k,l)
3916                 aggi1(k,l)=-aggi1(k,l)
3917                 aggj(k,l)=-aggj(k,l)
3918                 aggj1(k,l)=-aggj1(k,l)
3919               enddo
3920             enddo
3921           else
3922             a22=-a22
3923             a23=-a23
3924             a32=-a32
3925             a33=-a33
3926             do l=1,4
3927               do k=1,3
3928                 agg(k,l)=-agg(k,l)
3929                 aggi(k,l)=-aggi(k,l)
3930                 aggi1(k,l)=-aggi1(k,l)
3931                 aggj(k,l)=-aggj(k,l)
3932                 aggj1(k,l)=-aggj1(k,l)
3933               enddo
3934             enddo
3935           endif
3936           ENDIF ! WCORR
3937 11111     continue
3938           IF (wel_loc.gt.0.0d0) THEN
3939 C Contribution to the local-electrostatic energy coming from the i-j pair
3940           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3941      &     +a33*muij(4)
3942 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3943 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3944           eel_loc=eel_loc+eel_loc_ij
3945 C Partial derivatives in virtual-bond dihedral angles gamma
3946           if (calc_grad) then
3947           if (i.gt.1)
3948      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3949      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3950      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3951           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3952      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3953      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3954 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
3955 cd          write(iout,*) 'agg  ',agg
3956 cd          write(iout,*) 'aggi ',aggi
3957 cd          write(iout,*) 'aggi1',aggi1
3958 cd          write(iout,*) 'aggj ',aggj
3959 cd          write(iout,*) 'aggj1',aggj1
3960
3961 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3962           do l=1,3
3963             ggg(l)=agg(l,1)*muij(1)+
3964      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3965           enddo
3966           do k=i+2,j2
3967             do l=1,3
3968               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3969             enddo
3970           enddo
3971 C Remaining derivatives of eello
3972           do l=1,3
3973             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3974      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3975             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3976      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3977             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3978      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3979             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3980      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3981           enddo
3982           endif
3983           ENDIF
3984           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3985 C Contributions from turns
3986             a_temp(1,1)=a22
3987             a_temp(1,2)=a23
3988             a_temp(2,1)=a32
3989             a_temp(2,2)=a33
3990             call eturn34(i,j,eello_turn3,eello_turn4)
3991           endif
3992 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3993           if (j.gt.i+1 .and. num_conti.le.maxconts) then
3994 C
3995 C Calculate the contact function. The ith column of the array JCONT will
3996 C contain the numbers of atoms that make contacts with the atom I (of numbers
3997 C greater than I). The arrays FACONT and GACONT will contain the values of
3998 C the contact function and its derivative.
3999 c           r0ij=1.02D0*rpp(iteli,itelj)
4000 c           r0ij=1.11D0*rpp(iteli,itelj)
4001             r0ij=2.20D0*rpp(iteli,itelj)
4002 c           r0ij=1.55D0*rpp(iteli,itelj)
4003             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4004             if (fcont.gt.0.0D0) then
4005               num_conti=num_conti+1
4006               if (num_conti.gt.maxconts) then
4007                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4008      &                         ' will skip next contacts for this conf.'
4009               else
4010                 jcont_hb(num_conti,i)=j
4011                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4012      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4013 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4014 C  terms.
4015                 d_cont(num_conti,i)=rij
4016 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4017 C     --- Electrostatic-interaction matrix ---
4018                 a_chuj(1,1,num_conti,i)=a22
4019                 a_chuj(1,2,num_conti,i)=a23
4020                 a_chuj(2,1,num_conti,i)=a32
4021                 a_chuj(2,2,num_conti,i)=a33
4022 C     --- Gradient of rij
4023                 do kkk=1,3
4024                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4025                 enddo
4026 c             if (i.eq.1) then
4027 c                a_chuj(1,1,num_conti,i)=-0.61d0
4028 c                a_chuj(1,2,num_conti,i)= 0.4d0
4029 c                a_chuj(2,1,num_conti,i)= 0.65d0
4030 c                a_chuj(2,2,num_conti,i)= 0.50d0
4031 c             else if (i.eq.2) then
4032 c                a_chuj(1,1,num_conti,i)= 0.0d0
4033 c                a_chuj(1,2,num_conti,i)= 0.0d0
4034 c                a_chuj(2,1,num_conti,i)= 0.0d0
4035 c                a_chuj(2,2,num_conti,i)= 0.0d0
4036 c             endif
4037 C     --- and its gradients
4038 cd                write (iout,*) 'i',i,' j',j
4039 cd                do kkk=1,3
4040 cd                write (iout,*) 'iii 1 kkk',kkk
4041 cd                write (iout,*) agg(kkk,:)
4042 cd                enddo
4043 cd                do kkk=1,3
4044 cd                write (iout,*) 'iii 2 kkk',kkk
4045 cd                write (iout,*) aggi(kkk,:)
4046 cd                enddo
4047 cd                do kkk=1,3
4048 cd                write (iout,*) 'iii 3 kkk',kkk
4049 cd                write (iout,*) aggi1(kkk,:)
4050 cd                enddo
4051 cd                do kkk=1,3
4052 cd                write (iout,*) 'iii 4 kkk',kkk
4053 cd                write (iout,*) aggj(kkk,:)
4054 cd                enddo
4055 cd                do kkk=1,3
4056 cd                write (iout,*) 'iii 5 kkk',kkk
4057 cd                write (iout,*) aggj1(kkk,:)
4058 cd                enddo
4059                 kkll=0
4060                 do k=1,2
4061                   do l=1,2
4062                     kkll=kkll+1
4063                     do m=1,3
4064                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4065                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4066                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4067                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4068                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4069 c                      do mm=1,5
4070 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4071 c                      enddo
4072                     enddo
4073                   enddo
4074                 enddo
4075                 ENDIF
4076                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4077 C Calculate contact energies
4078                 cosa4=4.0D0*cosa
4079                 wij=cosa-3.0D0*cosb*cosg
4080                 cosbg1=cosb+cosg
4081                 cosbg2=cosb-cosg
4082 c               fac3=dsqrt(-ael6i)/r0ij**3
4083                 fac3=dsqrt(-ael6i)*r3ij
4084                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4085                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4086 c               ees0mij=0.0D0
4087                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4088                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4089 C Diagnostics. Comment out or remove after debugging!
4090 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4091 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4092 c               ees0m(num_conti,i)=0.0D0
4093 C End diagnostics.
4094 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4095 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4096                 facont_hb(num_conti,i)=fcont
4097                 if (calc_grad) then
4098 C Angular derivatives of the contact function
4099                 ees0pij1=fac3/ees0pij
4100                 ees0mij1=fac3/ees0mij
4101                 fac3p=-3.0D0*fac3*rrmij
4102                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4103                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4104 c               ees0mij1=0.0D0
4105                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4106                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4107                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4108                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4109                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4110                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4111                 ecosap=ecosa1+ecosa2
4112                 ecosbp=ecosb1+ecosb2
4113                 ecosgp=ecosg1+ecosg2
4114                 ecosam=ecosa1-ecosa2
4115                 ecosbm=ecosb1-ecosb2
4116                 ecosgm=ecosg1-ecosg2
4117 C Diagnostics
4118 c               ecosap=ecosa1
4119 c               ecosbp=ecosb1
4120 c               ecosgp=ecosg1
4121 c               ecosam=0.0D0
4122 c               ecosbm=0.0D0
4123 c               ecosgm=0.0D0
4124 C End diagnostics
4125                 fprimcont=fprimcont/rij
4126 cd              facont_hb(num_conti,i)=1.0D0
4127 C Following line is for diagnostics.
4128 cd              fprimcont=0.0D0
4129                 do k=1,3
4130                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4131                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4132                 enddo
4133                 do k=1,3
4134                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4135                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4136                 enddo
4137                 gggp(1)=gggp(1)+ees0pijp*xj
4138                 gggp(2)=gggp(2)+ees0pijp*yj
4139                 gggp(3)=gggp(3)+ees0pijp*zj
4140                 gggm(1)=gggm(1)+ees0mijp*xj
4141                 gggm(2)=gggm(2)+ees0mijp*yj
4142                 gggm(3)=gggm(3)+ees0mijp*zj
4143 C Derivatives due to the contact function
4144                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4145                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4146                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4147                 do k=1,3
4148                   ghalfp=0.5D0*gggp(k)
4149                   ghalfm=0.5D0*gggm(k)
4150                   gacontp_hb1(k,num_conti,i)=ghalfp
4151      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4152      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4153                   gacontp_hb2(k,num_conti,i)=ghalfp
4154      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4155      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4156                   gacontp_hb3(k,num_conti,i)=gggp(k)
4157                   gacontm_hb1(k,num_conti,i)=ghalfm
4158      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4159      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4160                   gacontm_hb2(k,num_conti,i)=ghalfm
4161      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4162      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4163                   gacontm_hb3(k,num_conti,i)=gggm(k)
4164                 enddo
4165                 endif
4166 C Diagnostics. Comment out or remove after debugging!
4167 cdiag           do k=1,3
4168 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4169 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4170 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4171 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4172 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4173 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4174 cdiag           enddo
4175               ENDIF ! wcorr
4176               endif  ! num_conti.le.maxconts
4177             endif  ! fcont.gt.0
4178           endif    ! j.gt.i+1
4179  1216     continue
4180         enddo ! j
4181         num_cont_hb(i)=num_conti
4182  1215   continue
4183       enddo   ! i
4184 cd      do i=1,nres
4185 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4186 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4187 cd      enddo
4188 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4189 ccc      eel_loc=eel_loc+eello_turn3
4190       return
4191       end
4192 C-----------------------------------------------------------------------------
4193       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4194 C Third- and fourth-order contributions from turns
4195       implicit real*8 (a-h,o-z)
4196       include 'DIMENSIONS'
4197       include 'DIMENSIONS.ZSCOPT'
4198       include 'COMMON.IOUNITS'
4199       include 'COMMON.GEO'
4200       include 'COMMON.VAR'
4201       include 'COMMON.LOCAL'
4202       include 'COMMON.CHAIN'
4203       include 'COMMON.DERIV'
4204       include 'COMMON.INTERACT'
4205       include 'COMMON.CONTACTS'
4206       include 'COMMON.TORSION'
4207       include 'COMMON.VECTORS'
4208       include 'COMMON.FFIELD'
4209       dimension ggg(3)
4210       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4211      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4212      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4213       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4214      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4215       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4216       if (j.eq.i+2) then
4217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4218 C
4219 C               Third-order contributions
4220 C
4221 C                 (i+2)o----(i+3)
4222 C                      | |
4223 C                      | |
4224 C                 (i+1)o----i
4225 C
4226 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4227 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4228         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4229         call transpose2(auxmat(1,1),auxmat1(1,1))
4230         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4231         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4232 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4233 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4234 cd     &    ' eello_turn3_num',4*eello_turn3_num
4235         if (calc_grad) then
4236 C Derivatives in gamma(i)
4237         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4238         call transpose2(auxmat2(1,1),pizda(1,1))
4239         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4240         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4241 C Derivatives in gamma(i+1)
4242         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4243         call transpose2(auxmat2(1,1),pizda(1,1))
4244         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4245         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4246      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4247 C Cartesian derivatives
4248         do l=1,3
4249           a_temp(1,1)=aggi(l,1)
4250           a_temp(1,2)=aggi(l,2)
4251           a_temp(2,1)=aggi(l,3)
4252           a_temp(2,2)=aggi(l,4)
4253           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4254           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4255      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4256           a_temp(1,1)=aggi1(l,1)
4257           a_temp(1,2)=aggi1(l,2)
4258           a_temp(2,1)=aggi1(l,3)
4259           a_temp(2,2)=aggi1(l,4)
4260           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4261           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4262      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4263           a_temp(1,1)=aggj(l,1)
4264           a_temp(1,2)=aggj(l,2)
4265           a_temp(2,1)=aggj(l,3)
4266           a_temp(2,2)=aggj(l,4)
4267           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4268           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4269      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4270           a_temp(1,1)=aggj1(l,1)
4271           a_temp(1,2)=aggj1(l,2)
4272           a_temp(2,1)=aggj1(l,3)
4273           a_temp(2,2)=aggj1(l,4)
4274           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4275           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4276      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4277         enddo
4278         endif
4279       else if (j.eq.i+3) then
4280 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4281 C
4282 C               Fourth-order contributions
4283 C
4284 C                 (i+3)o----(i+4)
4285 C                     /  |
4286 C               (i+2)o   |
4287 C                     \  |
4288 C                 (i+1)o----i
4289 C
4290 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4291 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4292         iti1=itortyp(itype(i+1))
4293         iti2=itortyp(itype(i+2))
4294         iti3=itortyp(itype(i+3))
4295         call transpose2(EUg(1,1,i+1),e1t(1,1))
4296         call transpose2(Eug(1,1,i+2),e2t(1,1))
4297         call transpose2(Eug(1,1,i+3),e3t(1,1))
4298         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4299         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4300         s1=scalar2(b1(1,iti2),auxvec(1))
4301         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4302         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4303         s2=scalar2(b1(1,iti1),auxvec(1))
4304         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4305         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4306         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4307         eello_turn4=eello_turn4-(s1+s2+s3)
4308 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4309 cd     &    ' eello_turn4_num',8*eello_turn4_num
4310 C Derivatives in gamma(i)
4311         if (calc_grad) then
4312         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4313         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4314         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4315         s1=scalar2(b1(1,iti2),auxvec(1))
4316         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4317         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4318         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4319 C Derivatives in gamma(i+1)
4320         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4321         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4322         s2=scalar2(b1(1,iti1),auxvec(1))
4323         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4324         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4325         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4326         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4327 C Derivatives in gamma(i+2)
4328         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4329         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4330         s1=scalar2(b1(1,iti2),auxvec(1))
4331         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4332         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4333         s2=scalar2(b1(1,iti1),auxvec(1))
4334         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4335         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4336         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4337         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4338 C Cartesian derivatives
4339 C Derivatives of this turn contributions in DC(i+2)
4340         if (j.lt.nres-1) then
4341           do l=1,3
4342             a_temp(1,1)=agg(l,1)
4343             a_temp(1,2)=agg(l,2)
4344             a_temp(2,1)=agg(l,3)
4345             a_temp(2,2)=agg(l,4)
4346             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4347             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4348             s1=scalar2(b1(1,iti2),auxvec(1))
4349             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4350             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4351             s2=scalar2(b1(1,iti1),auxvec(1))
4352             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4353             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4354             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4355             ggg(l)=-(s1+s2+s3)
4356             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4357           enddo
4358         endif
4359 C Remaining derivatives of this turn contribution
4360         do l=1,3
4361           a_temp(1,1)=aggi(l,1)
4362           a_temp(1,2)=aggi(l,2)
4363           a_temp(2,1)=aggi(l,3)
4364           a_temp(2,2)=aggi(l,4)
4365           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4366           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4367           s1=scalar2(b1(1,iti2),auxvec(1))
4368           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4369           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4370           s2=scalar2(b1(1,iti1),auxvec(1))
4371           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4372           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4373           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4374           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4375           a_temp(1,1)=aggi1(l,1)
4376           a_temp(1,2)=aggi1(l,2)
4377           a_temp(2,1)=aggi1(l,3)
4378           a_temp(2,2)=aggi1(l,4)
4379           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4380           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4381           s1=scalar2(b1(1,iti2),auxvec(1))
4382           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4383           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4384           s2=scalar2(b1(1,iti1),auxvec(1))
4385           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4386           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4387           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4388           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4389           a_temp(1,1)=aggj(l,1)
4390           a_temp(1,2)=aggj(l,2)
4391           a_temp(2,1)=aggj(l,3)
4392           a_temp(2,2)=aggj(l,4)
4393           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4394           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4395           s1=scalar2(b1(1,iti2),auxvec(1))
4396           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4397           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4398           s2=scalar2(b1(1,iti1),auxvec(1))
4399           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4400           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4401           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4402           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4403           a_temp(1,1)=aggj1(l,1)
4404           a_temp(1,2)=aggj1(l,2)
4405           a_temp(2,1)=aggj1(l,3)
4406           a_temp(2,2)=aggj1(l,4)
4407           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4408           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4409           s1=scalar2(b1(1,iti2),auxvec(1))
4410           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4411           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4412           s2=scalar2(b1(1,iti1),auxvec(1))
4413           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4414           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4415           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4416           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4417         enddo
4418         endif
4419       endif
4420       return
4421       end
4422 C-----------------------------------------------------------------------------
4423       subroutine vecpr(u,v,w)
4424       implicit real*8(a-h,o-z)
4425       dimension u(3),v(3),w(3)
4426       w(1)=u(2)*v(3)-u(3)*v(2)
4427       w(2)=-u(1)*v(3)+u(3)*v(1)
4428       w(3)=u(1)*v(2)-u(2)*v(1)
4429       return
4430       end
4431 C-----------------------------------------------------------------------------
4432       subroutine unormderiv(u,ugrad,unorm,ungrad)
4433 C This subroutine computes the derivatives of a normalized vector u, given
4434 C the derivatives computed without normalization conditions, ugrad. Returns
4435 C ungrad.
4436       implicit none
4437       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4438       double precision vec(3)
4439       double precision scalar
4440       integer i,j
4441 c      write (2,*) 'ugrad',ugrad
4442 c      write (2,*) 'u',u
4443       do i=1,3
4444         vec(i)=scalar(ugrad(1,i),u(1))
4445       enddo
4446 c      write (2,*) 'vec',vec
4447       do i=1,3
4448         do j=1,3
4449           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4450         enddo
4451       enddo
4452 c      write (2,*) 'ungrad',ungrad
4453       return
4454       end
4455 C-----------------------------------------------------------------------------
4456       subroutine escp(evdw2,evdw2_14)
4457 C
4458 C This subroutine calculates the excluded-volume interaction energy between
4459 C peptide-group centers and side chains and its gradient in virtual-bond and
4460 C side-chain vectors.
4461 C
4462       implicit real*8 (a-h,o-z)
4463       include 'DIMENSIONS'
4464       include 'DIMENSIONS.ZSCOPT'
4465       include 'COMMON.GEO'
4466       include 'COMMON.VAR'
4467       include 'COMMON.LOCAL'
4468       include 'COMMON.CHAIN'
4469       include 'COMMON.DERIV'
4470       include 'COMMON.INTERACT'
4471       include 'COMMON.FFIELD'
4472       include 'COMMON.IOUNITS'
4473       dimension ggg(3)
4474       evdw2=0.0D0
4475       evdw2_14=0.0d0
4476 cd    print '(a)','Enter ESCP'
4477 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4478 c     &  ' scal14',scal14
4479       do i=iatscp_s,iatscp_e
4480         iteli=itel(i)
4481 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4482 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4483         if (iteli.eq.0) goto 1225
4484         xi=0.5D0*(c(1,i)+c(1,i+1))
4485         yi=0.5D0*(c(2,i)+c(2,i+1))
4486         zi=0.5D0*(c(3,i)+c(3,i+1))
4487
4488         do iint=1,nscp_gr(i)
4489
4490         do j=iscpstart(i,iint),iscpend(i,iint)
4491           itypj=itype(j)
4492 C Uncomment following three lines for SC-p interactions
4493 c         xj=c(1,nres+j)-xi
4494 c         yj=c(2,nres+j)-yi
4495 c         zj=c(3,nres+j)-zi
4496 C Uncomment following three lines for Ca-p interactions
4497           xj=c(1,j)-xi
4498           yj=c(2,j)-yi
4499           zj=c(3,j)-zi
4500           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4501           fac=rrij**expon2
4502           e1=fac*fac*aad(itypj,iteli)
4503           e2=fac*bad(itypj,iteli)
4504           if (iabs(j-i) .le. 2) then
4505             e1=scal14*e1
4506             e2=scal14*e2
4507             evdw2_14=evdw2_14+e1+e2
4508           endif
4509           evdwij=e1+e2
4510 c          write (iout,*) i,j,evdwij
4511           evdw2=evdw2+evdwij
4512           if (calc_grad) then
4513 C
4514 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4515 C
4516           fac=-(evdwij+e1)*rrij
4517           ggg(1)=xj*fac
4518           ggg(2)=yj*fac
4519           ggg(3)=zj*fac
4520           if (j.lt.i) then
4521 cd          write (iout,*) 'j<i'
4522 C Uncomment following three lines for SC-p interactions
4523 c           do k=1,3
4524 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4525 c           enddo
4526           else
4527 cd          write (iout,*) 'j>i'
4528             do k=1,3
4529               ggg(k)=-ggg(k)
4530 C Uncomment following line for SC-p interactions
4531 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4532             enddo
4533           endif
4534           do k=1,3
4535             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4536           enddo
4537           kstart=min0(i+1,j)
4538           kend=max0(i-1,j-1)
4539 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4540 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4541           do k=kstart,kend
4542             do l=1,3
4543               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4544             enddo
4545           enddo
4546           endif
4547         enddo
4548         enddo ! iint
4549  1225   continue
4550       enddo ! i
4551       do i=1,nct
4552         do j=1,3
4553           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4554           gradx_scp(j,i)=expon*gradx_scp(j,i)
4555         enddo
4556       enddo
4557 C******************************************************************************
4558 C
4559 C                              N O T E !!!
4560 C
4561 C To save time the factor EXPON has been extracted from ALL components
4562 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4563 C use!
4564 C
4565 C******************************************************************************
4566       return
4567       end
4568 C--------------------------------------------------------------------------
4569       subroutine edis(ehpb)
4570 C
4571 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4572 C
4573       implicit real*8 (a-h,o-z)
4574       include 'DIMENSIONS'
4575       include 'DIMENSIONS.ZSCOPT'
4576       include 'COMMON.SBRIDGE'
4577       include 'COMMON.CHAIN'
4578       include 'COMMON.DERIV'
4579       include 'COMMON.VAR'
4580       include 'COMMON.INTERACT'
4581       dimension ggg(3)
4582       ehpb=0.0D0
4583 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
4584 cd    print *,'link_start=',link_start,' link_end=',link_end
4585       if (link_end.eq.0) return
4586       do i=link_start,link_end
4587 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4588 C CA-CA distance used in regularization of structure.
4589         ii=ihpb(i)
4590         jj=jhpb(i)
4591 C iii and jjj point to the residues for which the distance is assigned.
4592         if (ii.gt.nres) then
4593           iii=ii-nres
4594           jjj=jj-nres
4595         else
4596           iii=ii
4597           jjj=jj
4598         endif
4599 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4600 C    distance and angle dependent SS bond potential.
4601         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4602           call ssbond_ene(iii,jjj,eij)
4603           ehpb=ehpb+2*eij
4604         else
4605 C Calculate the distance between the two points and its difference from the
4606 C target distance.
4607         dd=dist(ii,jj)
4608         rdis=dd-dhpb(i)
4609 C Get the force constant corresponding to this distance.
4610         waga=forcon(i)
4611 C Calculate the contribution to energy.
4612         ehpb=ehpb+waga*rdis*rdis
4613 C
4614 C Evaluate gradient.
4615 C
4616         fac=waga*rdis/dd
4617 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4618 cd   &   ' waga=',waga,' fac=',fac
4619         do j=1,3
4620           ggg(j)=fac*(c(j,jj)-c(j,ii))
4621         enddo
4622 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4623 C If this is a SC-SC distance, we need to calculate the contributions to the
4624 C Cartesian gradient in the SC vectors (ghpbx).
4625         if (iii.lt.ii) then
4626           do j=1,3
4627             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4628             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4629           enddo
4630         endif
4631         do j=iii,jjj-1
4632           do k=1,3
4633             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4634           enddo
4635         enddo
4636         endif
4637       enddo
4638       ehpb=0.5D0*ehpb
4639       return
4640       end
4641 C--------------------------------------------------------------------------
4642       subroutine ssbond_ene(i,j,eij)
4643 C
4644 C Calculate the distance and angle dependent SS-bond potential energy
4645 C using a free-energy function derived based on RHF/6-31G** ab initio
4646 C calculations of diethyl disulfide.
4647 C
4648 C A. Liwo and U. Kozlowska, 11/24/03
4649 C
4650       implicit real*8 (a-h,o-z)
4651       include 'DIMENSIONS'
4652       include 'DIMENSIONS.ZSCOPT'
4653       include 'COMMON.SBRIDGE'
4654       include 'COMMON.CHAIN'
4655       include 'COMMON.DERIV'
4656       include 'COMMON.LOCAL'
4657       include 'COMMON.INTERACT'
4658       include 'COMMON.VAR'
4659       include 'COMMON.IOUNITS'
4660       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4661       itypi=itype(i)
4662       xi=c(1,nres+i)
4663       yi=c(2,nres+i)
4664       zi=c(3,nres+i)
4665       dxi=dc_norm(1,nres+i)
4666       dyi=dc_norm(2,nres+i)
4667       dzi=dc_norm(3,nres+i)
4668       dsci_inv=dsc_inv(itypi)
4669       itypj=itype(j)
4670       dscj_inv=dsc_inv(itypj)
4671       xj=c(1,nres+j)-xi
4672       yj=c(2,nres+j)-yi
4673       zj=c(3,nres+j)-zi
4674       dxj=dc_norm(1,nres+j)
4675       dyj=dc_norm(2,nres+j)
4676       dzj=dc_norm(3,nres+j)
4677       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4678       rij=dsqrt(rrij)
4679       erij(1)=xj*rij
4680       erij(2)=yj*rij
4681       erij(3)=zj*rij
4682       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4683       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4684       om12=dxi*dxj+dyi*dyj+dzi*dzj
4685       do k=1,3
4686         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4687         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4688       enddo
4689       rij=1.0d0/rij
4690       deltad=rij-d0cm
4691       deltat1=1.0d0-om1
4692       deltat2=1.0d0+om2
4693       deltat12=om2-om1+2.0d0
4694       cosphi=om12-om1*om2
4695       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4696      &  +akct*deltad*deltat12
4697      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4698 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4699 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4700 c     &  " deltat12",deltat12," eij",eij
4701       ed=2*akcm*deltad+akct*deltat12
4702       pom1=akct*deltad
4703       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4704       eom1=-2*akth*deltat1-pom1-om2*pom2
4705       eom2= 2*akth*deltat2+pom1-om1*pom2
4706       eom12=pom2
4707       do k=1,3
4708         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4709       enddo
4710       do k=1,3
4711         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4712      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4713         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4714      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4715       enddo
4716 C
4717 C Calculate the components of the gradient in DC and X
4718 C
4719       do k=i,j-1
4720         do l=1,3
4721           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4722         enddo
4723       enddo
4724       return
4725       end
4726 C--------------------------------------------------------------------------
4727       subroutine ebond(estr)
4728 c
4729 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4730 c
4731       implicit real*8 (a-h,o-z)
4732       include 'DIMENSIONS'
4733       include 'DIMENSIONS.ZSCOPT'
4734       include 'COMMON.LOCAL'
4735       include 'COMMON.GEO'
4736       include 'COMMON.INTERACT'
4737       include 'COMMON.DERIV'
4738       include 'COMMON.VAR'
4739       include 'COMMON.CHAIN'
4740       include 'COMMON.IOUNITS'
4741       include 'COMMON.NAMES'
4742       include 'COMMON.FFIELD'
4743       include 'COMMON.CONTROL'
4744       double precision u(3),ud(3)
4745       estr=0.0d0
4746       do i=nnt+1,nct
4747         diff = vbld(i)-vbldp0
4748 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4749         estr=estr+diff*diff
4750         do j=1,3
4751           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4752         enddo
4753       enddo
4754       estr=0.5d0*AKP*estr
4755 c
4756 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4757 c
4758       do i=nnt,nct
4759         iti=itype(i)
4760         if (iti.ne.10) then
4761           nbi=nbondterm(iti)
4762           if (nbi.eq.1) then
4763             diff=vbld(i+nres)-vbldsc0(1,iti)
4764 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4765 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4766             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4767             do j=1,3
4768               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4769             enddo
4770           else
4771             do j=1,nbi
4772               diff=vbld(i+nres)-vbldsc0(j,iti)
4773               ud(j)=aksc(j,iti)*diff
4774               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4775             enddo
4776             uprod=u(1)
4777             do j=2,nbi
4778               uprod=uprod*u(j)
4779             enddo
4780             usum=0.0d0
4781             usumsqder=0.0d0
4782             do j=1,nbi
4783               uprod1=1.0d0
4784               uprod2=1.0d0
4785               do k=1,nbi
4786                 if (k.ne.j) then
4787                   uprod1=uprod1*u(k)
4788                   uprod2=uprod2*u(k)*u(k)
4789                 endif
4790               enddo
4791               usum=usum+uprod1
4792               usumsqder=usumsqder+ud(j)*uprod2
4793             enddo
4794 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4795 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4796             estr=estr+uprod/usum
4797             do j=1,3
4798              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4799             enddo
4800           endif
4801         endif
4802       enddo
4803       return
4804       end
4805 #ifdef CRYST_THETA
4806 C--------------------------------------------------------------------------
4807       subroutine ebend(etheta)
4808 C
4809 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4810 C angles gamma and its derivatives in consecutive thetas and gammas.
4811 C
4812       implicit real*8 (a-h,o-z)
4813       include 'DIMENSIONS'
4814       include 'DIMENSIONS.ZSCOPT'
4815       include 'COMMON.LOCAL'
4816       include 'COMMON.GEO'
4817       include 'COMMON.INTERACT'
4818       include 'COMMON.DERIV'
4819       include 'COMMON.VAR'
4820       include 'COMMON.CHAIN'
4821       include 'COMMON.IOUNITS'
4822       include 'COMMON.NAMES'
4823       include 'COMMON.FFIELD'
4824       common /calcthet/ term1,term2,termm,diffak,ratak,
4825      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4826      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4827       double precision y(2),z(2)
4828       delta=0.02d0*pi
4829       time11=dexp(-2*time)
4830       time12=1.0d0
4831       etheta=0.0D0
4832 c      write (iout,*) "nres",nres
4833 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4834 c      write (iout,*) ithet_start,ithet_end
4835       do i=ithet_start,ithet_end
4836 C Zero the energy function and its derivative at 0 or pi.
4837         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4838         it=itype(i-1)
4839 c        if (i.gt.ithet_start .and.
4840 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4841 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4842 c          phii=phi(i)
4843 c          y(1)=dcos(phii)
4844 c          y(2)=dsin(phii)
4845 c        else
4846 c          y(1)=0.0D0
4847 c          y(2)=0.0D0
4848 c        endif
4849 c        if (i.lt.nres .and. itel(i).ne.0) then
4850 c          phii1=phi(i+1)
4851 c          z(1)=dcos(phii1)
4852 c          z(2)=dsin(phii1)
4853 c        else
4854 c          z(1)=0.0D0
4855 c          z(2)=0.0D0
4856 c        endif
4857         if (i.gt.3) then
4858 #ifdef OSF
4859           phii=phi(i)
4860           icrc=0
4861           call proc_proc(phii,icrc)
4862           if (icrc.eq.1) phii=150.0
4863 #else
4864           phii=phi(i)
4865 #endif
4866           y(1)=dcos(phii)
4867           y(2)=dsin(phii)
4868         else
4869           y(1)=0.0D0
4870           y(2)=0.0D0
4871         endif
4872         if (i.lt.nres) then
4873 #ifdef OSF
4874           phii1=phi(i+1)
4875           icrc=0
4876           call proc_proc(phii1,icrc)
4877           if (icrc.eq.1) phii1=150.0
4878           phii1=pinorm(phii1)
4879           z(1)=cos(phii1)
4880 #else
4881           phii1=phi(i+1)
4882           z(1)=dcos(phii1)
4883 #endif
4884           z(2)=dsin(phii1)
4885         else
4886           z(1)=0.0D0
4887           z(2)=0.0D0
4888         endif
4889 C Calculate the "mean" value of theta from the part of the distribution
4890 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4891 C In following comments this theta will be referred to as t_c.
4892         thet_pred_mean=0.0d0
4893         do k=1,2
4894           athetk=athet(k,it)
4895           bthetk=bthet(k,it)
4896           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4897         enddo
4898 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4899         dthett=thet_pred_mean*ssd
4900         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4901 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4902 C Derivatives of the "mean" values in gamma1 and gamma2.
4903         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4904         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4905         if (theta(i).gt.pi-delta) then
4906           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4907      &         E_tc0)
4908           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4909           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4910           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4911      &        E_theta)
4912           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4913      &        E_tc)
4914         else if (theta(i).lt.delta) then
4915           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4916           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4917           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4918      &        E_theta)
4919           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4920           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4921      &        E_tc)
4922         else
4923           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4924      &        E_theta,E_tc)
4925         endif
4926         etheta=etheta+ethetai
4927 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4928 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4929         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4930         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4931         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4932  1215   continue
4933       enddo
4934 C Ufff.... We've done all this!!!
4935       return
4936       end
4937 C---------------------------------------------------------------------------
4938       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4939      &     E_tc)
4940       implicit real*8 (a-h,o-z)
4941       include 'DIMENSIONS'
4942       include 'DIMENSIONS.ZSCOPT'
4943       include 'COMMON.LOCAL'
4944       include 'COMMON.IOUNITS'
4945       common /calcthet/ term1,term2,termm,diffak,ratak,
4946      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4947      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4948 C Calculate the contributions to both Gaussian lobes.
4949 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4950 C The "polynomial part" of the "standard deviation" of this part of
4951 C the distribution.
4952         sig=polthet(3,it)
4953         do j=2,0,-1
4954           sig=sig*thet_pred_mean+polthet(j,it)
4955         enddo
4956 C Derivative of the "interior part" of the "standard deviation of the"
4957 C gamma-dependent Gaussian lobe in t_c.
4958         sigtc=3*polthet(3,it)
4959         do j=2,1,-1
4960           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4961         enddo
4962         sigtc=sig*sigtc
4963 C Set the parameters of both Gaussian lobes of the distribution.
4964 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4965         fac=sig*sig+sigc0(it)
4966         sigcsq=fac+fac
4967         sigc=1.0D0/sigcsq
4968 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4969         sigsqtc=-4.0D0*sigcsq*sigtc
4970 c       print *,i,sig,sigtc,sigsqtc
4971 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4972         sigtc=-sigtc/(fac*fac)
4973 C Following variable is sigma(t_c)**(-2)
4974         sigcsq=sigcsq*sigcsq
4975         sig0i=sig0(it)
4976         sig0inv=1.0D0/sig0i**2
4977         delthec=thetai-thet_pred_mean
4978         delthe0=thetai-theta0i
4979         term1=-0.5D0*sigcsq*delthec*delthec
4980         term2=-0.5D0*sig0inv*delthe0*delthe0
4981 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4982 C NaNs in taking the logarithm. We extract the largest exponent which is added
4983 C to the energy (this being the log of the distribution) at the end of energy
4984 C term evaluation for this virtual-bond angle.
4985         if (term1.gt.term2) then
4986           termm=term1
4987           term2=dexp(term2-termm)
4988           term1=1.0d0
4989         else
4990           termm=term2
4991           term1=dexp(term1-termm)
4992           term2=1.0d0
4993         endif
4994 C The ratio between the gamma-independent and gamma-dependent lobes of
4995 C the distribution is a Gaussian function of thet_pred_mean too.
4996         diffak=gthet(2,it)-thet_pred_mean
4997         ratak=diffak/gthet(3,it)**2
4998         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4999 C Let's differentiate it in thet_pred_mean NOW.
5000         aktc=ak*ratak
5001 C Now put together the distribution terms to make complete distribution.
5002         termexp=term1+ak*term2
5003         termpre=sigc+ak*sig0i
5004 C Contribution of the bending energy from this theta is just the -log of
5005 C the sum of the contributions from the two lobes and the pre-exponential
5006 C factor. Simple enough, isn't it?
5007         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5008 C NOW the derivatives!!!
5009 C 6/6/97 Take into account the deformation.
5010         E_theta=(delthec*sigcsq*term1
5011      &       +ak*delthe0*sig0inv*term2)/termexp
5012         E_tc=((sigtc+aktc*sig0i)/termpre
5013      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5014      &       aktc*term2)/termexp)
5015       return
5016       end
5017 c-----------------------------------------------------------------------------
5018       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5019       implicit real*8 (a-h,o-z)
5020       include 'DIMENSIONS'
5021       include 'DIMENSIONS.ZSCOPT'
5022       include 'COMMON.LOCAL'
5023       include 'COMMON.IOUNITS'
5024       common /calcthet/ term1,term2,termm,diffak,ratak,
5025      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5026      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5027       delthec=thetai-thet_pred_mean
5028       delthe0=thetai-theta0i
5029 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5030       t3 = thetai-thet_pred_mean
5031       t6 = t3**2
5032       t9 = term1
5033       t12 = t3*sigcsq
5034       t14 = t12+t6*sigsqtc
5035       t16 = 1.0d0
5036       t21 = thetai-theta0i
5037       t23 = t21**2
5038       t26 = term2
5039       t27 = t21*t26
5040       t32 = termexp
5041       t40 = t32**2
5042       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5043      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5044      & *(-t12*t9-ak*sig0inv*t27)
5045       return
5046       end
5047 #else
5048 C--------------------------------------------------------------------------
5049       subroutine ebend(etheta)
5050 C
5051 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5052 C angles gamma and its derivatives in consecutive thetas and gammas.
5053 C ab initio-derived potentials from
5054 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5055 C
5056       implicit real*8 (a-h,o-z)
5057       include 'DIMENSIONS'
5058       include 'DIMENSIONS.ZSCOPT'
5059       include 'COMMON.LOCAL'
5060       include 'COMMON.GEO'
5061       include 'COMMON.INTERACT'
5062       include 'COMMON.DERIV'
5063       include 'COMMON.VAR'
5064       include 'COMMON.CHAIN'
5065       include 'COMMON.IOUNITS'
5066       include 'COMMON.NAMES'
5067       include 'COMMON.FFIELD'
5068       include 'COMMON.CONTROL'
5069       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5070      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5071      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5072      & sinph1ph2(maxdouble,maxdouble)
5073       logical lprn /.false./, lprn1 /.false./
5074       etheta=0.0D0
5075 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5076       do i=ithet_start,ithet_end
5077         dethetai=0.0d0
5078         dephii=0.0d0
5079         dephii1=0.0d0
5080         theti2=0.5d0*theta(i)
5081         ityp2=ithetyp(itype(i-1))
5082         do k=1,nntheterm
5083           coskt(k)=dcos(k*theti2)
5084           sinkt(k)=dsin(k*theti2)
5085         enddo
5086         if (i.gt.3) then
5087 #ifdef OSF
5088           phii=phi(i)
5089           if (phii.ne.phii) phii=150.0
5090 #else
5091           phii=phi(i)
5092 #endif
5093           ityp1=ithetyp(itype(i-2))
5094           do k=1,nsingle
5095             cosph1(k)=dcos(k*phii)
5096             sinph1(k)=dsin(k*phii)
5097           enddo
5098         else
5099           phii=0.0d0
5100           ityp1=nthetyp+1
5101           do k=1,nsingle
5102             cosph1(k)=0.0d0
5103             sinph1(k)=0.0d0
5104           enddo
5105         endif
5106         if (i.lt.nres) then
5107 #ifdef OSF
5108           phii1=phi(i+1)
5109           if (phii1.ne.phii1) phii1=150.0
5110           phii1=pinorm(phii1)
5111 #else
5112           phii1=phi(i+1)
5113 #endif
5114           ityp3=ithetyp(itype(i))
5115           do k=1,nsingle
5116             cosph2(k)=dcos(k*phii1)
5117             sinph2(k)=dsin(k*phii1)
5118           enddo
5119         else
5120           phii1=0.0d0
5121           ityp3=nthetyp+1
5122           do k=1,nsingle
5123             cosph2(k)=0.0d0
5124             sinph2(k)=0.0d0
5125           enddo
5126         endif
5127 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5128 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5129 c        call flush(iout)
5130         ethetai=aa0thet(ityp1,ityp2,ityp3)
5131         do k=1,ndouble
5132           do l=1,k-1
5133             ccl=cosph1(l)*cosph2(k-l)
5134             ssl=sinph1(l)*sinph2(k-l)
5135             scl=sinph1(l)*cosph2(k-l)
5136             csl=cosph1(l)*sinph2(k-l)
5137             cosph1ph2(l,k)=ccl-ssl
5138             cosph1ph2(k,l)=ccl+ssl
5139             sinph1ph2(l,k)=scl+csl
5140             sinph1ph2(k,l)=scl-csl
5141           enddo
5142         enddo
5143         if (lprn) then
5144         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5145      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5146         write (iout,*) "coskt and sinkt"
5147         do k=1,nntheterm
5148           write (iout,*) k,coskt(k),sinkt(k)
5149         enddo
5150         endif
5151         do k=1,ntheterm
5152           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5153           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5154      &      *coskt(k)
5155           if (lprn)
5156      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5157      &     " ethetai",ethetai
5158         enddo
5159         if (lprn) then
5160         write (iout,*) "cosph and sinph"
5161         do k=1,nsingle
5162           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5163         enddo
5164         write (iout,*) "cosph1ph2 and sinph2ph2"
5165         do k=2,ndouble
5166           do l=1,k-1
5167             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5168      &         sinph1ph2(l,k),sinph1ph2(k,l)
5169           enddo
5170         enddo
5171         write(iout,*) "ethetai",ethetai
5172         endif
5173         do m=1,ntheterm2
5174           do k=1,nsingle
5175             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5176      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5177      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5178      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5179             ethetai=ethetai+sinkt(m)*aux
5180             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5181             dephii=dephii+k*sinkt(m)*(
5182      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5183      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5184             dephii1=dephii1+k*sinkt(m)*(
5185      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5186      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5187             if (lprn)
5188      &      write (iout,*) "m",m," k",k," bbthet",
5189      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5190      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5191      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5192      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5193           enddo
5194         enddo
5195         if (lprn)
5196      &  write(iout,*) "ethetai",ethetai
5197         do m=1,ntheterm3
5198           do k=2,ndouble
5199             do l=1,k-1
5200               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5201      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5202      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5203      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5204               ethetai=ethetai+sinkt(m)*aux
5205               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5206               dephii=dephii+l*sinkt(m)*(
5207      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5208      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5209      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5210      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5211               dephii1=dephii1+(k-l)*sinkt(m)*(
5212      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5213      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5214      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5215      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5216               if (lprn) then
5217               write (iout,*) "m",m," k",k," l",l," ffthet",
5218      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5219      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5220      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5221      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5222               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5223      &            cosph1ph2(k,l)*sinkt(m),
5224      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5225               endif
5226             enddo
5227           enddo
5228         enddo
5229 10      continue
5230         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5231      &   i,theta(i)*rad2deg,phii*rad2deg,
5232      &   phii1*rad2deg,ethetai
5233         etheta=etheta+ethetai
5234         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5235         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5236         gloc(nphi+i-2,icg)=wang*dethetai
5237       enddo
5238       return
5239       end
5240 #endif
5241 #ifdef CRYST_SC
5242 c-----------------------------------------------------------------------------
5243       subroutine esc(escloc)
5244 C Calculate the local energy of a side chain and its derivatives in the
5245 C corresponding virtual-bond valence angles THETA and the spherical angles
5246 C ALPHA and OMEGA.
5247       implicit real*8 (a-h,o-z)
5248       include 'DIMENSIONS'
5249       include 'DIMENSIONS.ZSCOPT'
5250       include 'COMMON.GEO'
5251       include 'COMMON.LOCAL'
5252       include 'COMMON.VAR'
5253       include 'COMMON.INTERACT'
5254       include 'COMMON.DERIV'
5255       include 'COMMON.CHAIN'
5256       include 'COMMON.IOUNITS'
5257       include 'COMMON.NAMES'
5258       include 'COMMON.FFIELD'
5259       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5260      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5261       common /sccalc/ time11,time12,time112,theti,it,nlobit
5262       delta=0.02d0*pi
5263       escloc=0.0D0
5264 c     write (iout,'(a)') 'ESC'
5265       do i=loc_start,loc_end
5266         it=itype(i)
5267         if (it.eq.10) goto 1
5268         nlobit=nlob(it)
5269 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5270 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5271         theti=theta(i+1)-pipol
5272         x(1)=dtan(theti)
5273         x(2)=alph(i)
5274         x(3)=omeg(i)
5275 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5276
5277         if (x(2).gt.pi-delta) then
5278           xtemp(1)=x(1)
5279           xtemp(2)=pi-delta
5280           xtemp(3)=x(3)
5281           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5282           xtemp(2)=pi
5283           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5284           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5285      &        escloci,dersc(2))
5286           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5287      &        ddersc0(1),dersc(1))
5288           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5289      &        ddersc0(3),dersc(3))
5290           xtemp(2)=pi-delta
5291           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5292           xtemp(2)=pi
5293           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5294           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5295      &            dersc0(2),esclocbi,dersc02)
5296           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5297      &            dersc12,dersc01)
5298           call splinthet(x(2),0.5d0*delta,ss,ssd)
5299           dersc0(1)=dersc01
5300           dersc0(2)=dersc02
5301           dersc0(3)=0.0d0
5302           do k=1,3
5303             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5304           enddo
5305           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5306 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5307 c    &             esclocbi,ss,ssd
5308           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5309 c         escloci=esclocbi
5310 c         write (iout,*) escloci
5311         else if (x(2).lt.delta) then
5312           xtemp(1)=x(1)
5313           xtemp(2)=delta
5314           xtemp(3)=x(3)
5315           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5316           xtemp(2)=0.0d0
5317           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5318           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5319      &        escloci,dersc(2))
5320           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5321      &        ddersc0(1),dersc(1))
5322           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5323      &        ddersc0(3),dersc(3))
5324           xtemp(2)=delta
5325           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5326           xtemp(2)=0.0d0
5327           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5328           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5329      &            dersc0(2),esclocbi,dersc02)
5330           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5331      &            dersc12,dersc01)
5332           dersc0(1)=dersc01
5333           dersc0(2)=dersc02
5334           dersc0(3)=0.0d0
5335           call splinthet(x(2),0.5d0*delta,ss,ssd)
5336           do k=1,3
5337             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5338           enddo
5339           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5340 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5341 c    &             esclocbi,ss,ssd
5342           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5343 c         write (iout,*) escloci
5344         else
5345           call enesc(x,escloci,dersc,ddummy,.false.)
5346         endif
5347
5348         escloc=escloc+escloci
5349 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5350
5351         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5352      &   wscloc*dersc(1)
5353         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5354         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5355     1   continue
5356       enddo
5357       return
5358       end
5359 C---------------------------------------------------------------------------
5360       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5361       implicit real*8 (a-h,o-z)
5362       include 'DIMENSIONS'
5363       include 'DIMENSIONS.ZSCOPT'
5364       include 'COMMON.GEO'
5365       include 'COMMON.LOCAL'
5366       include 'COMMON.IOUNITS'
5367       common /sccalc/ time11,time12,time112,theti,it,nlobit
5368       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5369       double precision contr(maxlob,-1:1)
5370       logical mixed
5371 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5372         escloc_i=0.0D0
5373         do j=1,3
5374           dersc(j)=0.0D0
5375           if (mixed) ddersc(j)=0.0d0
5376         enddo
5377         x3=x(3)
5378
5379 C Because of periodicity of the dependence of the SC energy in omega we have
5380 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5381 C To avoid underflows, first compute & store the exponents.
5382
5383         do iii=-1,1
5384
5385           x(3)=x3+iii*dwapi
5386
5387           do j=1,nlobit
5388             do k=1,3
5389               z(k)=x(k)-censc(k,j,it)
5390             enddo
5391             do k=1,3
5392               Axk=0.0D0
5393               do l=1,3
5394                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5395               enddo
5396               Ax(k,j,iii)=Axk
5397             enddo
5398             expfac=0.0D0
5399             do k=1,3
5400               expfac=expfac+Ax(k,j,iii)*z(k)
5401             enddo
5402             contr(j,iii)=expfac
5403           enddo ! j
5404
5405         enddo ! iii
5406
5407         x(3)=x3
5408 C As in the case of ebend, we want to avoid underflows in exponentiation and
5409 C subsequent NaNs and INFs in energy calculation.
5410 C Find the largest exponent
5411         emin=contr(1,-1)
5412         do iii=-1,1
5413           do j=1,nlobit
5414             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5415           enddo
5416         enddo
5417         emin=0.5D0*emin
5418 cd      print *,'it=',it,' emin=',emin
5419
5420 C Compute the contribution to SC energy and derivatives
5421         do iii=-1,1
5422
5423           do j=1,nlobit
5424             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5425 cd          print *,'j=',j,' expfac=',expfac
5426             escloc_i=escloc_i+expfac
5427             do k=1,3
5428               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5429             enddo
5430             if (mixed) then
5431               do k=1,3,2
5432                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5433      &            +gaussc(k,2,j,it))*expfac
5434               enddo
5435             endif
5436           enddo
5437
5438         enddo ! iii
5439
5440         dersc(1)=dersc(1)/cos(theti)**2
5441         ddersc(1)=ddersc(1)/cos(theti)**2
5442         ddersc(3)=ddersc(3)
5443
5444         escloci=-(dlog(escloc_i)-emin)
5445         do j=1,3
5446           dersc(j)=dersc(j)/escloc_i
5447         enddo
5448         if (mixed) then
5449           do j=1,3,2
5450             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5451           enddo
5452         endif
5453       return
5454       end
5455 C------------------------------------------------------------------------------
5456       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5457       implicit real*8 (a-h,o-z)
5458       include 'DIMENSIONS'
5459       include 'DIMENSIONS.ZSCOPT'
5460       include 'COMMON.GEO'
5461       include 'COMMON.LOCAL'
5462       include 'COMMON.IOUNITS'
5463       common /sccalc/ time11,time12,time112,theti,it,nlobit
5464       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5465       double precision contr(maxlob)
5466       logical mixed
5467
5468       escloc_i=0.0D0
5469
5470       do j=1,3
5471         dersc(j)=0.0D0
5472       enddo
5473
5474       do j=1,nlobit
5475         do k=1,2
5476           z(k)=x(k)-censc(k,j,it)
5477         enddo
5478         z(3)=dwapi
5479         do k=1,3
5480           Axk=0.0D0
5481           do l=1,3
5482             Axk=Axk+gaussc(l,k,j,it)*z(l)
5483           enddo
5484           Ax(k,j)=Axk
5485         enddo
5486         expfac=0.0D0
5487         do k=1,3
5488           expfac=expfac+Ax(k,j)*z(k)
5489         enddo
5490         contr(j)=expfac
5491       enddo ! j
5492
5493 C As in the case of ebend, we want to avoid underflows in exponentiation and
5494 C subsequent NaNs and INFs in energy calculation.
5495 C Find the largest exponent
5496       emin=contr(1)
5497       do j=1,nlobit
5498         if (emin.gt.contr(j)) emin=contr(j)
5499       enddo
5500       emin=0.5D0*emin
5501
5502 C Compute the contribution to SC energy and derivatives
5503
5504       dersc12=0.0d0
5505       do j=1,nlobit
5506         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5507         escloc_i=escloc_i+expfac
5508         do k=1,2
5509           dersc(k)=dersc(k)+Ax(k,j)*expfac
5510         enddo
5511         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5512      &            +gaussc(1,2,j,it))*expfac
5513         dersc(3)=0.0d0
5514       enddo
5515
5516       dersc(1)=dersc(1)/cos(theti)**2
5517       dersc12=dersc12/cos(theti)**2
5518       escloci=-(dlog(escloc_i)-emin)
5519       do j=1,2
5520         dersc(j)=dersc(j)/escloc_i
5521       enddo
5522       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5523       return
5524       end
5525 #else
5526 c----------------------------------------------------------------------------------
5527       subroutine esc(escloc)
5528 C Calculate the local energy of a side chain and its derivatives in the
5529 C corresponding virtual-bond valence angles THETA and the spherical angles
5530 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5531 C added by Urszula Kozlowska. 07/11/2007
5532 C
5533       implicit real*8 (a-h,o-z)
5534       include 'DIMENSIONS'
5535       include 'DIMENSIONS.ZSCOPT'
5536       include 'COMMON.GEO'
5537       include 'COMMON.LOCAL'
5538       include 'COMMON.VAR'
5539       include 'COMMON.SCROT'
5540       include 'COMMON.INTERACT'
5541       include 'COMMON.DERIV'
5542       include 'COMMON.CHAIN'
5543       include 'COMMON.IOUNITS'
5544       include 'COMMON.NAMES'
5545       include 'COMMON.FFIELD'
5546       include 'COMMON.CONTROL'
5547       include 'COMMON.VECTORS'
5548       double precision x_prime(3),y_prime(3),z_prime(3)
5549      &    , sumene,dsc_i,dp2_i,x(65),
5550      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5551      &    de_dxx,de_dyy,de_dzz,de_dt
5552       double precision s1_t,s1_6_t,s2_t,s2_6_t
5553       double precision
5554      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5555      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5556      & dt_dCi(3),dt_dCi1(3)
5557       common /sccalc/ time11,time12,time112,theti,it,nlobit
5558       delta=0.02d0*pi
5559       escloc=0.0D0
5560       do i=loc_start,loc_end
5561         costtab(i+1) =dcos(theta(i+1))
5562         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5563         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5564         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5565         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5566         cosfac=dsqrt(cosfac2)
5567         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5568         sinfac=dsqrt(sinfac2)
5569         it=itype(i)
5570         if (it.eq.10) goto 1
5571 c
5572 C  Compute the axes of tghe local cartesian coordinates system; store in
5573 c   x_prime, y_prime and z_prime
5574 c
5575         do j=1,3
5576           x_prime(j) = 0.00
5577           y_prime(j) = 0.00
5578           z_prime(j) = 0.00
5579         enddo
5580 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5581 C     &   dc_norm(3,i+nres)
5582         do j = 1,3
5583           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5584           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5585         enddo
5586         do j = 1,3
5587           z_prime(j) = -uz(j,i-1)
5588         enddo
5589 c       write (2,*) "i",i
5590 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5591 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5592 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5593 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5594 c      & " xy",scalar(x_prime(1),y_prime(1)),
5595 c      & " xz",scalar(x_prime(1),z_prime(1)),
5596 c      & " yy",scalar(y_prime(1),y_prime(1)),
5597 c      & " yz",scalar(y_prime(1),z_prime(1)),
5598 c      & " zz",scalar(z_prime(1),z_prime(1))
5599 c
5600 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5601 C to local coordinate system. Store in xx, yy, zz.
5602 c
5603         xx=0.0d0
5604         yy=0.0d0
5605         zz=0.0d0
5606         do j = 1,3
5607           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5608           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5609           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5610         enddo
5611
5612         xxtab(i)=xx
5613         yytab(i)=yy
5614         zztab(i)=zz
5615 C
5616 C Compute the energy of the ith side cbain
5617 C
5618 c        write (2,*) "xx",xx," yy",yy," zz",zz
5619         it=itype(i)
5620         do j = 1,65
5621           x(j) = sc_parmin(j,it)
5622         enddo
5623 #ifdef CHECK_COORD
5624 Cc diagnostics - remove later
5625         xx1 = dcos(alph(2))
5626         yy1 = dsin(alph(2))*dcos(omeg(2))
5627         zz1 = -dsin(alph(2))*dsin(omeg(2))
5628         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5629      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5630      &    xx1,yy1,zz1
5631 C,"  --- ", xx_w,yy_w,zz_w
5632 c end diagnostics
5633 #endif
5634         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5635      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5636      &   + x(10)*yy*zz
5637         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5638      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5639      & + x(20)*yy*zz
5640         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5641      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5642      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5643      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5644      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5645      &  +x(40)*xx*yy*zz
5646         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5647      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5648      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5649      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5650      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5651      &  +x(60)*xx*yy*zz
5652         dsc_i   = 0.743d0+x(61)
5653         dp2_i   = 1.9d0+x(62)
5654         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5655      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5656         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5657      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5658         s1=(1+x(63))/(0.1d0 + dscp1)
5659         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5660         s2=(1+x(65))/(0.1d0 + dscp2)
5661         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5662         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5663      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5664 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5665 c     &   sumene4,
5666 c     &   dscp1,dscp2,sumene
5667 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5668         escloc = escloc + sumene
5669 c        write (2,*) "escloc",escloc
5670         if (.not. calc_grad) goto 1
5671 #ifdef DEBUG
5672 C
5673 C This section to check the numerical derivatives of the energy of ith side
5674 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5675 C #define DEBUG in the code to turn it on.
5676 C
5677         write (2,*) "sumene               =",sumene
5678         aincr=1.0d-7
5679         xxsave=xx
5680         xx=xx+aincr
5681         write (2,*) xx,yy,zz
5682         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5683         de_dxx_num=(sumenep-sumene)/aincr
5684         xx=xxsave
5685         write (2,*) "xx+ sumene from enesc=",sumenep
5686         yysave=yy
5687         yy=yy+aincr
5688         write (2,*) xx,yy,zz
5689         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5690         de_dyy_num=(sumenep-sumene)/aincr
5691         yy=yysave
5692         write (2,*) "yy+ sumene from enesc=",sumenep
5693         zzsave=zz
5694         zz=zz+aincr
5695         write (2,*) xx,yy,zz
5696         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5697         de_dzz_num=(sumenep-sumene)/aincr
5698         zz=zzsave
5699         write (2,*) "zz+ sumene from enesc=",sumenep
5700         costsave=cost2tab(i+1)
5701         sintsave=sint2tab(i+1)
5702         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5703         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5704         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5705         de_dt_num=(sumenep-sumene)/aincr
5706         write (2,*) " t+ sumene from enesc=",sumenep
5707         cost2tab(i+1)=costsave
5708         sint2tab(i+1)=sintsave
5709 C End of diagnostics section.
5710 #endif
5711 C
5712 C Compute the gradient of esc
5713 C
5714         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5715         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5716         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5717         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5718         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5719         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5720         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5721         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5722         pom1=(sumene3*sint2tab(i+1)+sumene1)
5723      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5724         pom2=(sumene4*cost2tab(i+1)+sumene2)
5725      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5726         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5727         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5728      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5729      &  +x(40)*yy*zz
5730         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5731         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5732      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5733      &  +x(60)*yy*zz
5734         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5735      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5736      &        +(pom1+pom2)*pom_dx
5737 #ifdef DEBUG
5738         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5739 #endif
5740 C
5741         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5742         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5743      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5744      &  +x(40)*xx*zz
5745         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5746         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5747      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5748      &  +x(59)*zz**2 +x(60)*xx*zz
5749         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5750      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5751      &        +(pom1-pom2)*pom_dy
5752 #ifdef DEBUG
5753         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5754 #endif
5755 C
5756         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5757      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5758      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5759      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5760      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5761      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5762      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5763      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5764 #ifdef DEBUG
5765         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5766 #endif
5767 C
5768         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5769      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5770      &  +pom1*pom_dt1+pom2*pom_dt2
5771 #ifdef DEBUG
5772         write(2,*), "de_dt = ", de_dt,de_dt_num
5773 #endif
5774 c
5775 C
5776        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5777        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5778        cosfac2xx=cosfac2*xx
5779        sinfac2yy=sinfac2*yy
5780        do k = 1,3
5781          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5782      &      vbld_inv(i+1)
5783          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5784      &      vbld_inv(i)
5785          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5786          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5787 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5788 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5789 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5790 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5791          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5792          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5793          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5794          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5795          dZZ_Ci1(k)=0.0d0
5796          dZZ_Ci(k)=0.0d0
5797          do j=1,3
5798            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5799            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5800          enddo
5801
5802          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5803          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5804          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5805 c
5806          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5807          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5808        enddo
5809
5810        do k=1,3
5811          dXX_Ctab(k,i)=dXX_Ci(k)
5812          dXX_C1tab(k,i)=dXX_Ci1(k)
5813          dYY_Ctab(k,i)=dYY_Ci(k)
5814          dYY_C1tab(k,i)=dYY_Ci1(k)
5815          dZZ_Ctab(k,i)=dZZ_Ci(k)
5816          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5817          dXX_XYZtab(k,i)=dXX_XYZ(k)
5818          dYY_XYZtab(k,i)=dYY_XYZ(k)
5819          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5820        enddo
5821
5822        do k = 1,3
5823 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5824 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5825 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5826 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5827 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5828 c     &    dt_dci(k)
5829 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5830 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5831          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5832      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5833          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5834      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5835          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5836      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5837        enddo
5838 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5839 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5840
5841 C to check gradient call subroutine check_grad
5842
5843     1 continue
5844       enddo
5845       return
5846       end
5847 #endif
5848 c------------------------------------------------------------------------------
5849       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5850 C
5851 C This procedure calculates two-body contact function g(rij) and its derivative:
5852 C
5853 C           eps0ij                                     !       x < -1
5854 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5855 C            0                                         !       x > 1
5856 C
5857 C where x=(rij-r0ij)/delta
5858 C
5859 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5860 C
5861       implicit none
5862       double precision rij,r0ij,eps0ij,fcont,fprimcont
5863       double precision x,x2,x4,delta
5864 c     delta=0.02D0*r0ij
5865 c      delta=0.2D0*r0ij
5866       x=(rij-r0ij)/delta
5867       if (x.lt.-1.0D0) then
5868         fcont=eps0ij
5869         fprimcont=0.0D0
5870       else if (x.le.1.0D0) then
5871         x2=x*x
5872         x4=x2*x2
5873         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5874         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5875       else
5876         fcont=0.0D0
5877         fprimcont=0.0D0
5878       endif
5879       return
5880       end
5881 c------------------------------------------------------------------------------
5882       subroutine splinthet(theti,delta,ss,ssder)
5883       implicit real*8 (a-h,o-z)
5884       include 'DIMENSIONS'
5885       include 'DIMENSIONS.ZSCOPT'
5886       include 'COMMON.VAR'
5887       include 'COMMON.GEO'
5888       thetup=pi-delta
5889       thetlow=delta
5890       if (theti.gt.pipol) then
5891         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5892       else
5893         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5894         ssder=-ssder
5895       endif
5896       return
5897       end
5898 c------------------------------------------------------------------------------
5899       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5900       implicit none
5901       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5902       double precision ksi,ksi2,ksi3,a1,a2,a3
5903       a1=fprim0*delta/(f1-f0)
5904       a2=3.0d0-2.0d0*a1
5905       a3=a1-2.0d0
5906       ksi=(x-x0)/delta
5907       ksi2=ksi*ksi
5908       ksi3=ksi2*ksi
5909       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5910       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5911       return
5912       end
5913 c------------------------------------------------------------------------------
5914       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5915       implicit none
5916       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5917       double precision ksi,ksi2,ksi3,a1,a2,a3
5918       ksi=(x-x0)/delta
5919       ksi2=ksi*ksi
5920       ksi3=ksi2*ksi
5921       a1=fprim0x*delta
5922       a2=3*(f1x-f0x)-2*fprim0x*delta
5923       a3=fprim0x*delta-2*(f1x-f0x)
5924       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5925       return
5926       end
5927 C-----------------------------------------------------------------------------
5928 #ifdef CRYST_TOR
5929 C-----------------------------------------------------------------------------
5930       subroutine etor(etors,edihcnstr)
5931       implicit real*8 (a-h,o-z)
5932       include 'DIMENSIONS'
5933       include 'DIMENSIONS.ZSCOPT'
5934       include 'COMMON.VAR'
5935       include 'COMMON.GEO'
5936       include 'COMMON.LOCAL'
5937       include 'COMMON.TORSION'
5938       include 'COMMON.INTERACT'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.CHAIN'
5941       include 'COMMON.NAMES'
5942       include 'COMMON.IOUNITS'
5943       include 'COMMON.FFIELD'
5944       include 'COMMON.TORCNSTR'
5945       logical lprn
5946 C Set lprn=.true. for debugging
5947       lprn=.false.
5948 c      lprn=.true.
5949       etors=0.0D0
5950       do i=iphi_start,iphi_end
5951         itori=itortyp(itype(i-2))
5952         itori1=itortyp(itype(i-1))
5953         phii=phi(i)
5954         gloci=0.0D0
5955 C Proline-Proline pair is a special case...
5956         if (itori.eq.3 .and. itori1.eq.3) then
5957           if (phii.gt.-dwapi3) then
5958             cosphi=dcos(3*phii)
5959             fac=1.0D0/(1.0D0-cosphi)
5960             etorsi=v1(1,3,3)*fac
5961             etorsi=etorsi+etorsi
5962             etors=etors+etorsi-v1(1,3,3)
5963             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5964           endif
5965           do j=1,3
5966             v1ij=v1(j+1,itori,itori1)
5967             v2ij=v2(j+1,itori,itori1)
5968             cosphi=dcos(j*phii)
5969             sinphi=dsin(j*phii)
5970             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5971             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5972           enddo
5973         else
5974           do j=1,nterm_old
5975             v1ij=v1(j,itori,itori1)
5976             v2ij=v2(j,itori,itori1)
5977             cosphi=dcos(j*phii)
5978             sinphi=dsin(j*phii)
5979             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5980             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5981           enddo
5982         endif
5983         if (lprn)
5984      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5985      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5986      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5987         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5988 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5989       enddo
5990 ! 6/20/98 - dihedral angle constraints
5991       edihcnstr=0.0d0
5992       do i=1,ndih_constr
5993         itori=idih_constr(i)
5994         phii=phi(itori)
5995         difi=phii-phi0(i)
5996         if (difi.gt.drange(i)) then
5997           difi=difi-drange(i)
5998           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5999           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6000         else if (difi.lt.-drange(i)) then
6001           difi=difi+drange(i)
6002           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6003           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6004         endif
6005 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6006 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6007       enddo
6008 !      write (iout,*) 'edihcnstr',edihcnstr
6009       return
6010       end
6011 c------------------------------------------------------------------------------
6012 #else
6013       subroutine etor(etors,edihcnstr)
6014       implicit real*8 (a-h,o-z)
6015       include 'DIMENSIONS'
6016       include 'DIMENSIONS.ZSCOPT'
6017       include 'COMMON.VAR'
6018       include 'COMMON.GEO'
6019       include 'COMMON.LOCAL'
6020       include 'COMMON.TORSION'
6021       include 'COMMON.INTERACT'
6022       include 'COMMON.DERIV'
6023       include 'COMMON.CHAIN'
6024       include 'COMMON.NAMES'
6025       include 'COMMON.IOUNITS'
6026       include 'COMMON.FFIELD'
6027       include 'COMMON.TORCNSTR'
6028       include 'COMMON.WEIGHTS'
6029       include 'COMMON.WEIGHTDER'
6030       logical lprn
6031       integer itor2typ(3) /10,9,20/
6032 C Set lprn=.true. for debugging
6033       lprn=.false.
6034 c      lprn=.true.
6035       etors=0.0D0
6036       do i=1,ntyp
6037         do j=1,ntyp
6038           do k=0,3
6039             do l=0,2*maxterm
6040               etor_temp(l,k,j,i)=0.0d0
6041             enddo
6042           enddo
6043         enddo
6044       enddo
6045       do i=iphi_start,iphi_end
6046         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6047         itori=itortyp(itype(i-2))
6048         itori1=itortyp(itype(i-1))
6049         weitori=weitor(0,itori,itori1)
6050         phii=phi(i)
6051         gloci=0.0D0
6052         etori=0.0d0
6053 C Regular cosine and sine terms
6054         do j=1,nterm(itori,itori1)
6055           v1ij=v1(j,itori,itori1)
6056           v2ij=v2(j,itori,itori1)
6057           cosphi=dcos(j*phii)
6058           sinphi=dsin(j*phii)
6059           etori=etori+v1ij*cosphi+v2ij*sinphi
6060           etor_temp(j,0,itori,itori1)=etor_temp(j,0,itori,itori1)+
6061      &      cosphi*ww(13)
6062           etor_temp(nterm(itori,itori1)+j,0,itori,itori1)=
6063      &      etor_temp(nterm(itori,itori1)+j,0,itori,itori1)+
6064      &      sinphi*ww(13)
6065           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6066         enddo
6067 C Lorentz terms
6068 C                         v1
6069 C  E = SUM ----------------------------------- - v1
6070 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6071 C
6072         cosphi=dcos(0.5d0*phii)
6073         sinphi=dsin(0.5d0*phii)
6074         do j=1,nlor(itori,itori1)
6075           vl1ij=vlor1(j,itori,itori1)
6076           vl2ij=vlor2(j,itori,itori1)
6077           vl3ij=vlor3(j,itori,itori1)
6078           pom=vl2ij*cosphi+vl3ij*sinphi
6079           pom1=1.0d0/(pom*pom+1.0d0)
6080           etori=etori+vl1ij*pom1
6081           pom=-pom*pom1*pom1
6082           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6083         enddo
6084 C Subtract the constant term
6085         etors=etors+(etori-v0(itori,itori1))*weitori
6086         etor_temp(0,0,itori,itori1)=etor_temp(0,0,itori,itori1)+
6087      &    (etori-v0(itori,itori1))*ww(13)
6088
6089         if (lprn) then
6090         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
6091      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6092      &  weitori,v0(itori,itori1)*weitori,(v1(j,itori,itori1)*weitori,
6093      &  j=1,6),(v2(j,itori,itori1)*weitori,j=1,6)
6094         write (iout,*) "typ",itori,itor2typ(itori),itori1,
6095      &    itor2typ(itori1)," etor_temp",
6096      &    etor_temp(0,0,itori,itori1)
6097         call flush(iout)
6098         endif
6099         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6100 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6101  1215   continue
6102       enddo
6103 ! 6/20/98 - dihedral angle constraints
6104       edihcnstr=0.0d0
6105       do i=1,ndih_constr
6106         print *,"i",i
6107         itori=idih_constr(i)
6108         phii=phi(itori)
6109         difi=phii-phi0(i)
6110         if (difi.gt.drange(i)) then
6111           difi=difi-drange(i)
6112           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6113           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6114         else if (difi.lt.-drange(i)) then
6115           difi=difi+drange(i)
6116           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6117           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6118         endif
6119 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6120 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6121       enddo
6122 !      write (iout,*) 'edihcnstr',edihcnstr
6123       return
6124       end
6125 c----------------------------------------------------------------------------
6126       subroutine etor_d(etors_d)
6127 C 6/23/01 Compute double torsional energy
6128       implicit real*8 (a-h,o-z)
6129       include 'DIMENSIONS'
6130       include 'DIMENSIONS.ZSCOPT'
6131       include 'COMMON.VAR'
6132       include 'COMMON.GEO'
6133       include 'COMMON.LOCAL'
6134       include 'COMMON.TORSION'
6135       include 'COMMON.INTERACT'
6136       include 'COMMON.DERIV'
6137       include 'COMMON.CHAIN'
6138       include 'COMMON.NAMES'
6139       include 'COMMON.IOUNITS'
6140       include 'COMMON.FFIELD'
6141       include 'COMMON.TORCNSTR'
6142       logical lprn
6143 C Set lprn=.true. for debugging
6144       lprn=.false.
6145 c     lprn=.true.
6146       etors_d=0.0D0
6147       do i=iphi_start,iphi_end-1
6148         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6149      &     goto 1215
6150         itori=itortyp(itype(i-2))
6151         itori1=itortyp(itype(i-1))
6152         itori2=itortyp(itype(i))
6153         phii=phi(i)
6154         phii1=phi(i+1)
6155         gloci1=0.0D0
6156         gloci2=0.0D0
6157 C Regular cosine and sine terms
6158         do j=1,ntermd_1(itori,itori1,itori2)
6159           v1cij=v1c(1,j,itori,itori1,itori2)
6160           v1sij=v1s(1,j,itori,itori1,itori2)
6161           v2cij=v1c(2,j,itori,itori1,itori2)
6162           v2sij=v1s(2,j,itori,itori1,itori2)
6163           cosphi1=dcos(j*phii)
6164           sinphi1=dsin(j*phii)
6165           cosphi2=dcos(j*phii1)
6166           sinphi2=dsin(j*phii1)
6167           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6168      &     v2cij*cosphi2+v2sij*sinphi2
6169           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6170           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6171         enddo
6172         do k=2,ntermd_2(itori,itori1,itori2)
6173           do l=1,k-1
6174             v1cdij = v2c(k,l,itori,itori1,itori2)
6175             v2cdij = v2c(l,k,itori,itori1,itori2)
6176             v1sdij = v2s(k,l,itori,itori1,itori2)
6177             v2sdij = v2s(l,k,itori,itori1,itori2)
6178             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6179             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6180             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6181             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6182             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6183      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6184             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6185      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6186             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6187      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6188           enddo
6189         enddo
6190         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6191         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6192  1215   continue
6193       enddo
6194       return
6195       end
6196 #endif
6197 c------------------------------------------------------------------------------
6198       subroutine eback_sc_corr(esccor)
6199 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6200 c        conformational states; temporarily implemented as differences
6201 c        between UNRES torsional potentials (dependent on three types of
6202 c        residues) and the torsional potentials dependent on all 20 types
6203 c        of residues computed from AM1 energy surfaces of terminally-blocked
6204 c        amino-acid residues.
6205       implicit real*8 (a-h,o-z)
6206       include 'DIMENSIONS'
6207       include 'DIMENSIONS.ZSCOPT'
6208       include 'COMMON.VAR'
6209       include 'COMMON.GEO'
6210       include 'COMMON.LOCAL'
6211       include 'COMMON.TORSION'
6212       include 'COMMON.SCCOR'
6213       include 'COMMON.INTERACT'
6214       include 'COMMON.DERIV'
6215       include 'COMMON.CHAIN'
6216       include 'COMMON.NAMES'
6217       include 'COMMON.IOUNITS'
6218       include 'COMMON.FFIELD'
6219       include 'COMMON.CONTROL'
6220       include 'COMMON.WEIGHTS'
6221       include 'COMMON.WEIGHTDER'
6222       logical lprn
6223 C Set lprn=.true. for debugging
6224       lprn=.false.
6225 c      lprn=.true.
6226 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
6227       esccor=0.0D0
6228       do i=itau_start,itau_end
6229 c        write (iout,*) "i",i," itype",itype(i-2),itype(i-1)
6230 c        call flush(iout)
6231         esccor_ii=0.0D0
6232         isccori=isccortyp(itype(i-2))
6233         isccori1=isccortyp(itype(i-1))
6234         phii=phi(i)
6235 c        write (iout,*) "i",i," isccori",isccori," isccori1",isccori1,
6236 c     &    " phii",phii
6237 c        call flush(iout)
6238 cccc  Added 9 May 2012
6239 cc Tauangle is torsional engle depending on the value of first digit
6240 c(see comment below)
6241 cc Omicron is flat angle depending on the value of first digit
6242 c(see comment below)
6243
6244         do intertyp=1,3 !intertyp
6245 cc Added 09 May 2012 (Adasko)
6246 cc  Intertyp means interaction type of backbone mainchain correlation:
6247 c   1 = SC...Ca...Ca...Ca
6248 c   2 = Ca...Ca...Ca...SC
6249 c   3 = SC...Ca...Ca...SCi
6250         gloci=0.0D0
6251         weitori=weitor(intertyp,isccori,isccori1)
6252         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6253      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6254      &      (itype(i-1).eq.21)))
6255      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6256      &     .or.(itype(i-2).eq.21)))
6257      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6258      &      (itype(i-1).eq.21)))) cycle
6259         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6260         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6261      & cycle
6262         esccori=0.0d0
6263         do j=1,nterm_sccor(isccori,isccori1)
6264           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6265           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6266           cosphi=dcos(j*tauangle(intertyp,i))
6267           sinphi=dsin(j*tauangle(intertyp,i))
6268           esccori=esccori+v1ij*cosphi+v2ij*sinphi
6269           etor_temp(j,intertyp,isccori,isccori1)=
6270      &    etor_temp(j,intertyp,isccori,isccori1)+cosphi*ww(19)
6271           etor_temp(nterm_sccor(isccori,isccori1)+j,intertyp,
6272      &      isccori,isccori1)=etor_temp(nterm_sccor(isccori,isccori1)+j,
6273      &      intertyp,isccori,isccori1)+sinphi*ww(19)
6274           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6275         enddo
6276         esccor=esccor+weitori*esccori
6277         etor_temp(0,intertyp,isccori,isccori1)=
6278      &    etor_temp(0,intertyp,isccori,isccori1)+esccori*ww(19)
6279         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6280 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6281 c     &gloc_sc(intertyp,i-3,icg)
6282         if (lprn) then
6283         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6284      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6285      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6286      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6287         write (iout,*) "esccori",esccori
6288         call flush(iout)
6289         endif
6290         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6291        enddo !intertyp
6292       enddo
6293       return
6294       end
6295 c------------------------------------------------------------------------------
6296       subroutine multibody(ecorr)
6297 C This subroutine calculates multi-body contributions to energy following
6298 C the idea of Skolnick et al. If side chains I and J make a contact and
6299 C at the same time side chains I+1 and J+1 make a contact, an extra
6300 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6301       implicit real*8 (a-h,o-z)
6302       include 'DIMENSIONS'
6303       include 'DIMENSIONS.ZSCOPT'
6304       include 'COMMON.IOUNITS'
6305       include 'COMMON.DERIV'
6306       include 'COMMON.INTERACT'
6307       include 'COMMON.CONTACTS'
6308       double precision gx(3),gx1(3)
6309       logical lprn
6310
6311 C Set lprn=.true. for debugging
6312       lprn=.false.
6313
6314       if (lprn) then
6315         write (iout,'(a)') 'Contact function values:'
6316         do i=nnt,nct-2
6317           write (iout,'(i2,20(1x,i2,f10.5))')
6318      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6319         enddo
6320       endif
6321       ecorr=0.0D0
6322       do i=nnt,nct
6323         do j=1,3
6324           gradcorr(j,i)=0.0D0
6325           gradxorr(j,i)=0.0D0
6326         enddo
6327       enddo
6328       do i=nnt,nct-2
6329
6330         DO ISHIFT = 3,4
6331
6332         i1=i+ishift
6333         num_conti=num_cont(i)
6334         num_conti1=num_cont(i1)
6335         do jj=1,num_conti
6336           j=jcont(jj,i)
6337           do kk=1,num_conti1
6338             j1=jcont(kk,i1)
6339             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6340 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6341 cd   &                   ' ishift=',ishift
6342 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6343 C The system gains extra energy.
6344               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6345             endif   ! j1==j+-ishift
6346           enddo     ! kk
6347         enddo       ! jj
6348
6349         ENDDO ! ISHIFT
6350
6351       enddo         ! i
6352       return
6353       end
6354 c------------------------------------------------------------------------------
6355       double precision function esccorr(i,j,k,l,jj,kk)
6356       implicit real*8 (a-h,o-z)
6357       include 'DIMENSIONS'
6358       include 'DIMENSIONS.ZSCOPT'
6359       include 'COMMON.IOUNITS'
6360       include 'COMMON.DERIV'
6361       include 'COMMON.INTERACT'
6362       include 'COMMON.CONTACTS'
6363       double precision gx(3),gx1(3)
6364       logical lprn
6365       lprn=.false.
6366       eij=facont(jj,i)
6367       ekl=facont(kk,k)
6368 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6369 C Calculate the multi-body contribution to energy.
6370 C Calculate multi-body contributions to the gradient.
6371 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6372 cd   & k,l,(gacont(m,kk,k),m=1,3)
6373       do m=1,3
6374         gx(m) =ekl*gacont(m,jj,i)
6375         gx1(m)=eij*gacont(m,kk,k)
6376         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6377         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6378         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6379         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6380       enddo
6381       do m=i,j-1
6382         do ll=1,3
6383           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6384         enddo
6385       enddo
6386       do m=k,l-1
6387         do ll=1,3
6388           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6389         enddo
6390       enddo
6391       esccorr=-eij*ekl
6392       return
6393       end
6394 c------------------------------------------------------------------------------
6395 #ifdef MPL
6396       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6397       implicit real*8 (a-h,o-z)
6398       include 'DIMENSIONS'
6399       integer dimen1,dimen2,atom,indx
6400       double precision buffer(dimen1,dimen2)
6401       double precision zapas
6402       common /contacts_hb/ zapas(3,20,maxres,7),
6403      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6404      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6405       num_kont=num_cont_hb(atom)
6406       do i=1,num_kont
6407         do k=1,7
6408           do j=1,3
6409             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6410           enddo ! j
6411         enddo ! k
6412         buffer(i,indx+22)=facont_hb(i,atom)
6413         buffer(i,indx+23)=ees0p(i,atom)
6414         buffer(i,indx+24)=ees0m(i,atom)
6415         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6416       enddo ! i
6417       buffer(1,indx+26)=dfloat(num_kont)
6418       return
6419       end
6420 c------------------------------------------------------------------------------
6421       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6422       implicit real*8 (a-h,o-z)
6423       include 'DIMENSIONS'
6424       integer dimen1,dimen2,atom,indx
6425       double precision buffer(dimen1,dimen2)
6426       double precision zapas
6427       common /contacts_hb/ zapas(3,20,maxres,7),
6428      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6429      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6430       num_kont=buffer(1,indx+26)
6431       num_kont_old=num_cont_hb(atom)
6432       num_cont_hb(atom)=num_kont+num_kont_old
6433       do i=1,num_kont
6434         ii=i+num_kont_old
6435         do k=1,7
6436           do j=1,3
6437             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6438           enddo ! j
6439         enddo ! k
6440         facont_hb(ii,atom)=buffer(i,indx+22)
6441         ees0p(ii,atom)=buffer(i,indx+23)
6442         ees0m(ii,atom)=buffer(i,indx+24)
6443         jcont_hb(ii,atom)=buffer(i,indx+25)
6444       enddo ! i
6445       return
6446       end
6447 c------------------------------------------------------------------------------
6448 #endif
6449       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6450 C This subroutine calculates multi-body contributions to hydrogen-bonding
6451       implicit real*8 (a-h,o-z)
6452       include 'DIMENSIONS'
6453       include 'DIMENSIONS.ZSCOPT'
6454       include 'COMMON.IOUNITS'
6455 #ifdef MPL
6456       include 'COMMON.INFO'
6457 #endif
6458       include 'COMMON.FFIELD'
6459       include 'COMMON.DERIV'
6460       include 'COMMON.INTERACT'
6461       include 'COMMON.CONTACTS'
6462 #ifdef MPL
6463       parameter (max_cont=maxconts)
6464       parameter (max_dim=2*(8*3+2))
6465       parameter (msglen1=max_cont*max_dim*4)
6466       parameter (msglen2=2*msglen1)
6467       integer source,CorrelType,CorrelID,Error
6468       double precision buffer(max_cont,max_dim)
6469 #endif
6470       double precision gx(3),gx1(3)
6471       logical lprn,ldone
6472
6473 C Set lprn=.true. for debugging
6474       lprn=.false.
6475 #ifdef MPL
6476       n_corr=0
6477       n_corr1=0
6478       if (fgProcs.le.1) goto 30
6479       if (lprn) then
6480         write (iout,'(a)') 'Contact function values:'
6481         do i=nnt,nct-2
6482           write (iout,'(2i3,50(1x,i2,f5.2))')
6483      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6484      &    j=1,num_cont_hb(i))
6485         enddo
6486       endif
6487 C Caution! Following code assumes that electrostatic interactions concerning
6488 C a given atom are split among at most two processors!
6489       CorrelType=477
6490       CorrelID=MyID+1
6491       ldone=.false.
6492       do i=1,max_cont
6493         do j=1,max_dim
6494           buffer(i,j)=0.0D0
6495         enddo
6496       enddo
6497       mm=mod(MyRank,2)
6498 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6499       if (mm) 20,20,10
6500    10 continue
6501 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6502       if (MyRank.gt.0) then
6503 C Send correlation contributions to the preceding processor
6504         msglen=msglen1
6505         nn=num_cont_hb(iatel_s)
6506         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6507 cd      write (iout,*) 'The BUFFER array:'
6508 cd      do i=1,nn
6509 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6510 cd      enddo
6511         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6512           msglen=msglen2
6513             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6514 C Clear the contacts of the atom passed to the neighboring processor
6515         nn=num_cont_hb(iatel_s+1)
6516 cd      do i=1,nn
6517 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6518 cd      enddo
6519             num_cont_hb(iatel_s)=0
6520         endif
6521 cd      write (iout,*) 'Processor ',MyID,MyRank,
6522 cd   & ' is sending correlation contribution to processor',MyID-1,
6523 cd   & ' msglen=',msglen
6524 cd      write (*,*) 'Processor ',MyID,MyRank,
6525 cd   & ' is sending correlation contribution to processor',MyID-1,
6526 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6527         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6528 cd      write (iout,*) 'Processor ',MyID,
6529 cd   & ' has sent correlation contribution to processor',MyID-1,
6530 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6531 cd      write (*,*) 'Processor ',MyID,
6532 cd   & ' has sent correlation contribution to processor',MyID-1,
6533 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6534         msglen=msglen1
6535       endif ! (MyRank.gt.0)
6536       if (ldone) goto 30
6537       ldone=.true.
6538    20 continue
6539 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6540       if (MyRank.lt.fgProcs-1) then
6541 C Receive correlation contributions from the next processor
6542         msglen=msglen1
6543         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6544 cd      write (iout,*) 'Processor',MyID,
6545 cd   & ' is receiving correlation contribution from processor',MyID+1,
6546 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6547 cd      write (*,*) 'Processor',MyID,
6548 cd   & ' is receiving correlation contribution from processor',MyID+1,
6549 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6550         nbytes=-1
6551         do while (nbytes.le.0)
6552           call mp_probe(MyID+1,CorrelType,nbytes)
6553         enddo
6554 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6555         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6556 cd      write (iout,*) 'Processor',MyID,
6557 cd   & ' has received correlation contribution from processor',MyID+1,
6558 cd   & ' msglen=',msglen,' nbytes=',nbytes
6559 cd      write (iout,*) 'The received BUFFER array:'
6560 cd      do i=1,max_cont
6561 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6562 cd      enddo
6563         if (msglen.eq.msglen1) then
6564           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6565         else if (msglen.eq.msglen2)  then
6566           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6567           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6568         else
6569           write (iout,*)
6570      & 'ERROR!!!! message length changed while processing correlations.'
6571           write (*,*)
6572      & 'ERROR!!!! message length changed while processing correlations.'
6573           call mp_stopall(Error)
6574         endif ! msglen.eq.msglen1
6575       endif ! MyRank.lt.fgProcs-1
6576       if (ldone) goto 30
6577       ldone=.true.
6578       goto 10
6579    30 continue
6580 #endif
6581       if (lprn) then
6582         write (iout,'(a)') 'Contact function values:'
6583         do i=nnt,nct-2
6584           write (iout,'(2i3,50(1x,i2,f5.2))')
6585      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6586      &    j=1,num_cont_hb(i))
6587         enddo
6588       endif
6589       ecorr=0.0D0
6590 C Remove the loop below after debugging !!!
6591       do i=nnt,nct
6592         do j=1,3
6593           gradcorr(j,i)=0.0D0
6594           gradxorr(j,i)=0.0D0
6595         enddo
6596       enddo
6597 C Calculate the local-electrostatic correlation terms
6598       do i=iatel_s,iatel_e+1
6599         i1=i+1
6600         num_conti=num_cont_hb(i)
6601         num_conti1=num_cont_hb(i+1)
6602         do jj=1,num_conti
6603           j=jcont_hb(jj,i)
6604           do kk=1,num_conti1
6605             j1=jcont_hb(kk,i1)
6606 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6607 c     &         ' jj=',jj,' kk=',kk
6608             if (j1.eq.j+1 .or. j1.eq.j-1) then
6609 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6610 C The system gains extra energy.
6611               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6612               n_corr=n_corr+1
6613             else if (j1.eq.j) then
6614 C Contacts I-J and I-(J+1) occur simultaneously.
6615 C The system loses extra energy.
6616 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6617             endif
6618           enddo ! kk
6619           do kk=1,num_conti
6620             j1=jcont_hb(kk,i)
6621 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6622 c    &         ' jj=',jj,' kk=',kk
6623             if (j1.eq.j+1) then
6624 C Contacts I-J and (I+1)-J occur simultaneously.
6625 C The system loses extra energy.
6626 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6627             endif ! j1==j+1
6628           enddo ! kk
6629         enddo ! jj
6630       enddo ! i
6631       return
6632       end
6633 c------------------------------------------------------------------------------
6634       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6635      &  n_corr1)
6636 C This subroutine calculates multi-body contributions to hydrogen-bonding
6637       implicit real*8 (a-h,o-z)
6638       include 'DIMENSIONS'
6639       include 'DIMENSIONS.ZSCOPT'
6640       include 'COMMON.IOUNITS'
6641 #ifdef MPL
6642       include 'COMMON.INFO'
6643 #endif
6644       include 'COMMON.FFIELD'
6645       include 'COMMON.DERIV'
6646       include 'COMMON.INTERACT'
6647       include 'COMMON.CONTACTS'
6648 #ifdef MPL
6649       parameter (max_cont=maxconts)
6650       parameter (max_dim=2*(8*3+2))
6651       parameter (msglen1=max_cont*max_dim*4)
6652       parameter (msglen2=2*msglen1)
6653       integer source,CorrelType,CorrelID,Error
6654       double precision buffer(max_cont,max_dim)
6655 #endif
6656       double precision gx(3),gx1(3)
6657       logical lprn,ldone
6658
6659 C Set lprn=.true. for debugging
6660       lprn=.false.
6661       eturn6=0.0d0
6662 #ifdef MPL
6663       n_corr=0
6664       n_corr1=0
6665       if (fgProcs.le.1) goto 30
6666       if (lprn) then
6667         write (iout,'(a)') 'Contact function values:'
6668         do i=nnt,nct-2
6669           write (iout,'(2i3,50(1x,i2,f5.2))')
6670      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6671      &    j=1,num_cont_hb(i))
6672         enddo
6673       endif
6674 C Caution! Following code assumes that electrostatic interactions concerning
6675 C a given atom are split among at most two processors!
6676       CorrelType=477
6677       CorrelID=MyID+1
6678       ldone=.false.
6679       do i=1,max_cont
6680         do j=1,max_dim
6681           buffer(i,j)=0.0D0
6682         enddo
6683       enddo
6684       mm=mod(MyRank,2)
6685 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6686       if (mm) 20,20,10
6687    10 continue
6688 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6689       if (MyRank.gt.0) then
6690 C Send correlation contributions to the preceding processor
6691         msglen=msglen1
6692         nn=num_cont_hb(iatel_s)
6693         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6694 cd      write (iout,*) 'The BUFFER array:'
6695 cd      do i=1,nn
6696 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6697 cd      enddo
6698         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6699           msglen=msglen2
6700             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6701 C Clear the contacts of the atom passed to the neighboring processor
6702         nn=num_cont_hb(iatel_s+1)
6703 cd      do i=1,nn
6704 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6705 cd      enddo
6706             num_cont_hb(iatel_s)=0
6707         endif
6708 cd      write (iout,*) 'Processor ',MyID,MyRank,
6709 cd   & ' is sending correlation contribution to processor',MyID-1,
6710 cd   & ' msglen=',msglen
6711 cd      write (*,*) 'Processor ',MyID,MyRank,
6712 cd   & ' is sending correlation contribution to processor',MyID-1,
6713 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6714         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6715 cd      write (iout,*) 'Processor ',MyID,
6716 cd   & ' has sent correlation contribution to processor',MyID-1,
6717 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6718 cd      write (*,*) 'Processor ',MyID,
6719 cd   & ' has sent correlation contribution to processor',MyID-1,
6720 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6721         msglen=msglen1
6722       endif ! (MyRank.gt.0)
6723       if (ldone) goto 30
6724       ldone=.true.
6725    20 continue
6726 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6727       if (MyRank.lt.fgProcs-1) then
6728 C Receive correlation contributions from the next processor
6729         msglen=msglen1
6730         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6731 cd      write (iout,*) 'Processor',MyID,
6732 cd   & ' is receiving correlation contribution from processor',MyID+1,
6733 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6734 cd      write (*,*) 'Processor',MyID,
6735 cd   & ' is receiving correlation contribution from processor',MyID+1,
6736 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6737         nbytes=-1
6738         do while (nbytes.le.0)
6739           call mp_probe(MyID+1,CorrelType,nbytes)
6740         enddo
6741 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6742         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6743 cd      write (iout,*) 'Processor',MyID,
6744 cd   & ' has received correlation contribution from processor',MyID+1,
6745 cd   & ' msglen=',msglen,' nbytes=',nbytes
6746 cd      write (iout,*) 'The received BUFFER array:'
6747 cd      do i=1,max_cont
6748 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6749 cd      enddo
6750         if (msglen.eq.msglen1) then
6751           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6752         else if (msglen.eq.msglen2)  then
6753           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6754           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6755         else
6756           write (iout,*)
6757      & 'ERROR!!!! message length changed while processing correlations.'
6758           write (*,*)
6759      & 'ERROR!!!! message length changed while processing correlations.'
6760           call mp_stopall(Error)
6761         endif ! msglen.eq.msglen1
6762       endif ! MyRank.lt.fgProcs-1
6763       if (ldone) goto 30
6764       ldone=.true.
6765       goto 10
6766    30 continue
6767 #endif
6768       if (lprn) then
6769         write (iout,'(a)') 'Contact function values:'
6770         do i=nnt,nct-2
6771           write (iout,'(2i3,50(1x,i2,f5.2))')
6772      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6773      &    j=1,num_cont_hb(i))
6774         enddo
6775       endif
6776       ecorr=0.0D0
6777       ecorr5=0.0d0
6778       ecorr6=0.0d0
6779 C Remove the loop below after debugging !!!
6780       do i=nnt,nct
6781         do j=1,3
6782           gradcorr(j,i)=0.0D0
6783           gradxorr(j,i)=0.0D0
6784         enddo
6785       enddo
6786 C Calculate the dipole-dipole interaction energies
6787       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6788       do i=iatel_s,iatel_e+1
6789         num_conti=num_cont_hb(i)
6790         do jj=1,num_conti
6791           j=jcont_hb(jj,i)
6792           call dipole(i,j,jj)
6793         enddo
6794       enddo
6795       endif
6796 C Calculate the local-electrostatic correlation terms
6797       do i=iatel_s,iatel_e+1
6798         i1=i+1
6799         num_conti=num_cont_hb(i)
6800         num_conti1=num_cont_hb(i+1)
6801         do jj=1,num_conti
6802           j=jcont_hb(jj,i)
6803           do kk=1,num_conti1
6804             j1=jcont_hb(kk,i1)
6805 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6806 c     &         ' jj=',jj,' kk=',kk
6807             if (j1.eq.j+1 .or. j1.eq.j-1) then
6808 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6809 C The system gains extra energy.
6810               n_corr=n_corr+1
6811               sqd1=dsqrt(d_cont(jj,i))
6812               sqd2=dsqrt(d_cont(kk,i1))
6813               sred_geom = sqd1*sqd2
6814               IF (sred_geom.lt.cutoff_corr) THEN
6815                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6816      &            ekont,fprimcont)
6817 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6818 c     &         ' jj=',jj,' kk=',kk
6819                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6820                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6821                 do l=1,3
6822                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6823                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6824                 enddo
6825                 n_corr1=n_corr1+1
6826 cd               write (iout,*) 'sred_geom=',sred_geom,
6827 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6828                 call calc_eello(i,j,i+1,j1,jj,kk)
6829                 if (wcorr4.gt.0.0d0)
6830      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6831                 if (wcorr5.gt.0.0d0)
6832      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6833 c                print *,"wcorr5",ecorr5
6834 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6835 cd                write(2,*)'ijkl',i,j,i+1,j1
6836                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6837      &               .or. wturn6.eq.0.0d0))then
6838 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6839                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6840 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6841 cd     &            'ecorr6=',ecorr6
6842 cd                write (iout,'(4e15.5)') sred_geom,
6843 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6844 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6845 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6846                 else if (wturn6.gt.0.0d0
6847      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6848 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6849                   eturn6=eturn6+eello_turn6(i,jj,kk)
6850 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6851                 endif
6852               ENDIF
6853 1111          continue
6854             else if (j1.eq.j) then
6855 C Contacts I-J and I-(J+1) occur simultaneously.
6856 C The system loses extra energy.
6857 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6858             endif
6859           enddo ! kk
6860           do kk=1,num_conti
6861             j1=jcont_hb(kk,i)
6862 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6863 c    &         ' jj=',jj,' kk=',kk
6864             if (j1.eq.j+1) then
6865 C Contacts I-J and (I+1)-J occur simultaneously.
6866 C The system loses extra energy.
6867 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6868             endif ! j1==j+1
6869           enddo ! kk
6870         enddo ! jj
6871       enddo ! i
6872       return
6873       end
6874 c------------------------------------------------------------------------------
6875       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6876       implicit real*8 (a-h,o-z)
6877       include 'DIMENSIONS'
6878       include 'DIMENSIONS.ZSCOPT'
6879       include 'COMMON.IOUNITS'
6880       include 'COMMON.DERIV'
6881       include 'COMMON.INTERACT'
6882       include 'COMMON.CONTACTS'
6883       double precision gx(3),gx1(3)
6884       logical lprn
6885       lprn=.false.
6886       eij=facont_hb(jj,i)
6887       ekl=facont_hb(kk,k)
6888       ees0pij=ees0p(jj,i)
6889       ees0pkl=ees0p(kk,k)
6890       ees0mij=ees0m(jj,i)
6891       ees0mkl=ees0m(kk,k)
6892       ekont=eij*ekl
6893       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6894 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6895 C Following 4 lines for diagnostics.
6896 cd    ees0pkl=0.0D0
6897 cd    ees0pij=1.0D0
6898 cd    ees0mkl=0.0D0
6899 cd    ees0mij=1.0D0
6900 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6901 c    &   ' and',k,l
6902 c     write (iout,*)'Contacts have occurred for peptide groups',
6903 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6904 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6905 C Calculate the multi-body contribution to energy.
6906       ecorr=ecorr+ekont*ees
6907       if (calc_grad) then
6908 C Calculate multi-body contributions to the gradient.
6909       do ll=1,3
6910         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6911         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6912      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6913      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6914         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6915      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6916      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6917         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6918         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6919      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6920      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6921         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6922      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6923      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6924       enddo
6925       do m=i+1,j-1
6926         do ll=1,3
6927           gradcorr(ll,m)=gradcorr(ll,m)+
6928      &     ees*ekl*gacont_hbr(ll,jj,i)-
6929      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6930      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6931         enddo
6932       enddo
6933       do m=k+1,l-1
6934         do ll=1,3
6935           gradcorr(ll,m)=gradcorr(ll,m)+
6936      &     ees*eij*gacont_hbr(ll,kk,k)-
6937      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6938      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6939         enddo
6940       enddo
6941       endif
6942       ehbcorr=ekont*ees
6943       return
6944       end
6945 C---------------------------------------------------------------------------
6946       subroutine dipole(i,j,jj)
6947       implicit real*8 (a-h,o-z)
6948       include 'DIMENSIONS'
6949       include 'DIMENSIONS.ZSCOPT'
6950       include 'COMMON.IOUNITS'
6951       include 'COMMON.CHAIN'
6952       include 'COMMON.FFIELD'
6953       include 'COMMON.DERIV'
6954       include 'COMMON.INTERACT'
6955       include 'COMMON.CONTACTS'
6956       include 'COMMON.TORSION'
6957       include 'COMMON.VAR'
6958       include 'COMMON.GEO'
6959       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6960      &  auxmat(2,2)
6961       iti1 = itortyp(itype(i+1))
6962       if (j.lt.nres-1) then
6963         itj1 = itortyp(itype(j+1))
6964       else
6965         itj1=ntortyp+1
6966       endif
6967       do iii=1,2
6968         dipi(iii,1)=Ub2(iii,i)
6969         dipderi(iii)=Ub2der(iii,i)
6970         dipi(iii,2)=b1(iii,iti1)
6971         dipj(iii,1)=Ub2(iii,j)
6972         dipderj(iii)=Ub2der(iii,j)
6973         dipj(iii,2)=b1(iii,itj1)
6974       enddo
6975       kkk=0
6976       do iii=1,2
6977         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6978         do jjj=1,2
6979           kkk=kkk+1
6980           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6981         enddo
6982       enddo
6983       if (.not.calc_grad) return
6984       do kkk=1,5
6985         do lll=1,3
6986           mmm=0
6987           do iii=1,2
6988             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6989      &        auxvec(1))
6990             do jjj=1,2
6991               mmm=mmm+1
6992               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6993             enddo
6994           enddo
6995         enddo
6996       enddo
6997       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6998       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6999       do iii=1,2
7000         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7001       enddo
7002       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7003       do iii=1,2
7004         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7005       enddo
7006       return
7007       end
7008 C---------------------------------------------------------------------------
7009       subroutine calc_eello(i,j,k,l,jj,kk)
7010 C
7011 C This subroutine computes matrices and vectors needed to calculate
7012 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7013 C
7014       implicit real*8 (a-h,o-z)
7015       include 'DIMENSIONS'
7016       include 'DIMENSIONS.ZSCOPT'
7017       include 'COMMON.IOUNITS'
7018       include 'COMMON.CHAIN'
7019       include 'COMMON.DERIV'
7020       include 'COMMON.INTERACT'
7021       include 'COMMON.CONTACTS'
7022       include 'COMMON.TORSION'
7023       include 'COMMON.VAR'
7024       include 'COMMON.GEO'
7025       include 'COMMON.FFIELD'
7026       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7027      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7028       logical lprn
7029       common /kutas/ lprn
7030 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7031 cd     & ' jj=',jj,' kk=',kk
7032 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7033       do iii=1,2
7034         do jjj=1,2
7035           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7036           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7037         enddo
7038       enddo
7039       call transpose2(aa1(1,1),aa1t(1,1))
7040       call transpose2(aa2(1,1),aa2t(1,1))
7041       do kkk=1,5
7042         do lll=1,3
7043           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7044      &      aa1tder(1,1,lll,kkk))
7045           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7046      &      aa2tder(1,1,lll,kkk))
7047         enddo
7048       enddo
7049       if (l.eq.j+1) then
7050 C parallel orientation of the two CA-CA-CA frames.
7051         if (i.gt.1) then
7052           iti=itortyp(itype(i))
7053         else
7054           iti=ntortyp+1
7055         endif
7056         itk1=itortyp(itype(k+1))
7057         itj=itortyp(itype(j))
7058         if (l.lt.nres-1) then
7059           itl1=itortyp(itype(l+1))
7060         else
7061           itl1=ntortyp+1
7062         endif
7063 C A1 kernel(j+1) A2T
7064 cd        do iii=1,2
7065 cd          write (iout,'(3f10.5,5x,3f10.5)')
7066 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7067 cd        enddo
7068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7069      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7070      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7071 C Following matrices are needed only for 6-th order cumulants
7072         IF (wcorr6.gt.0.0d0) THEN
7073         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7074      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7075      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7077      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7078      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7079      &   ADtEAderx(1,1,1,1,1,1))
7080         lprn=.false.
7081         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7082      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7083      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7084      &   ADtEA1derx(1,1,1,1,1,1))
7085         ENDIF
7086 C End 6-th order cumulants
7087 cd        lprn=.false.
7088 cd        if (lprn) then
7089 cd        write (2,*) 'In calc_eello6'
7090 cd        do iii=1,2
7091 cd          write (2,*) 'iii=',iii
7092 cd          do kkk=1,5
7093 cd            write (2,*) 'kkk=',kkk
7094 cd            do jjj=1,2
7095 cd              write (2,'(3(2f10.5),5x)')
7096 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7097 cd            enddo
7098 cd          enddo
7099 cd        enddo
7100 cd        endif
7101         call transpose2(EUgder(1,1,k),auxmat(1,1))
7102         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7103         call transpose2(EUg(1,1,k),auxmat(1,1))
7104         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7105         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7106         do iii=1,2
7107           do kkk=1,5
7108             do lll=1,3
7109               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7110      &          EAEAderx(1,1,lll,kkk,iii,1))
7111             enddo
7112           enddo
7113         enddo
7114 C A1T kernel(i+1) A2
7115         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7116      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7117      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7118 C Following matrices are needed only for 6-th order cumulants
7119         IF (wcorr6.gt.0.0d0) THEN
7120         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7121      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7122      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7123         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7124      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7125      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7126      &   ADtEAderx(1,1,1,1,1,2))
7127         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7128      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7129      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7130      &   ADtEA1derx(1,1,1,1,1,2))
7131         ENDIF
7132 C End 6-th order cumulants
7133         call transpose2(EUgder(1,1,l),auxmat(1,1))
7134         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7135         call transpose2(EUg(1,1,l),auxmat(1,1))
7136         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7137         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7138         do iii=1,2
7139           do kkk=1,5
7140             do lll=1,3
7141               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7142      &          EAEAderx(1,1,lll,kkk,iii,2))
7143             enddo
7144           enddo
7145         enddo
7146 C AEAb1 and AEAb2
7147 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7148 C They are needed only when the fifth- or the sixth-order cumulants are
7149 C indluded.
7150         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7151         call transpose2(AEA(1,1,1),auxmat(1,1))
7152         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7153         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7154         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7155         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7156         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7157         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7158         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7159         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7160         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7161         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7162         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7163         call transpose2(AEA(1,1,2),auxmat(1,1))
7164         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7165         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7166         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7167         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7168         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7169         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7170         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7171         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7172         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7173         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7174         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7175 C Calculate the Cartesian derivatives of the vectors.
7176         do iii=1,2
7177           do kkk=1,5
7178             do lll=1,3
7179               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7180               call matvec2(auxmat(1,1),b1(1,iti),
7181      &          AEAb1derx(1,lll,kkk,iii,1,1))
7182               call matvec2(auxmat(1,1),Ub2(1,i),
7183      &          AEAb2derx(1,lll,kkk,iii,1,1))
7184               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7185      &          AEAb1derx(1,lll,kkk,iii,2,1))
7186               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7187      &          AEAb2derx(1,lll,kkk,iii,2,1))
7188               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7189               call matvec2(auxmat(1,1),b1(1,itj),
7190      &          AEAb1derx(1,lll,kkk,iii,1,2))
7191               call matvec2(auxmat(1,1),Ub2(1,j),
7192      &          AEAb2derx(1,lll,kkk,iii,1,2))
7193               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7194      &          AEAb1derx(1,lll,kkk,iii,2,2))
7195               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7196      &          AEAb2derx(1,lll,kkk,iii,2,2))
7197             enddo
7198           enddo
7199         enddo
7200         ENDIF
7201 C End vectors
7202       else
7203 C Antiparallel orientation of the two CA-CA-CA frames.
7204         if (i.gt.1) then
7205           iti=itortyp(itype(i))
7206         else
7207           iti=ntortyp+1
7208         endif
7209         itk1=itortyp(itype(k+1))
7210         itl=itortyp(itype(l))
7211         itj=itortyp(itype(j))
7212         if (j.lt.nres-1) then
7213           itj1=itortyp(itype(j+1))
7214         else
7215           itj1=ntortyp+1
7216         endif
7217 C A2 kernel(j-1)T A1T
7218         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7219      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7220      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7221 C Following matrices are needed only for 6-th order cumulants
7222         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7223      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7224         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7225      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7226      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7227         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7228      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7229      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7230      &   ADtEAderx(1,1,1,1,1,1))
7231         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7232      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7233      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7234      &   ADtEA1derx(1,1,1,1,1,1))
7235         ENDIF
7236 C End 6-th order cumulants
7237         call transpose2(EUgder(1,1,k),auxmat(1,1))
7238         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7239         call transpose2(EUg(1,1,k),auxmat(1,1))
7240         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7241         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7242         do iii=1,2
7243           do kkk=1,5
7244             do lll=1,3
7245               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7246      &          EAEAderx(1,1,lll,kkk,iii,1))
7247             enddo
7248           enddo
7249         enddo
7250 C A2T kernel(i+1)T A1
7251         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7252      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7253      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7254 C Following matrices are needed only for 6-th order cumulants
7255         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7256      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7257         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7258      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7259      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7260         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7261      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7262      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7263      &   ADtEAderx(1,1,1,1,1,2))
7264         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7265      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7266      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7267      &   ADtEA1derx(1,1,1,1,1,2))
7268         ENDIF
7269 C End 6-th order cumulants
7270         call transpose2(EUgder(1,1,j),auxmat(1,1))
7271         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7272         call transpose2(EUg(1,1,j),auxmat(1,1))
7273         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7274         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7275         do iii=1,2
7276           do kkk=1,5
7277             do lll=1,3
7278               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7279      &          EAEAderx(1,1,lll,kkk,iii,2))
7280             enddo
7281           enddo
7282         enddo
7283 C AEAb1 and AEAb2
7284 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7285 C They are needed only when the fifth- or the sixth-order cumulants are
7286 C indluded.
7287         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7288      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7289         call transpose2(AEA(1,1,1),auxmat(1,1))
7290         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7291         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7292         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7293         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7294         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7295         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7296         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7297         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7298         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7299         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7300         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7301         call transpose2(AEA(1,1,2),auxmat(1,1))
7302         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7303         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7304         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7305         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7306         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7307         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7308         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7309         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7310         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7311         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7312         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7313 C Calculate the Cartesian derivatives of the vectors.
7314         do iii=1,2
7315           do kkk=1,5
7316             do lll=1,3
7317               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7318               call matvec2(auxmat(1,1),b1(1,iti),
7319      &          AEAb1derx(1,lll,kkk,iii,1,1))
7320               call matvec2(auxmat(1,1),Ub2(1,i),
7321      &          AEAb2derx(1,lll,kkk,iii,1,1))
7322               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7323      &          AEAb1derx(1,lll,kkk,iii,2,1))
7324               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7325      &          AEAb2derx(1,lll,kkk,iii,2,1))
7326               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7327               call matvec2(auxmat(1,1),b1(1,itl),
7328      &          AEAb1derx(1,lll,kkk,iii,1,2))
7329               call matvec2(auxmat(1,1),Ub2(1,l),
7330      &          AEAb2derx(1,lll,kkk,iii,1,2))
7331               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7332      &          AEAb1derx(1,lll,kkk,iii,2,2))
7333               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7334      &          AEAb2derx(1,lll,kkk,iii,2,2))
7335             enddo
7336           enddo
7337         enddo
7338         ENDIF
7339 C End vectors
7340       endif
7341       return
7342       end
7343 C---------------------------------------------------------------------------
7344       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7345      &  KK,KKderg,AKA,AKAderg,AKAderx)
7346       implicit none
7347       integer nderg
7348       logical transp
7349       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7350      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7351      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7352       integer iii,kkk,lll
7353       integer jjj,mmm
7354       logical lprn
7355       common /kutas/ lprn
7356       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7357       do iii=1,nderg
7358         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7359      &    AKAderg(1,1,iii))
7360       enddo
7361 cd      if (lprn) write (2,*) 'In kernel'
7362       do kkk=1,5
7363 cd        if (lprn) write (2,*) 'kkk=',kkk
7364         do lll=1,3
7365           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7366      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7367 cd          if (lprn) then
7368 cd            write (2,*) 'lll=',lll
7369 cd            write (2,*) 'iii=1'
7370 cd            do jjj=1,2
7371 cd              write (2,'(3(2f10.5),5x)')
7372 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7373 cd            enddo
7374 cd          endif
7375           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7376      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7377 cd          if (lprn) then
7378 cd            write (2,*) 'lll=',lll
7379 cd            write (2,*) 'iii=2'
7380 cd            do jjj=1,2
7381 cd              write (2,'(3(2f10.5),5x)')
7382 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7383 cd            enddo
7384 cd          endif
7385         enddo
7386       enddo
7387       return
7388       end
7389 C---------------------------------------------------------------------------
7390       double precision function eello4(i,j,k,l,jj,kk)
7391       implicit real*8 (a-h,o-z)
7392       include 'DIMENSIONS'
7393       include 'DIMENSIONS.ZSCOPT'
7394       include 'COMMON.IOUNITS'
7395       include 'COMMON.CHAIN'
7396       include 'COMMON.DERIV'
7397       include 'COMMON.INTERACT'
7398       include 'COMMON.CONTACTS'
7399       include 'COMMON.TORSION'
7400       include 'COMMON.VAR'
7401       include 'COMMON.GEO'
7402       double precision pizda(2,2),ggg1(3),ggg2(3)
7403 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7404 cd        eello4=0.0d0
7405 cd        return
7406 cd      endif
7407 cd      print *,'eello4:',i,j,k,l,jj,kk
7408 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7409 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7410 cold      eij=facont_hb(jj,i)
7411 cold      ekl=facont_hb(kk,k)
7412 cold      ekont=eij*ekl
7413       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7414       if (calc_grad) then
7415 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7416       gcorr_loc(k-1)=gcorr_loc(k-1)
7417      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7418       if (l.eq.j+1) then
7419         gcorr_loc(l-1)=gcorr_loc(l-1)
7420      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7421       else
7422         gcorr_loc(j-1)=gcorr_loc(j-1)
7423      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7424       endif
7425       do iii=1,2
7426         do kkk=1,5
7427           do lll=1,3
7428             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7429      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7430 cd            derx(lll,kkk,iii)=0.0d0
7431           enddo
7432         enddo
7433       enddo
7434 cd      gcorr_loc(l-1)=0.0d0
7435 cd      gcorr_loc(j-1)=0.0d0
7436 cd      gcorr_loc(k-1)=0.0d0
7437 cd      eel4=1.0d0
7438 cd      write (iout,*)'Contacts have occurred for peptide groups',
7439 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7440 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7441       if (j.lt.nres-1) then
7442         j1=j+1
7443         j2=j-1
7444       else
7445         j1=j-1
7446         j2=j-2
7447       endif
7448       if (l.lt.nres-1) then
7449         l1=l+1
7450         l2=l-1
7451       else
7452         l1=l-1
7453         l2=l-2
7454       endif
7455       do ll=1,3
7456 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7457         ggg1(ll)=eel4*g_contij(ll,1)
7458         ggg2(ll)=eel4*g_contij(ll,2)
7459         ghalf=0.5d0*ggg1(ll)
7460 cd        ghalf=0.0d0
7461         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7462         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7463         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7464         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7465 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7466         ghalf=0.5d0*ggg2(ll)
7467 cd        ghalf=0.0d0
7468         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7469         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7470         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7471         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7472       enddo
7473 cd      goto 1112
7474       do m=i+1,j-1
7475         do ll=1,3
7476 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7477           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7478         enddo
7479       enddo
7480       do m=k+1,l-1
7481         do ll=1,3
7482 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7483           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7484         enddo
7485       enddo
7486 1112  continue
7487       do m=i+2,j2
7488         do ll=1,3
7489           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7490         enddo
7491       enddo
7492       do m=k+2,l2
7493         do ll=1,3
7494           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7495         enddo
7496       enddo
7497 cd      do iii=1,nres-3
7498 cd        write (2,*) iii,gcorr_loc(iii)
7499 cd      enddo
7500       endif
7501       eello4=ekont*eel4
7502 cd      write (2,*) 'ekont',ekont
7503 cd      write (iout,*) 'eello4',ekont*eel4
7504       return
7505       end
7506 C---------------------------------------------------------------------------
7507       double precision function eello5(i,j,k,l,jj,kk)
7508       implicit real*8 (a-h,o-z)
7509       include 'DIMENSIONS'
7510       include 'DIMENSIONS.ZSCOPT'
7511       include 'COMMON.IOUNITS'
7512       include 'COMMON.CHAIN'
7513       include 'COMMON.DERIV'
7514       include 'COMMON.INTERACT'
7515       include 'COMMON.CONTACTS'
7516       include 'COMMON.TORSION'
7517       include 'COMMON.VAR'
7518       include 'COMMON.GEO'
7519       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7520       double precision ggg1(3),ggg2(3)
7521 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7522 C                                                                              C
7523 C                            Parallel chains                                   C
7524 C                                                                              C
7525 C          o             o                   o             o                   C
7526 C         /l\           / \             \   / \           / \   /              C
7527 C        /   \         /   \             \ /   \         /   \ /               C
7528 C       j| o |l1       | o |              o| o |         | o |o                C
7529 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7530 C      \i/   \         /   \ /             /   \         /   \                 C
7531 C       o    k1             o                                                  C
7532 C         (I)          (II)                (III)          (IV)                 C
7533 C                                                                              C
7534 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7535 C                                                                              C
7536 C                            Antiparallel chains                               C
7537 C                                                                              C
7538 C          o             o                   o             o                   C
7539 C         /j\           / \             \   / \           / \   /              C
7540 C        /   \         /   \             \ /   \         /   \ /               C
7541 C      j1| o |l        | o |              o| o |         | o |o                C
7542 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7543 C      \i/   \         /   \ /             /   \         /   \                 C
7544 C       o     k1            o                                                  C
7545 C         (I)          (II)                (III)          (IV)                 C
7546 C                                                                              C
7547 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7548 C                                                                              C
7549 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7550 C                                                                              C
7551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7552 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7553 cd        eello5=0.0d0
7554 cd        return
7555 cd      endif
7556 cd      write (iout,*)
7557 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7558 cd     &   ' and',k,l
7559       itk=itortyp(itype(k))
7560       itl=itortyp(itype(l))
7561       itj=itortyp(itype(j))
7562       eello5_1=0.0d0
7563       eello5_2=0.0d0
7564       eello5_3=0.0d0
7565       eello5_4=0.0d0
7566 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7567 cd     &   eel5_3_num,eel5_4_num)
7568       do iii=1,2
7569         do kkk=1,5
7570           do lll=1,3
7571             derx(lll,kkk,iii)=0.0d0
7572           enddo
7573         enddo
7574       enddo
7575 cd      eij=facont_hb(jj,i)
7576 cd      ekl=facont_hb(kk,k)
7577 cd      ekont=eij*ekl
7578 cd      write (iout,*)'Contacts have occurred for peptide groups',
7579 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7580 cd      goto 1111
7581 C Contribution from the graph I.
7582 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7583 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7584       call transpose2(EUg(1,1,k),auxmat(1,1))
7585       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7586       vv(1)=pizda(1,1)-pizda(2,2)
7587       vv(2)=pizda(1,2)+pizda(2,1)
7588       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7589      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7590       if (calc_grad) then
7591 C Explicit gradient in virtual-dihedral angles.
7592       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7593      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7594      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7595       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7596       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7597       vv(1)=pizda(1,1)-pizda(2,2)
7598       vv(2)=pizda(1,2)+pizda(2,1)
7599       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7600      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7601      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7602       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7603       vv(1)=pizda(1,1)-pizda(2,2)
7604       vv(2)=pizda(1,2)+pizda(2,1)
7605       if (l.eq.j+1) then
7606         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7607      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7608      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7609       else
7610         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7611      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7612      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7613       endif
7614 C Cartesian gradient
7615       do iii=1,2
7616         do kkk=1,5
7617           do lll=1,3
7618             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7619      &        pizda(1,1))
7620             vv(1)=pizda(1,1)-pizda(2,2)
7621             vv(2)=pizda(1,2)+pizda(2,1)
7622             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7623      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7624      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7625           enddo
7626         enddo
7627       enddo
7628 c      goto 1112
7629       endif
7630 c1111  continue
7631 C Contribution from graph II
7632       call transpose2(EE(1,1,itk),auxmat(1,1))
7633       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7634       vv(1)=pizda(1,1)+pizda(2,2)
7635       vv(2)=pizda(2,1)-pizda(1,2)
7636       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7637      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7638       if (calc_grad) then
7639 C Explicit gradient in virtual-dihedral angles.
7640       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7641      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7642       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7643       vv(1)=pizda(1,1)+pizda(2,2)
7644       vv(2)=pizda(2,1)-pizda(1,2)
7645       if (l.eq.j+1) then
7646         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7647      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7648      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7649       else
7650         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7651      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7652      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7653       endif
7654 C Cartesian gradient
7655       do iii=1,2
7656         do kkk=1,5
7657           do lll=1,3
7658             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7659      &        pizda(1,1))
7660             vv(1)=pizda(1,1)+pizda(2,2)
7661             vv(2)=pizda(2,1)-pizda(1,2)
7662             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7663      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7664      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7665           enddo
7666         enddo
7667       enddo
7668 cd      goto 1112
7669       endif
7670 cd1111  continue
7671       if (l.eq.j+1) then
7672 cd        goto 1110
7673 C Parallel orientation
7674 C Contribution from graph III
7675         call transpose2(EUg(1,1,l),auxmat(1,1))
7676         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7677         vv(1)=pizda(1,1)-pizda(2,2)
7678         vv(2)=pizda(1,2)+pizda(2,1)
7679         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7680      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7681         if (calc_grad) then
7682 C Explicit gradient in virtual-dihedral angles.
7683         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7684      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7685      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7686         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7687         vv(1)=pizda(1,1)-pizda(2,2)
7688         vv(2)=pizda(1,2)+pizda(2,1)
7689         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7690      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7692         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7693         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7694         vv(1)=pizda(1,1)-pizda(2,2)
7695         vv(2)=pizda(1,2)+pizda(2,1)
7696         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7697      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7698      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7699 C Cartesian gradient
7700         do iii=1,2
7701           do kkk=1,5
7702             do lll=1,3
7703               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7704      &          pizda(1,1))
7705               vv(1)=pizda(1,1)-pizda(2,2)
7706               vv(2)=pizda(1,2)+pizda(2,1)
7707               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7708      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7709      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7710             enddo
7711           enddo
7712         enddo
7713 cd        goto 1112
7714         endif
7715 C Contribution from graph IV
7716 cd1110    continue
7717         call transpose2(EE(1,1,itl),auxmat(1,1))
7718         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7719         vv(1)=pizda(1,1)+pizda(2,2)
7720         vv(2)=pizda(2,1)-pizda(1,2)
7721         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7722      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7723         if (calc_grad) then
7724 C Explicit gradient in virtual-dihedral angles.
7725         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7726      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7727         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7728         vv(1)=pizda(1,1)+pizda(2,2)
7729         vv(2)=pizda(2,1)-pizda(1,2)
7730         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7731      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7732      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7733 C Cartesian gradient
7734         do iii=1,2
7735           do kkk=1,5
7736             do lll=1,3
7737               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7738      &          pizda(1,1))
7739               vv(1)=pizda(1,1)+pizda(2,2)
7740               vv(2)=pizda(2,1)-pizda(1,2)
7741               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7742      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7743      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7744             enddo
7745           enddo
7746         enddo
7747         endif
7748       else
7749 C Antiparallel orientation
7750 C Contribution from graph III
7751 c        goto 1110
7752         call transpose2(EUg(1,1,j),auxmat(1,1))
7753         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7754         vv(1)=pizda(1,1)-pizda(2,2)
7755         vv(2)=pizda(1,2)+pizda(2,1)
7756         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7757      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7758         if (calc_grad) then
7759 C Explicit gradient in virtual-dihedral angles.
7760         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7761      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7762      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7763         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7764         vv(1)=pizda(1,1)-pizda(2,2)
7765         vv(2)=pizda(1,2)+pizda(2,1)
7766         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7767      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7768      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7769         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7770         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7771         vv(1)=pizda(1,1)-pizda(2,2)
7772         vv(2)=pizda(1,2)+pizda(2,1)
7773         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7774      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7775      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7776 C Cartesian gradient
7777         do iii=1,2
7778           do kkk=1,5
7779             do lll=1,3
7780               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7781      &          pizda(1,1))
7782               vv(1)=pizda(1,1)-pizda(2,2)
7783               vv(2)=pizda(1,2)+pizda(2,1)
7784               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7785      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7786      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7787             enddo
7788           enddo
7789         enddo
7790 cd        goto 1112
7791         endif
7792 C Contribution from graph IV
7793 1110    continue
7794         call transpose2(EE(1,1,itj),auxmat(1,1))
7795         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7796         vv(1)=pizda(1,1)+pizda(2,2)
7797         vv(2)=pizda(2,1)-pizda(1,2)
7798         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7799      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7800         if (calc_grad) then
7801 C Explicit gradient in virtual-dihedral angles.
7802         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7803      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7804         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7805         vv(1)=pizda(1,1)+pizda(2,2)
7806         vv(2)=pizda(2,1)-pizda(1,2)
7807         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7808      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7809      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7810 C Cartesian gradient
7811         do iii=1,2
7812           do kkk=1,5
7813             do lll=1,3
7814               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7815      &          pizda(1,1))
7816               vv(1)=pizda(1,1)+pizda(2,2)
7817               vv(2)=pizda(2,1)-pizda(1,2)
7818               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7819      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7820      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7821             enddo
7822           enddo
7823         enddo
7824       endif
7825       endif
7826 1112  continue
7827       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7828 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7829 cd        write (2,*) 'ijkl',i,j,k,l
7830 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7831 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7832 cd      endif
7833 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7834 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7835 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7836 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7837       if (calc_grad) then
7838       if (j.lt.nres-1) then
7839         j1=j+1
7840         j2=j-1
7841       else
7842         j1=j-1
7843         j2=j-2
7844       endif
7845       if (l.lt.nres-1) then
7846         l1=l+1
7847         l2=l-1
7848       else
7849         l1=l-1
7850         l2=l-2
7851       endif
7852 cd      eij=1.0d0
7853 cd      ekl=1.0d0
7854 cd      ekont=1.0d0
7855 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7856       do ll=1,3
7857         ggg1(ll)=eel5*g_contij(ll,1)
7858         ggg2(ll)=eel5*g_contij(ll,2)
7859 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7860         ghalf=0.5d0*ggg1(ll)
7861 cd        ghalf=0.0d0
7862         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7863         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7864         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7865         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7866 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7867         ghalf=0.5d0*ggg2(ll)
7868 cd        ghalf=0.0d0
7869         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7870         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7871         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7872         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7873       enddo
7874 cd      goto 1112
7875       do m=i+1,j-1
7876         do ll=1,3
7877 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7878           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7879         enddo
7880       enddo
7881       do m=k+1,l-1
7882         do ll=1,3
7883 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7884           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7885         enddo
7886       enddo
7887 c1112  continue
7888       do m=i+2,j2
7889         do ll=1,3
7890           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7891         enddo
7892       enddo
7893       do m=k+2,l2
7894         do ll=1,3
7895           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7896         enddo
7897       enddo
7898 cd      do iii=1,nres-3
7899 cd        write (2,*) iii,g_corr5_loc(iii)
7900 cd      enddo
7901       endif
7902       eello5=ekont*eel5
7903 cd      write (2,*) 'ekont',ekont
7904 cd      write (iout,*) 'eello5',ekont*eel5
7905       return
7906       end
7907 c--------------------------------------------------------------------------
7908       double precision function eello6(i,j,k,l,jj,kk)
7909       implicit real*8 (a-h,o-z)
7910       include 'DIMENSIONS'
7911       include 'DIMENSIONS.ZSCOPT'
7912       include 'COMMON.IOUNITS'
7913       include 'COMMON.CHAIN'
7914       include 'COMMON.DERIV'
7915       include 'COMMON.INTERACT'
7916       include 'COMMON.CONTACTS'
7917       include 'COMMON.TORSION'
7918       include 'COMMON.VAR'
7919       include 'COMMON.GEO'
7920       include 'COMMON.FFIELD'
7921       double precision ggg1(3),ggg2(3)
7922 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7923 cd        eello6=0.0d0
7924 cd        return
7925 cd      endif
7926 cd      write (iout,*)
7927 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7928 cd     &   ' and',k,l
7929       eello6_1=0.0d0
7930       eello6_2=0.0d0
7931       eello6_3=0.0d0
7932       eello6_4=0.0d0
7933       eello6_5=0.0d0
7934       eello6_6=0.0d0
7935 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7936 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7937       do iii=1,2
7938         do kkk=1,5
7939           do lll=1,3
7940             derx(lll,kkk,iii)=0.0d0
7941           enddo
7942         enddo
7943       enddo
7944 cd      eij=facont_hb(jj,i)
7945 cd      ekl=facont_hb(kk,k)
7946 cd      ekont=eij*ekl
7947 cd      eij=1.0d0
7948 cd      ekl=1.0d0
7949 cd      ekont=1.0d0
7950       if (l.eq.j+1) then
7951         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7952         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7953         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7954         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7955         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7956         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7957       else
7958         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7959         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7960         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7961         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7962         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7963           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7964         else
7965           eello6_5=0.0d0
7966         endif
7967         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7968       endif
7969 C If turn contributions are considered, they will be handled separately.
7970       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7971 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7972 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7973 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7974 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7975 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7976 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7977 cd      goto 1112
7978       if (calc_grad) then
7979       if (j.lt.nres-1) then
7980         j1=j+1
7981         j2=j-1
7982       else
7983         j1=j-1
7984         j2=j-2
7985       endif
7986       if (l.lt.nres-1) then
7987         l1=l+1
7988         l2=l-1
7989       else
7990         l1=l-1
7991         l2=l-2
7992       endif
7993       do ll=1,3
7994         ggg1(ll)=eel6*g_contij(ll,1)
7995         ggg2(ll)=eel6*g_contij(ll,2)
7996 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7997         ghalf=0.5d0*ggg1(ll)
7998 cd        ghalf=0.0d0
7999         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8000         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8001         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8002         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8003         ghalf=0.5d0*ggg2(ll)
8004 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8005 cd        ghalf=0.0d0
8006         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8007         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8008         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8009         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8010       enddo
8011 cd      goto 1112
8012       do m=i+1,j-1
8013         do ll=1,3
8014 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8015           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8016         enddo
8017       enddo
8018       do m=k+1,l-1
8019         do ll=1,3
8020 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8021           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8022         enddo
8023       enddo
8024 1112  continue
8025       do m=i+2,j2
8026         do ll=1,3
8027           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8028         enddo
8029       enddo
8030       do m=k+2,l2
8031         do ll=1,3
8032           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8033         enddo
8034       enddo
8035 cd      do iii=1,nres-3
8036 cd        write (2,*) iii,g_corr6_loc(iii)
8037 cd      enddo
8038       endif
8039       eello6=ekont*eel6
8040 cd      write (2,*) 'ekont',ekont
8041 cd      write (iout,*) 'eello6',ekont*eel6
8042       return
8043       end
8044 c--------------------------------------------------------------------------
8045       double precision function eello6_graph1(i,j,k,l,imat,swap)
8046       implicit real*8 (a-h,o-z)
8047       include 'DIMENSIONS'
8048       include 'DIMENSIONS.ZSCOPT'
8049       include 'COMMON.IOUNITS'
8050       include 'COMMON.CHAIN'
8051       include 'COMMON.DERIV'
8052       include 'COMMON.INTERACT'
8053       include 'COMMON.CONTACTS'
8054       include 'COMMON.TORSION'
8055       include 'COMMON.VAR'
8056       include 'COMMON.GEO'
8057       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8058       logical swap
8059       logical lprn
8060       common /kutas/ lprn
8061 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8062 C
8063 C      Parallel       Antiparallel
8064 C
8065 C          o             o
8066 C         /l\           /j\
8067 C        /   \         /   \
8068 C       /| o |         | o |\
8069 C     \ j|/k\|  /   \  |/k\|l /
8070 C      \ /   \ /     \ /   \ /
8071 C       o     o       o     o
8072 C       i             i
8073 C
8074 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8075       itk=itortyp(itype(k))
8076       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8077       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8078       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8079       call transpose2(EUgC(1,1,k),auxmat(1,1))
8080       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8081       vv1(1)=pizda1(1,1)-pizda1(2,2)
8082       vv1(2)=pizda1(1,2)+pizda1(2,1)
8083       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8084       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8085       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8086       s5=scalar2(vv(1),Dtobr2(1,i))
8087 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8088       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8089       if (.not. calc_grad) return
8090       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8091      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8092      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8093      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8094      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8095      & +scalar2(vv(1),Dtobr2der(1,i)))
8096       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8097       vv1(1)=pizda1(1,1)-pizda1(2,2)
8098       vv1(2)=pizda1(1,2)+pizda1(2,1)
8099       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8100       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8101       if (l.eq.j+1) then
8102         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8103      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8104      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8105      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8106      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8107       else
8108         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8109      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8110      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8111      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8112      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8113       endif
8114       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8115       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8116       vv1(1)=pizda1(1,1)-pizda1(2,2)
8117       vv1(2)=pizda1(1,2)+pizda1(2,1)
8118       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8119      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8120      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8121      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8122       do iii=1,2
8123         if (swap) then
8124           ind=3-iii
8125         else
8126           ind=iii
8127         endif
8128         do kkk=1,5
8129           do lll=1,3
8130             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8131             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8132             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8133             call transpose2(EUgC(1,1,k),auxmat(1,1))
8134             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8135      &        pizda1(1,1))
8136             vv1(1)=pizda1(1,1)-pizda1(2,2)
8137             vv1(2)=pizda1(1,2)+pizda1(2,1)
8138             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8139             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8140      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8141             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8142      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8143             s5=scalar2(vv(1),Dtobr2(1,i))
8144             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8145           enddo
8146         enddo
8147       enddo
8148       return
8149       end
8150 c----------------------------------------------------------------------------
8151       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8152       implicit real*8 (a-h,o-z)
8153       include 'DIMENSIONS'
8154       include 'DIMENSIONS.ZSCOPT'
8155       include 'COMMON.IOUNITS'
8156       include 'COMMON.CHAIN'
8157       include 'COMMON.DERIV'
8158       include 'COMMON.INTERACT'
8159       include 'COMMON.CONTACTS'
8160       include 'COMMON.TORSION'
8161       include 'COMMON.VAR'
8162       include 'COMMON.GEO'
8163       logical swap
8164       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8165      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8166       logical lprn
8167       common /kutas/ lprn
8168 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8169 C
8170 C      Parallel       Antiparallel
8171 C
8172 C          o             o
8173 C     \   /l\           /j\   /
8174 C      \ /   \         /   \ /
8175 C       o| o |         | o |o
8176 C     \ j|/k\|      \  |/k\|l
8177 C      \ /   \       \ /   \
8178 C       o             o
8179 C       i             i
8180 C
8181 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8182 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8183 C AL 7/4/01 s1 would occur in the sixth-order moment,
8184 C           but not in a cluster cumulant
8185 #ifdef MOMENT
8186       s1=dip(1,jj,i)*dip(1,kk,k)
8187 #endif
8188       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8189       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8190       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8191       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8192       call transpose2(EUg(1,1,k),auxmat(1,1))
8193       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8194       vv(1)=pizda(1,1)-pizda(2,2)
8195       vv(2)=pizda(1,2)+pizda(2,1)
8196       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8197 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8198 #ifdef MOMENT
8199       eello6_graph2=-(s1+s2+s3+s4)
8200 #else
8201       eello6_graph2=-(s2+s3+s4)
8202 #endif
8203 c      eello6_graph2=-s3
8204       if (.not. calc_grad) return
8205 C Derivatives in gamma(i-1)
8206       if (i.gt.1) then
8207 #ifdef MOMENT
8208         s1=dipderg(1,jj,i)*dip(1,kk,k)
8209 #endif
8210         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8211         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8212         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8213         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8214 #ifdef MOMENT
8215         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8216 #else
8217         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8218 #endif
8219 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8220       endif
8221 C Derivatives in gamma(k-1)
8222 #ifdef MOMENT
8223       s1=dip(1,jj,i)*dipderg(1,kk,k)
8224 #endif
8225       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8226       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8227       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8228       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8229       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8230       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8231       vv(1)=pizda(1,1)-pizda(2,2)
8232       vv(2)=pizda(1,2)+pizda(2,1)
8233       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8234 #ifdef MOMENT
8235       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8236 #else
8237       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8238 #endif
8239 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8240 C Derivatives in gamma(j-1) or gamma(l-1)
8241       if (j.gt.1) then
8242 #ifdef MOMENT
8243         s1=dipderg(3,jj,i)*dip(1,kk,k)
8244 #endif
8245         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8246         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8247         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8248         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8249         vv(1)=pizda(1,1)-pizda(2,2)
8250         vv(2)=pizda(1,2)+pizda(2,1)
8251         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8252 #ifdef MOMENT
8253         if (swap) then
8254           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8255         else
8256           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8257         endif
8258 #endif
8259         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8260 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8261       endif
8262 C Derivatives in gamma(l-1) or gamma(j-1)
8263       if (l.gt.1) then
8264 #ifdef MOMENT
8265         s1=dip(1,jj,i)*dipderg(3,kk,k)
8266 #endif
8267         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8268         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8269         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8270         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8271         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8272         vv(1)=pizda(1,1)-pizda(2,2)
8273         vv(2)=pizda(1,2)+pizda(2,1)
8274         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8275 #ifdef MOMENT
8276         if (swap) then
8277           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8278         else
8279           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8280         endif
8281 #endif
8282         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8283 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8284       endif
8285 C Cartesian derivatives.
8286       if (lprn) then
8287         write (2,*) 'In eello6_graph2'
8288         do iii=1,2
8289           write (2,*) 'iii=',iii
8290           do kkk=1,5
8291             write (2,*) 'kkk=',kkk
8292             do jjj=1,2
8293               write (2,'(3(2f10.5),5x)')
8294      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8295             enddo
8296           enddo
8297         enddo
8298       endif
8299       do iii=1,2
8300         do kkk=1,5
8301           do lll=1,3
8302 #ifdef MOMENT
8303             if (iii.eq.1) then
8304               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8305             else
8306               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8307             endif
8308 #endif
8309             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8310      &        auxvec(1))
8311             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8312             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8313      &        auxvec(1))
8314             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8315             call transpose2(EUg(1,1,k),auxmat(1,1))
8316             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8317      &        pizda(1,1))
8318             vv(1)=pizda(1,1)-pizda(2,2)
8319             vv(2)=pizda(1,2)+pizda(2,1)
8320             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8321 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8322 #ifdef MOMENT
8323             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8324 #else
8325             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8326 #endif
8327             if (swap) then
8328               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8329             else
8330               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8331             endif
8332           enddo
8333         enddo
8334       enddo
8335       return
8336       end
8337 c----------------------------------------------------------------------------
8338       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8339       implicit real*8 (a-h,o-z)
8340       include 'DIMENSIONS'
8341       include 'DIMENSIONS.ZSCOPT'
8342       include 'COMMON.IOUNITS'
8343       include 'COMMON.CHAIN'
8344       include 'COMMON.DERIV'
8345       include 'COMMON.INTERACT'
8346       include 'COMMON.CONTACTS'
8347       include 'COMMON.TORSION'
8348       include 'COMMON.VAR'
8349       include 'COMMON.GEO'
8350       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8351       logical swap
8352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8353 C
8354 C      Parallel       Antiparallel
8355 C
8356 C          o             o
8357 C         /l\   /   \   /j\
8358 C        /   \ /     \ /   \
8359 C       /| o |o       o| o |\
8360 C       j|/k\|  /      |/k\|l /
8361 C        /   \ /       /   \ /
8362 C       /     o       /     o
8363 C       i             i
8364 C
8365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8366 C
8367 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8368 C           energy moment and not to the cluster cumulant.
8369       iti=itortyp(itype(i))
8370       if (j.lt.nres-1) then
8371         itj1=itortyp(itype(j+1))
8372       else
8373         itj1=ntortyp+1
8374       endif
8375       itk=itortyp(itype(k))
8376       itk1=itortyp(itype(k+1))
8377       if (l.lt.nres-1) then
8378         itl1=itortyp(itype(l+1))
8379       else
8380         itl1=ntortyp+1
8381       endif
8382 #ifdef MOMENT
8383       s1=dip(4,jj,i)*dip(4,kk,k)
8384 #endif
8385       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8386       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8387       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8388       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8389       call transpose2(EE(1,1,itk),auxmat(1,1))
8390       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8391       vv(1)=pizda(1,1)+pizda(2,2)
8392       vv(2)=pizda(2,1)-pizda(1,2)
8393       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8394 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8395 #ifdef MOMENT
8396       eello6_graph3=-(s1+s2+s3+s4)
8397 #else
8398       eello6_graph3=-(s2+s3+s4)
8399 #endif
8400 c      eello6_graph3=-s4
8401       if (.not. calc_grad) return
8402 C Derivatives in gamma(k-1)
8403       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8404       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8405       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8406       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8407 C Derivatives in gamma(l-1)
8408       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8409       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8410       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8411       vv(1)=pizda(1,1)+pizda(2,2)
8412       vv(2)=pizda(2,1)-pizda(1,2)
8413       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8414       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8415 C Cartesian derivatives.
8416       do iii=1,2
8417         do kkk=1,5
8418           do lll=1,3
8419 #ifdef MOMENT
8420             if (iii.eq.1) then
8421               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8422             else
8423               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8424             endif
8425 #endif
8426             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8427      &        auxvec(1))
8428             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8429             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8430      &        auxvec(1))
8431             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8432             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8433      &        pizda(1,1))
8434             vv(1)=pizda(1,1)+pizda(2,2)
8435             vv(2)=pizda(2,1)-pizda(1,2)
8436             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8437 #ifdef MOMENT
8438             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8439 #else
8440             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8441 #endif
8442             if (swap) then
8443               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8444             else
8445               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8446             endif
8447 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8448           enddo
8449         enddo
8450       enddo
8451       return
8452       end
8453 c----------------------------------------------------------------------------
8454       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8455       implicit real*8 (a-h,o-z)
8456       include 'DIMENSIONS'
8457       include 'DIMENSIONS.ZSCOPT'
8458       include 'COMMON.IOUNITS'
8459       include 'COMMON.CHAIN'
8460       include 'COMMON.DERIV'
8461       include 'COMMON.INTERACT'
8462       include 'COMMON.CONTACTS'
8463       include 'COMMON.TORSION'
8464       include 'COMMON.VAR'
8465       include 'COMMON.GEO'
8466       include 'COMMON.FFIELD'
8467       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8468      & auxvec1(2),auxmat1(2,2)
8469       logical swap
8470 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8471 C
8472 C      Parallel       Antiparallel
8473 C
8474 C          o             o
8475 C         /l\   /   \   /j\
8476 C        /   \ /     \ /   \
8477 C       /| o |o       o| o |\
8478 C     \ j|/k\|      \  |/k\|l
8479 C      \ /   \       \ /   \
8480 C       o     \       o     \
8481 C       i             i
8482 C
8483 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8484 C
8485 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8486 C           energy moment and not to the cluster cumulant.
8487 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8488       iti=itortyp(itype(i))
8489       itj=itortyp(itype(j))
8490       if (j.lt.nres-1) then
8491         itj1=itortyp(itype(j+1))
8492       else
8493         itj1=ntortyp+1
8494       endif
8495       itk=itortyp(itype(k))
8496       if (k.lt.nres-1) then
8497         itk1=itortyp(itype(k+1))
8498       else
8499         itk1=ntortyp+1
8500       endif
8501       itl=itortyp(itype(l))
8502       if (l.lt.nres-1) then
8503         itl1=itortyp(itype(l+1))
8504       else
8505         itl1=ntortyp+1
8506       endif
8507 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8508 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8509 cd     & ' itl',itl,' itl1',itl1
8510 #ifdef MOMENT
8511       if (imat.eq.1) then
8512         s1=dip(3,jj,i)*dip(3,kk,k)
8513       else
8514         s1=dip(2,jj,j)*dip(2,kk,l)
8515       endif
8516 #endif
8517       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8518       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8519       if (j.eq.l+1) then
8520         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8521         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8522       else
8523         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8524         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8525       endif
8526       call transpose2(EUg(1,1,k),auxmat(1,1))
8527       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8528       vv(1)=pizda(1,1)-pizda(2,2)
8529       vv(2)=pizda(2,1)+pizda(1,2)
8530       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8531 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8532 #ifdef MOMENT
8533       eello6_graph4=-(s1+s2+s3+s4)
8534 #else
8535       eello6_graph4=-(s2+s3+s4)
8536 #endif
8537       if (.not. calc_grad) return
8538 C Derivatives in gamma(i-1)
8539       if (i.gt.1) then
8540 #ifdef MOMENT
8541         if (imat.eq.1) then
8542           s1=dipderg(2,jj,i)*dip(3,kk,k)
8543         else
8544           s1=dipderg(4,jj,j)*dip(2,kk,l)
8545         endif
8546 #endif
8547         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8548         if (j.eq.l+1) then
8549           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8550           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8551         else
8552           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8553           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8554         endif
8555         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8556         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8557 cd          write (2,*) 'turn6 derivatives'
8558 #ifdef MOMENT
8559           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8560 #else
8561           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8562 #endif
8563         else
8564 #ifdef MOMENT
8565           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8566 #else
8567           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8568 #endif
8569         endif
8570       endif
8571 C Derivatives in gamma(k-1)
8572 #ifdef MOMENT
8573       if (imat.eq.1) then
8574         s1=dip(3,jj,i)*dipderg(2,kk,k)
8575       else
8576         s1=dip(2,jj,j)*dipderg(4,kk,l)
8577       endif
8578 #endif
8579       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8580       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8581       if (j.eq.l+1) then
8582         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8583         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8584       else
8585         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8586         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8587       endif
8588       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8589       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8590       vv(1)=pizda(1,1)-pizda(2,2)
8591       vv(2)=pizda(2,1)+pizda(1,2)
8592       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8593       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8594 #ifdef MOMENT
8595         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8596 #else
8597         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8598 #endif
8599       else
8600 #ifdef MOMENT
8601         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8602 #else
8603         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8604 #endif
8605       endif
8606 C Derivatives in gamma(j-1) or gamma(l-1)
8607       if (l.eq.j+1 .and. l.gt.1) then
8608         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8609         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8610         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8611         vv(1)=pizda(1,1)-pizda(2,2)
8612         vv(2)=pizda(2,1)+pizda(1,2)
8613         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8614         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8615       else if (j.gt.1) then
8616         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8617         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8618         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8619         vv(1)=pizda(1,1)-pizda(2,2)
8620         vv(2)=pizda(2,1)+pizda(1,2)
8621         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8622         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8623           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8624         else
8625           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8626         endif
8627       endif
8628 C Cartesian derivatives.
8629       do iii=1,2
8630         do kkk=1,5
8631           do lll=1,3
8632 #ifdef MOMENT
8633             if (iii.eq.1) then
8634               if (imat.eq.1) then
8635                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8636               else
8637                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8638               endif
8639             else
8640               if (imat.eq.1) then
8641                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8642               else
8643                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8644               endif
8645             endif
8646 #endif
8647             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8648      &        auxvec(1))
8649             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8650             if (j.eq.l+1) then
8651               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8652      &          b1(1,itj1),auxvec(1))
8653               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8654             else
8655               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8656      &          b1(1,itl1),auxvec(1))
8657               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8658             endif
8659             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8660      &        pizda(1,1))
8661             vv(1)=pizda(1,1)-pizda(2,2)
8662             vv(2)=pizda(2,1)+pizda(1,2)
8663             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8664             if (swap) then
8665               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8666 #ifdef MOMENT
8667                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8668      &             -(s1+s2+s4)
8669 #else
8670                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8671      &             -(s2+s4)
8672 #endif
8673                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8674               else
8675 #ifdef MOMENT
8676                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8677 #else
8678                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8679 #endif
8680                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8681               endif
8682             else
8683 #ifdef MOMENT
8684               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8685 #else
8686               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8687 #endif
8688               if (l.eq.j+1) then
8689                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8690               else
8691                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8692               endif
8693             endif
8694           enddo
8695         enddo
8696       enddo
8697       return
8698       end
8699 c----------------------------------------------------------------------------
8700       double precision function eello_turn6(i,jj,kk)
8701       implicit real*8 (a-h,o-z)
8702       include 'DIMENSIONS'
8703       include 'DIMENSIONS.ZSCOPT'
8704       include 'COMMON.IOUNITS'
8705       include 'COMMON.CHAIN'
8706       include 'COMMON.DERIV'
8707       include 'COMMON.INTERACT'
8708       include 'COMMON.CONTACTS'
8709       include 'COMMON.TORSION'
8710       include 'COMMON.VAR'
8711       include 'COMMON.GEO'
8712       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8713      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8714      &  ggg1(3),ggg2(3)
8715       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8716      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8717 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8718 C           the respective energy moment and not to the cluster cumulant.
8719       eello_turn6=0.0d0
8720       j=i+4
8721       k=i+1
8722       l=i+3
8723       iti=itortyp(itype(i))
8724       itk=itortyp(itype(k))
8725       itk1=itortyp(itype(k+1))
8726       itl=itortyp(itype(l))
8727       itj=itortyp(itype(j))
8728 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8729 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8730 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8731 cd        eello6=0.0d0
8732 cd        return
8733 cd      endif
8734 cd      write (iout,*)
8735 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8736 cd     &   ' and',k,l
8737 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8738       do iii=1,2
8739         do kkk=1,5
8740           do lll=1,3
8741             derx_turn(lll,kkk,iii)=0.0d0
8742           enddo
8743         enddo
8744       enddo
8745 cd      eij=1.0d0
8746 cd      ekl=1.0d0
8747 cd      ekont=1.0d0
8748       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8749 cd      eello6_5=0.0d0
8750 cd      write (2,*) 'eello6_5',eello6_5
8751 #ifdef MOMENT
8752       call transpose2(AEA(1,1,1),auxmat(1,1))
8753       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8754       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8755       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8756 #else
8757       s1 = 0.0d0
8758 #endif
8759       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8760       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8761       s2 = scalar2(b1(1,itk),vtemp1(1))
8762 #ifdef MOMENT
8763       call transpose2(AEA(1,1,2),atemp(1,1))
8764       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8765       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8766       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8767 #else
8768       s8=0.0d0
8769 #endif
8770       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8771       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8772       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8773 #ifdef MOMENT
8774       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8775       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8776       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8777       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8778       ss13 = scalar2(b1(1,itk),vtemp4(1))
8779       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8780 #else
8781       s13=0.0d0
8782 #endif
8783 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8784 c      s1=0.0d0
8785 c      s2=0.0d0
8786 c      s8=0.0d0
8787 c      s12=0.0d0
8788 c      s13=0.0d0
8789       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8790       if (calc_grad) then
8791 C Derivatives in gamma(i+2)
8792 #ifdef MOMENT
8793       call transpose2(AEA(1,1,1),auxmatd(1,1))
8794       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8795       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8796       call transpose2(AEAderg(1,1,2),atempd(1,1))
8797       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8798       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8799 #else
8800       s8d=0.0d0
8801 #endif
8802       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8803       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8804       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8805 c      s1d=0.0d0
8806 c      s2d=0.0d0
8807 c      s8d=0.0d0
8808 c      s12d=0.0d0
8809 c      s13d=0.0d0
8810       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8811 C Derivatives in gamma(i+3)
8812 #ifdef MOMENT
8813       call transpose2(AEA(1,1,1),auxmatd(1,1))
8814       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8815       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8816       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8817 #else
8818       s1d=0.0d0
8819 #endif
8820       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8821       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8822       s2d = scalar2(b1(1,itk),vtemp1d(1))
8823 #ifdef MOMENT
8824       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8825       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8826 #endif
8827       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8828 #ifdef MOMENT
8829       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8830       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8831       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8832 #else
8833       s13d=0.0d0
8834 #endif
8835 c      s1d=0.0d0
8836 c      s2d=0.0d0
8837 c      s8d=0.0d0
8838 c      s12d=0.0d0
8839 c      s13d=0.0d0
8840 #ifdef MOMENT
8841       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8842      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8843 #else
8844       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8845      &               -0.5d0*ekont*(s2d+s12d)
8846 #endif
8847 C Derivatives in gamma(i+4)
8848       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8849       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8850       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8851 #ifdef MOMENT
8852       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8853       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8854       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8855 #else
8856       s13d = 0.0d0
8857 #endif
8858 c      s1d=0.0d0
8859 c      s2d=0.0d0
8860 c      s8d=0.0d0
8861 C      s12d=0.0d0
8862 c      s13d=0.0d0
8863 #ifdef MOMENT
8864       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8865 #else
8866       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8867 #endif
8868 C Derivatives in gamma(i+5)
8869 #ifdef MOMENT
8870       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8871       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8872       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8873 #else
8874       s1d = 0.0d0
8875 #endif
8876       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8877       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8878       s2d = scalar2(b1(1,itk),vtemp1d(1))
8879 #ifdef MOMENT
8880       call transpose2(AEA(1,1,2),atempd(1,1))
8881       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8882       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8883 #else
8884       s8d = 0.0d0
8885 #endif
8886       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8887       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8888 #ifdef MOMENT
8889       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8890       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8891       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8892 #else
8893       s13d = 0.0d0
8894 #endif
8895 c      s1d=0.0d0
8896 c      s2d=0.0d0
8897 c      s8d=0.0d0
8898 c      s12d=0.0d0
8899 c      s13d=0.0d0
8900 #ifdef MOMENT
8901       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8902      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8903 #else
8904       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8905      &               -0.5d0*ekont*(s2d+s12d)
8906 #endif
8907 C Cartesian derivatives
8908       do iii=1,2
8909         do kkk=1,5
8910           do lll=1,3
8911 #ifdef MOMENT
8912             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8913             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8914             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8915 #else
8916             s1d = 0.0d0
8917 #endif
8918             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8919             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8920      &          vtemp1d(1))
8921             s2d = scalar2(b1(1,itk),vtemp1d(1))
8922 #ifdef MOMENT
8923             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8924             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8925             s8d = -(atempd(1,1)+atempd(2,2))*
8926      &           scalar2(cc(1,1,itl),vtemp2(1))
8927 #else
8928             s8d = 0.0d0
8929 #endif
8930             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8931      &           auxmatd(1,1))
8932             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8933             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8934 c      s1d=0.0d0
8935 c      s2d=0.0d0
8936 c      s8d=0.0d0
8937 c      s12d=0.0d0
8938 c      s13d=0.0d0
8939 #ifdef MOMENT
8940             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8941      &        - 0.5d0*(s1d+s2d)
8942 #else
8943             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8944      &        - 0.5d0*s2d
8945 #endif
8946 #ifdef MOMENT
8947             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8948      &        - 0.5d0*(s8d+s12d)
8949 #else
8950             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8951      &        - 0.5d0*s12d
8952 #endif
8953           enddo
8954         enddo
8955       enddo
8956 #ifdef MOMENT
8957       do kkk=1,5
8958         do lll=1,3
8959           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8960      &      achuj_tempd(1,1))
8961           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8962           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8963           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8964           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8965           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8966      &      vtemp4d(1))
8967           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8968           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8969           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8970         enddo
8971       enddo
8972 #endif
8973 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8974 cd     &  16*eel_turn6_num
8975 cd      goto 1112
8976       if (j.lt.nres-1) then
8977         j1=j+1
8978         j2=j-1
8979       else
8980         j1=j-1
8981         j2=j-2
8982       endif
8983       if (l.lt.nres-1) then
8984         l1=l+1
8985         l2=l-1
8986       else
8987         l1=l-1
8988         l2=l-2
8989       endif
8990       do ll=1,3
8991         ggg1(ll)=eel_turn6*g_contij(ll,1)
8992         ggg2(ll)=eel_turn6*g_contij(ll,2)
8993         ghalf=0.5d0*ggg1(ll)
8994 cd        ghalf=0.0d0
8995         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8996      &    +ekont*derx_turn(ll,2,1)
8997         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8998         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8999      &    +ekont*derx_turn(ll,4,1)
9000         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9001         ghalf=0.5d0*ggg2(ll)
9002 cd        ghalf=0.0d0
9003         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9004      &    +ekont*derx_turn(ll,2,2)
9005         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9006         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9007      &    +ekont*derx_turn(ll,4,2)
9008         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9009       enddo
9010 cd      goto 1112
9011       do m=i+1,j-1
9012         do ll=1,3
9013           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9014         enddo
9015       enddo
9016       do m=k+1,l-1
9017         do ll=1,3
9018           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9019         enddo
9020       enddo
9021 1112  continue
9022       do m=i+2,j2
9023         do ll=1,3
9024           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9025         enddo
9026       enddo
9027       do m=k+2,l2
9028         do ll=1,3
9029           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9030         enddo
9031       enddo
9032 cd      do iii=1,nres-3
9033 cd        write (2,*) iii,g_corr6_loc(iii)
9034 cd      enddo
9035       endif
9036       eello_turn6=ekont*eel_turn6
9037 cd      write (2,*) 'ekont',ekont
9038 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9039       return
9040       end
9041 crc-------------------------------------------------
9042       SUBROUTINE MATVEC2(A1,V1,V2)
9043       implicit real*8 (a-h,o-z)
9044       include 'DIMENSIONS'
9045       DIMENSION A1(2,2),V1(2),V2(2)
9046 c      DO 1 I=1,2
9047 c        VI=0.0
9048 c        DO 3 K=1,2
9049 c    3     VI=VI+A1(I,K)*V1(K)
9050 c        Vaux(I)=VI
9051 c    1 CONTINUE
9052
9053       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9054       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9055
9056       v2(1)=vaux1
9057       v2(2)=vaux2
9058       END
9059 C---------------------------------------
9060       SUBROUTINE MATMAT2(A1,A2,A3)
9061       implicit real*8 (a-h,o-z)
9062       include 'DIMENSIONS'
9063       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9064 c      DIMENSION AI3(2,2)
9065 c        DO  J=1,2
9066 c          A3IJ=0.0
9067 c          DO K=1,2
9068 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9069 c          enddo
9070 c          A3(I,J)=A3IJ
9071 c       enddo
9072 c      enddo
9073
9074       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9075       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9076       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9077       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9078
9079       A3(1,1)=AI3_11
9080       A3(2,1)=AI3_21
9081       A3(1,2)=AI3_12
9082       A3(2,2)=AI3_22
9083       END
9084
9085 c-------------------------------------------------------------------------
9086       double precision function scalar2(u,v)
9087       implicit none
9088       double precision u(2),v(2)
9089       double precision sc
9090       integer i
9091       scalar2=u(1)*v(1)+u(2)*v(2)
9092       return
9093       end
9094
9095 C-----------------------------------------------------------------------------
9096
9097       subroutine transpose2(a,at)
9098       implicit none
9099       double precision a(2,2),at(2,2)
9100       at(1,1)=a(1,1)
9101       at(1,2)=a(2,1)
9102       at(2,1)=a(1,2)
9103       at(2,2)=a(2,2)
9104       return
9105       end
9106 c--------------------------------------------------------------------------
9107       subroutine transpose(n,a,at)
9108       implicit none
9109       integer n,i,j
9110       double precision a(n,n),at(n,n)
9111       do i=1,n
9112         do j=1,n
9113           at(j,i)=a(i,j)
9114         enddo
9115       enddo
9116       return
9117       end
9118 C---------------------------------------------------------------------------
9119       subroutine prodmat3(a1,a2,kk,transp,prod)
9120       implicit none
9121       integer i,j
9122       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9123       logical transp
9124 crc      double precision auxmat(2,2),prod_(2,2)
9125
9126       if (transp) then
9127 crc        call transpose2(kk(1,1),auxmat(1,1))
9128 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9129 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9130
9131            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9132      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9133            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9134      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9135            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9136      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9137            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9138      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9139
9140       else
9141 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9142 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9143
9144            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9145      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9146            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9147      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9148            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9149      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9150            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9151      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9152
9153       endif
9154 c      call transpose2(a2(1,1),a2t(1,1))
9155
9156 crc      print *,transp
9157 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9158 crc      print *,((prod(i,j),i=1,2),j=1,2)
9159
9160       return
9161       end
9162 C-----------------------------------------------------------------------------
9163       double precision function scalar(u,v)
9164       implicit none
9165       double precision u(3),v(3)
9166       double precision sc
9167       integer i
9168       sc=0.0d0
9169       do i=1,3
9170         sc=sc+u(i)*v(i)
9171       enddo
9172       scalar=sc
9173       return
9174       end
9175