source/wham/src-restraints-PM/energy_p_new.F

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