source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       double precision fact(6)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C      write(iout,*) 'po elektostatyce'
  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            write(iout,*) 'po eelec'
  53
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61
  62       call ebond(estr)
  63 C       write (iout,*) "estr",estr
  64 C
  65 C Calculate the disulfide-bridge and other energy and the contributions
  66 C from other distance constraints.
  67 cd    print *,'Calling EHPB'
  68       call edis(ehpb)
  69 cd    print *,'EHPB exitted succesfully.'
  70 C
  71 C Calculate the virtual-bond-angle energy.
  72 C
  73 C      print *,'Bend energy finished.'
  74       call ebend(ebe,ethetacnstr)
  75 cd    print *,'Bend energy finished.'
  76 C
  77 C Calculate the SC local energy.
  78 C
  79       call esc(escloc)
  80 C       print *,'SCLOC energy finished.'
  81 C
  82 C Calculate the virtual-bond torsional energy.
  83 C
  84 cd    print *,'nterm=',nterm
  85       call etor(etors,edihcnstr,fact(1))
  86 C
  87 C 6/23/01 Calculate double-torsional energy
  88 C
  89       call etor_d(etors_d,fact(2))
  90 C
  91 C 21/5/07 Calculate local sicdechain correlation energy
  92 C
  93       call eback_sc_corr(esccor)
  94
  95       if (wliptran.gt.0) then
  96         call Eliptransfer(eliptran)
  97       endif
  98
  99 C
 100 C 12/1/95 Multi-body terms
 101 C
 102       n_corr=0
 103       n_corr1=0
 104       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 105      &    .or. wturn6.gt.0.0d0) then
 106 c         print *,"calling multibody_eello"
 107          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 108 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 109 c         print *,ecorr,ecorr5,ecorr6,eturn6
 110       endif
 111       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 112          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 113       endif
 114 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 115 #ifdef SPLITELE
 116       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 117      & +wvdwpp*evdw1
 118      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 119      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 120      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 121      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 122      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 123      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 124      & +wliptran*eliptran
 125 #else
 126       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 127      & +welec*fact(1)*(ees+evdw1)
 128      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 129      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 130      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 131      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 132      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 133      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 134      & +wliptran*eliptran
 135 #endif
 136       energia(0)=etot
 137       energia(1)=evdw
 138 #ifdef SCP14
 139       energia(2)=evdw2-evdw2_14
 140       energia(17)=evdw2_14
 141 #else
 142       energia(2)=evdw2
 143       energia(17)=0.0d0
 144 #endif
 145 #ifdef SPLITELE
 146       energia(3)=ees
 147       energia(16)=evdw1
 148 #else
 149       energia(3)=ees+evdw1
 150       energia(16)=0.0d0
 151 #endif
 152       energia(4)=ecorr
 153       energia(5)=ecorr5
 154       energia(6)=ecorr6
 155       energia(7)=eel_loc
 156       energia(8)=eello_turn3
 157       energia(9)=eello_turn4
 158       energia(10)=eturn6
 159       energia(11)=ebe
 160       energia(12)=escloc
 161       energia(13)=etors
 162       energia(14)=etors_d
 163       energia(15)=ehpb
 164       energia(18)=estr
 165       energia(19)=esccor
 166       energia(20)=edihcnstr
 167       energia(21)=evdw_t
 168       energia(24)=ethetacnstr
 169       energia(22)=eliptran
 170 c detecting NaNQ
 171 #ifdef ISNAN
 172 #ifdef AIX
 173       if (isnan(etot).ne.0) energia(0)=1.0d+99
 174 #else
 175       if (isnan(etot)) energia(0)=1.0d+99
 176 #endif
 177 #else
 178       i=0
 179 #ifdef WINPGI
 180       idumm=proc_proc(etot,i)
 181 #else
 182       call proc_proc(etot,i)
 183 #endif
 184       if(i.eq.1)energia(0)=1.0d+99
 185 #endif
 186 #ifdef MPL
 187 c     endif
 188 #endif
 189       if (calc_grad) then
 190 C
 191 C Sum up the components of the Cartesian gradient.
 192 C
 193 #ifdef SPLITELE
 194       do i=1,nct
 195         do j=1,3
 196           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 197      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 198      &                wbond*gradb(j,i)+
 199      &                wstrain*ghpbc(j,i)+
 200      &                wcorr*fact(3)*gradcorr(j,i)+
 201      &                wel_loc*fact(2)*gel_loc(j,i)+
 202      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 203      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 204      &                wcorr5*fact(4)*gradcorr5(j,i)+
 205      &                wcorr6*fact(5)*gradcorr6(j,i)+
 206      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 207      &                wsccor*fact(2)*gsccorc(j,i)
 208      &               +wliptran*gliptranc(j,i)
 209           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 210      &                  wbond*gradbx(j,i)+
 211      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 212      &                  wsccor*fact(2)*gsccorx(j,i)
 213      &                 +wliptran*gliptranx(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      &               +wliptran*gliptranc(j,i)
 230           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 231      &                  wbond*gradbx(j,i)+
 232      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 233      &                  wsccor*fact(1)*gsccorx(j,i)
 234      &                 +wliptran*gliptranx(j,i)
 235         enddo
 236 #endif
 237       enddo
 238
 239
 240       do i=1,nres-3
 241         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 242      &   +wcorr5*fact(4)*g_corr5_loc(i)
 243      &   +wcorr6*fact(5)*g_corr6_loc(i)
 244      &   +wturn4*fact(3)*gel_loc_turn4(i)
 245      &   +wturn3*fact(2)*gel_loc_turn3(i)
 246      &   +wturn6*fact(5)*gel_loc_turn6(i)
 247      &   +wel_loc*fact(2)*gel_loc_loc(i)
 248 c     &   +wsccor*fact(1)*gsccor_loc(i)
 249 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 250       enddo
 251       endif
 252       if (dyn_ss) call dyn_set_nss
 253       return
 254       end
 255 C------------------------------------------------------------------------
 256       subroutine enerprint(energia,fact)
 257       implicit real*8 (a-h,o-z)
 258       include 'DIMENSIONS'
 259       include 'DIMENSIONS.ZSCOPT'
 260       include 'COMMON.IOUNITS'
 261       include 'COMMON.FFIELD'
 262       include 'COMMON.SBRIDGE'
 263       double precision energia(0:max_ene),fact(6)
 264       etot=energia(0)
 265       evdw=energia(1)+fact(6)*energia(21)
 266 #ifdef SCP14
 267       evdw2=energia(2)+energia(17)
 268 #else
 269       evdw2=energia(2)
 270 #endif
 271       ees=energia(3)
 272 #ifdef SPLITELE
 273       evdw1=energia(16)
 274 #endif
 275       ecorr=energia(4)
 276       ecorr5=energia(5)
 277       ecorr6=energia(6)
 278       eel_loc=energia(7)
 279       eello_turn3=energia(8)
 280       eello_turn4=energia(9)
 281       eello_turn6=energia(10)
 282       ebe=energia(11)
 283       escloc=energia(12)
 284       etors=energia(13)
 285       etors_d=energia(14)
 286       ehpb=energia(15)
 287       esccor=energia(19)
 288       edihcnstr=energia(20)
 289       estr=energia(18)
 290       ethetacnstr=energia(24)
 291       eliptran=energia(22)
 292 #ifdef SPLITELE
 293       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 294      &  wvdwpp,
 295      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 296      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 297      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 298      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 299      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 300      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 301      & eliptran,wliptran,etot
 302    10 format (/'Virtual-chain energies:'//
 303      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 304      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 305      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 306      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 307      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 308      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 309      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 310      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 311      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 312      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 313      & ' (SS bridges & dist. cnstr.)'/
 314      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 315      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 316      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 317      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 318      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 319      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 320      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 321      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 322      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 323      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 324      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 325      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 326      & 'ETOT=  ',1pE16.6,' (total)')
 327 #else
 328       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 329      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 330      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 331      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 332      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 333      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 334      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 335    10 format (/'Virtual-chain energies:'//
 336      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 337      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 338      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 339      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 340      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 341      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 342      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 343      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 344      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 345      & ' (SS bridges & dist. cnstr.)'/
 346      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 347      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 348      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 349      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 350      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 351      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 352      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 353      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 354      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 355      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 356      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 357      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 358      & 'ETOT=  ',1pE16.6,' (total)')
 359 #endif
 360       return
 361       end
 362 C-----------------------------------------------------------------------
 363       subroutine elj(evdw,evdw_t)
 364 C
 365 C This subroutine calculates the interaction energy of nonbonded side chains
 366 C assuming the LJ potential of interaction.
 367 C
 368       implicit real*8 (a-h,o-z)
 369       include 'DIMENSIONS'
 370       include 'DIMENSIONS.ZSCOPT'
 371       include "DIMENSIONS.COMPAR"
 372       parameter (accur=1.0d-10)
 373       include 'COMMON.GEO'
 374       include 'COMMON.VAR'
 375       include 'COMMON.LOCAL'
 376       include 'COMMON.CHAIN'
 377       include 'COMMON.DERIV'
 378       include 'COMMON.INTERACT'
 379       include 'COMMON.TORSION'
 380       include 'COMMON.ENEPS'
 381       include 'COMMON.SBRIDGE'
 382       include 'COMMON.NAMES'
 383       include 'COMMON.IOUNITS'
 384       include 'COMMON.CONTACTS'
 385       dimension gg(3)
 386       integer icant
 387       external icant
 388 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 389 c ROZNICA z cluster
 390       do i=1,210
 391         do j=1,2
 392           eneps_temp(j,i)=0.0d0
 393         enddo
 394       enddo
 395 cROZNICA
 396
 397       evdw=0.0D0
 398       evdw_t=0.0d0
 399       do i=iatsc_s,iatsc_e
 400         itypi=iabs(itype(i))
 401         if (itypi.eq.ntyp1) cycle
 402         itypi1=iabs(itype(i+1))
 403         xi=c(1,nres+i)
 404         yi=c(2,nres+i)
 405         zi=c(3,nres+i)
 406 C Change 12/1/95
 407         num_conti=0
 408 C
 409 C Calculate SC interaction energy.
 410 C
 411         do iint=1,nint_gr(i)
 412 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 413 cd   &                  'iend=',iend(i,iint)
 414           do j=istart(i,iint),iend(i,iint)
 415             itypj=iabs(itype(j))
 416             if (itypj.eq.ntyp1) cycle
 417             xj=c(1,nres+j)-xi
 418             yj=c(2,nres+j)-yi
 419             zj=c(3,nres+j)-zi
 420 C Change 12/1/95 to calculate four-body interactions
 421             rij=xj*xj+yj*yj+zj*zj
 422             rrij=1.0D0/rij
 423 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 424             eps0ij=eps(itypi,itypj)
 425             fac=rrij**expon2
 426             e1=fac*fac*aa
 427             e2=fac*bb
 428             evdwij=e1+e2
 429             ij=icant(itypi,itypj)
 430 c ROZNICA z cluster
 431             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 432             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 433 c
 434
 435 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 436 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 437 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 438 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 439 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 440 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 441             if (bb.gt.0.0d0) then
 442               evdw=evdw+evdwij
 443             else
 444               evdw_t=evdw_t+evdwij
 445             endif
 446             if (calc_grad) then
 447 C
 448 C Calculate the components of the gradient in DC and X
 449 C
 450             fac=-rrij*(e1+evdwij)
 451             gg(1)=xj*fac
 452             gg(2)=yj*fac
 453             gg(3)=zj*fac
 454             do k=1,3
 455               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 456               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 457             enddo
 458             do k=i,j-1
 459               do l=1,3
 460                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 461               enddo
 462             enddo
 463             endif
 464 C
 465 C 12/1/95, revised on 5/20/97
 466 C
 467 C Calculate the contact function. The ith column of the array JCONT will
 468 C contain the numbers of atoms that make contacts with the atom I (of numbers
 469 C greater than I). The arrays FACONT and GACONT will contain the values of
 470 C the contact function and its derivative.
 471 C
 472 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 473 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 474 C Uncomment next line, if the correlation interactions are contact function only
 475             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 476               rij=dsqrt(rij)
 477               sigij=sigma(itypi,itypj)
 478               r0ij=rs0(itypi,itypj)
 479 C
 480 C Check whether the SC's are not too far to make a contact.
 481 C
 482               rcut=1.5d0*r0ij
 483               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 484 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 485 C
 486               if (fcont.gt.0.0D0) then
 487 C If the SC-SC distance if close to sigma, apply spline.
 488 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 489 cAdam &             fcont1,fprimcont1)
 490 cAdam           fcont1=1.0d0-fcont1
 491 cAdam           if (fcont1.gt.0.0d0) then
 492 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 493 cAdam             fcont=fcont*fcont1
 494 cAdam           endif
 495 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 496 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 497 cga             do k=1,3
 498 cga               gg(k)=gg(k)*eps0ij
 499 cga             enddo
 500 cga             eps0ij=-evdwij*eps0ij
 501 C Uncomment for AL's type of SC correlation interactions.
 502 cadam           eps0ij=-evdwij
 503                 num_conti=num_conti+1
 504                 jcont(num_conti,i)=j
 505                 facont(num_conti,i)=fcont*eps0ij
 506                 fprimcont=eps0ij*fprimcont/rij
 507                 fcont=expon*fcont
 508 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 509 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 510 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 511 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 512                 gacont(1,num_conti,i)=-fprimcont*xj
 513                 gacont(2,num_conti,i)=-fprimcont*yj
 514                 gacont(3,num_conti,i)=-fprimcont*zj
 515 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 516 cd              write (iout,'(2i3,3f10.5)')
 517 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 518               endif
 519             endif
 520           enddo      ! j
 521         enddo        ! iint
 522 C Change 12/1/95
 523         num_cont(i)=num_conti
 524       enddo          ! i
 525       if (calc_grad) then
 526       do i=1,nct
 527         do j=1,3
 528           gvdwc(j,i)=expon*gvdwc(j,i)
 529           gvdwx(j,i)=expon*gvdwx(j,i)
 530         enddo
 531       enddo
 532       endif
 533 C******************************************************************************
 534 C
 535 C                              N O T E !!!
 536 C
 537 C To save time, the factor of EXPON has been extracted from ALL components
 538 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 539 C use!
 540 C
 541 C******************************************************************************
 542       return
 543       end
 544 C-----------------------------------------------------------------------------
 545       subroutine eljk(evdw,evdw_t)
 546 C
 547 C This subroutine calculates the interaction energy of nonbonded side chains
 548 C assuming the LJK potential of interaction.
 549 C
 550       implicit real*8 (a-h,o-z)
 551       include 'DIMENSIONS'
 552       include 'DIMENSIONS.ZSCOPT'
 553       include "DIMENSIONS.COMPAR"
 554       include 'COMMON.GEO'
 555       include 'COMMON.VAR'
 556       include 'COMMON.LOCAL'
 557       include 'COMMON.CHAIN'
 558       include 'COMMON.DERIV'
 559       include 'COMMON.INTERACT'
 560       include 'COMMON.ENEPS'
 561       include 'COMMON.IOUNITS'
 562       include 'COMMON.NAMES'
 563       dimension gg(3)
 564       logical scheck
 565       integer icant
 566       external icant
 567 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 568       do i=1,210
 569         do j=1,2
 570           eneps_temp(j,i)=0.0d0
 571         enddo
 572       enddo
 573       evdw=0.0D0
 574       evdw_t=0.0d0
 575       do i=iatsc_s,iatsc_e
 576         itypi=iabs(itype(i))
 577         if (itypi.eq.ntyp1) cycle
 578         itypi1=iabs(itype(i+1))
 579         xi=c(1,nres+i)
 580         yi=c(2,nres+i)
 581         zi=c(3,nres+i)
 582 C
 583 C Calculate SC interaction energy.
 584 C
 585         do iint=1,nint_gr(i)
 586           do j=istart(i,iint),iend(i,iint)
 587             itypj=iabs(itype(j))
 588             if (itypj.eq.ntyp1) cycle
 589             xj=c(1,nres+j)-xi
 590             yj=c(2,nres+j)-yi
 591             zj=c(3,nres+j)-zi
 592             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 593             fac_augm=rrij**expon
 594             e_augm=augm(itypi,itypj)*fac_augm
 595             r_inv_ij=dsqrt(rrij)
 596             rij=1.0D0/r_inv_ij
 597             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 598             fac=r_shift_inv**expon
 599             e1=fac*fac*aa
 600             e2=fac*bb
 601             evdwij=e_augm+e1+e2
 602             ij=icant(itypi,itypj)
 603             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 604      &        /dabs(eps(itypi,itypj))
 605             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 606 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 607 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 608 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 609 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 610 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 611 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 612 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 613             if (bb.gt.0.0d0) then
 614               evdw=evdw+evdwij
 615             else
 616               evdw_t=evdw_t+evdwij
 617             endif
 618             if (calc_grad) then
 619 C
 620 C Calculate the components of the gradient in DC and X
 621 C
 622             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 623             gg(1)=xj*fac
 624             gg(2)=yj*fac
 625             gg(3)=zj*fac
 626             do k=1,3
 627               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 628               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 629             enddo
 630             do k=i,j-1
 631               do l=1,3
 632                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 633               enddo
 634             enddo
 635             endif
 636           enddo      ! j
 637         enddo        ! iint
 638       enddo          ! i
 639       if (calc_grad) then
 640       do i=1,nct
 641         do j=1,3
 642           gvdwc(j,i)=expon*gvdwc(j,i)
 643           gvdwx(j,i)=expon*gvdwx(j,i)
 644         enddo
 645       enddo
 646       endif
 647       return
 648       end
 649 C-----------------------------------------------------------------------------
 650       subroutine ebp(evdw,evdw_t)
 651 C
 652 C This subroutine calculates the interaction energy of nonbonded side chains
 653 C assuming the Berne-Pechukas potential of interaction.
 654 C
 655       implicit real*8 (a-h,o-z)
 656       include 'DIMENSIONS'
 657       include 'DIMENSIONS.ZSCOPT'
 658       include "DIMENSIONS.COMPAR"
 659       include 'COMMON.GEO'
 660       include 'COMMON.VAR'
 661       include 'COMMON.LOCAL'
 662       include 'COMMON.CHAIN'
 663       include 'COMMON.DERIV'
 664       include 'COMMON.NAMES'
 665       include 'COMMON.INTERACT'
 666       include 'COMMON.ENEPS'
 667       include 'COMMON.IOUNITS'
 668       include 'COMMON.CALC'
 669       common /srutu/ icall
 670 c     double precision rrsave(maxdim)
 671       logical lprn
 672       integer icant
 673       external icant
 674       do i=1,210
 675         do j=1,2
 676           eneps_temp(j,i)=0.0d0
 677         enddo
 678       enddo
 679       evdw=0.0D0
 680       evdw_t=0.0d0
 681 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 682 c     if (icall.eq.0) then
 683 c       lprn=.true.
 684 c     else
 685         lprn=.false.
 686 c     endif
 687       ind=0
 688       do i=iatsc_s,iatsc_e
 689         itypi=iabs(itype(i))
 690         if (itypi.eq.ntyp1) cycle
 691         itypi1=iabs(itype(i+1))
 692         xi=c(1,nres+i)
 693         yi=c(2,nres+i)
 694         zi=c(3,nres+i)
 695         dxi=dc_norm(1,nres+i)
 696         dyi=dc_norm(2,nres+i)
 697         dzi=dc_norm(3,nres+i)
 698         dsci_inv=vbld_inv(i+nres)
 699 C
 700 C Calculate SC interaction energy.
 701 C
 702         do iint=1,nint_gr(i)
 703           do j=istart(i,iint),iend(i,iint)
 704             ind=ind+1
 705             itypj=iabs(itype(j))
 706             if (itypj.eq.ntyp1) cycle
 707             dscj_inv=vbld_inv(j+nres)
 708             chi1=chi(itypi,itypj)
 709             chi2=chi(itypj,itypi)
 710             chi12=chi1*chi2
 711             chip1=chip(itypi)
 712             chip2=chip(itypj)
 713             chip12=chip1*chip2
 714             alf1=alp(itypi)
 715             alf2=alp(itypj)
 716             alf12=0.5D0*(alf1+alf2)
 717 C For diagnostics only!!!
 718 c           chi1=0.0D0
 719 c           chi2=0.0D0
 720 c           chi12=0.0D0
 721 c           chip1=0.0D0
 722 c           chip2=0.0D0
 723 c           chip12=0.0D0
 724 c           alf1=0.0D0
 725 c           alf2=0.0D0
 726 c           alf12=0.0D0
 727             xj=c(1,nres+j)-xi
 728             yj=c(2,nres+j)-yi
 729             zj=c(3,nres+j)-zi
 730             dxj=dc_norm(1,nres+j)
 731             dyj=dc_norm(2,nres+j)
 732             dzj=dc_norm(3,nres+j)
 733             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 734 cd          if (icall.eq.0) then
 735 cd            rrsave(ind)=rrij
 736 cd          else
 737 cd            rrij=rrsave(ind)
 738 cd          endif
 739             rij=dsqrt(rrij)
 740 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 741             call sc_angular
 742 C Calculate whole angle-dependent part of epsilon and contributions
 743 C to its derivatives
 744             fac=(rrij*sigsq)**expon2
 745             e1=fac*fac*aa
 746             e2=fac*bb
 747             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 748             eps2der=evdwij*eps3rt
 749             eps3der=evdwij*eps2rt
 750             evdwij=evdwij*eps2rt*eps3rt
 751             ij=icant(itypi,itypj)
 752             aux=eps1*eps2rt**2*eps3rt**2
 753             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 754      &        /dabs(eps(itypi,itypj))
 755             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 756             if (bb.gt.0.0d0) then
 757               evdw=evdw+evdwij
 758             else
 759               evdw_t=evdw_t+evdwij
 760             endif
 761             if (calc_grad) then
 762             if (lprn) then
 763             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 764             epsi=bb**2/aa
 765             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 766      &        restyp(itypi),i,restyp(itypj),j,
 767      &        epsi,sigm,chi1,chi2,chip1,chip2,
 768      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 769      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 770      &        evdwij
 771             endif
 772 C Calculate gradient components.
 773             e1=e1*eps1*eps2rt**2*eps3rt**2
 774             fac=-expon*(e1+evdwij)
 775             sigder=fac/sigsq
 776             fac=rrij*fac
 777 C Calculate radial part of the gradient
 778             gg(1)=xj*fac
 779             gg(2)=yj*fac
 780             gg(3)=zj*fac
 781 C Calculate the angular part of the gradient and sum add the contributions
 782 C to the appropriate components of the Cartesian gradient.
 783             call sc_grad
 784             endif
 785           enddo      ! j
 786         enddo        ! iint
 787       enddo          ! i
 788 c     stop
 789       return
 790       end
 791 C-----------------------------------------------------------------------------
 792       subroutine egb(evdw,evdw_t)
 793 C
 794 C This subroutine calculates the interaction energy of nonbonded side chains
 795 C assuming the Gay-Berne potential of interaction.
 796 C
 797       implicit real*8 (a-h,o-z)
 798       include 'DIMENSIONS'
 799       include 'DIMENSIONS.ZSCOPT'
 800       include "DIMENSIONS.COMPAR"
 801       include 'COMMON.GEO'
 802       include 'COMMON.VAR'
 803       include 'COMMON.LOCAL'
 804       include 'COMMON.CHAIN'
 805       include 'COMMON.DERIV'
 806       include 'COMMON.NAMES'
 807       include 'COMMON.INTERACT'
 808       include 'COMMON.ENEPS'
 809       include 'COMMON.IOUNITS'
 810       include 'COMMON.CALC'
 811       include 'COMMON.SBRIDGE'
 812       logical lprn
 813       common /srutu/icall
 814       integer icant
 815       external icant
 816       do i=1,210
 817         do j=1,2
 818           eneps_temp(j,i)=0.0d0
 819         enddo
 820       enddo
 821 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 822       evdw=0.0D0
 823       evdw_t=0.0d0
 824       lprn=.false.
 825 c      if (icall.gt.0) lprn=.true.
 826       ind=0
 827       do i=iatsc_s,iatsc_e
 828         itypi=iabs(itype(i))
 829         if (itypi.eq.ntyp1) cycle
 830         itypi1=iabs(itype(i+1))
 831         xi=c(1,nres+i)
 832         yi=c(2,nres+i)
 833         zi=c(3,nres+i)
 834 C returning the ith atom to box
 835           xi=mod(xi,boxxsize)
 836           if (xi.lt.0) xi=xi+boxxsize
 837           yi=mod(yi,boxysize)
 838           if (yi.lt.0) yi=yi+boxysize
 839           zi=mod(zi,boxzsize)
 840           if (zi.lt.0) zi=zi+boxzsize
 841        if ((zi.gt.bordlipbot)
 842      &.and.(zi.lt.bordliptop)) then
 843 C the energy transfer exist
 844         if (zi.lt.buflipbot) then
 845 C what fraction I am in
 846          fracinbuf=1.0d0-
 847      &        ((zi-bordlipbot)/lipbufthick)
 848 C lipbufthick is thickenes of lipid buffore
 849          sslipi=sscalelip(fracinbuf)
 850          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 851         elseif (zi.gt.bufliptop) then
 852          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 853          sslipi=sscalelip(fracinbuf)
 854          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 855         else
 856          sslipi=1.0d0
 857          ssgradlipi=0.0
 858         endif
 859        else
 860          sslipi=0.0d0
 861          ssgradlipi=0.0
 862        endif
 863
 864         dxi=dc_norm(1,nres+i)
 865         dyi=dc_norm(2,nres+i)
 866         dzi=dc_norm(3,nres+i)
 867         dsci_inv=vbld_inv(i+nres)
 868 C
 869 C Calculate SC interaction energy.
 870 C
 871         do iint=1,nint_gr(i)
 872           do j=istart(i,iint),iend(i,iint)
 873             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 874               call dyn_ssbond_ene(i,j,evdwij)
 875               evdw=evdw+evdwij
 876 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 877 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 878 C triple bond artifac removal
 879              do k=j+1,iend(i,iint)
 880 C search over all next residues
 881               if (dyn_ss_mask(k)) then
 882 C check if they are cysteins
 883 C              write(iout,*) 'k=',k
 884               call triple_ssbond_ene(i,j,k,evdwij)
 885 C call the energy function that removes the artifical triple disulfide
 886 C bond the soubroutine is located in ssMD.F
 887               evdw=evdw+evdwij
 888 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 889 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 890               endif!dyn_ss_mask(k)
 891              enddo! k
 892             ELSE
 893             ind=ind+1
 894             itypj=iabs(itype(j))
 895             if (itypj.eq.ntyp1) cycle
 896             dscj_inv=vbld_inv(j+nres)
 897             sig0ij=sigma(itypi,itypj)
 898             chi1=chi(itypi,itypj)
 899             chi2=chi(itypj,itypi)
 900             chi12=chi1*chi2
 901             chip1=chip(itypi)
 902             chip2=chip(itypj)
 903             chip12=chip1*chip2
 904             alf1=alp(itypi)
 905             alf2=alp(itypj)
 906             alf12=0.5D0*(alf1+alf2)
 907 C For diagnostics only!!!
 908 c           chi1=0.0D0
 909 c           chi2=0.0D0
 910 c           chi12=0.0D0
 911 c           chip1=0.0D0
 912 c           chip2=0.0D0
 913 c           chip12=0.0D0
 914 c           alf1=0.0D0
 915 c           alf2=0.0D0
 916 c           alf12=0.0D0
 917             xj=c(1,nres+j)
 918             yj=c(2,nres+j)
 919             zj=c(3,nres+j)
 920 C returning jth atom to box
 921           xj=mod(xj,boxxsize)
 922           if (xj.lt.0) xj=xj+boxxsize
 923           yj=mod(yj,boxysize)
 924           if (yj.lt.0) yj=yj+boxysize
 925           zj=mod(zj,boxzsize)
 926           if (zj.lt.0) zj=zj+boxzsize
 927        if ((zj.gt.bordlipbot)
 928      &.and.(zj.lt.bordliptop)) then
 929 C the energy transfer exist
 930         if (zj.lt.buflipbot) then
 931 C what fraction I am in
 932          fracinbuf=1.0d0-
 933      &        ((zj-bordlipbot)/lipbufthick)
 934 C lipbufthick is thickenes of lipid buffore
 935          sslipj=sscalelip(fracinbuf)
 936          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 937         elseif (zj.gt.bufliptop) then
 938          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 939          sslipj=sscalelip(fracinbuf)
 940          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 941         else
 942          sslipj=1.0d0
 943          ssgradlipj=0.0
 944         endif
 945        else
 946          sslipj=0.0d0
 947          ssgradlipj=0.0
 948        endif
 949       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 950      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 951       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 952      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 953 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
 954 C checking the distance
 955       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 956       xj_safe=xj
 957       yj_safe=yj
 958       zj_safe=zj
 959       subchap=0
 960 C finding the closest
 961       do xshift=-1,1
 962       do yshift=-1,1
 963       do zshift=-1,1
 964           xj=xj_safe+xshift*boxxsize
 965           yj=yj_safe+yshift*boxysize
 966           zj=zj_safe+zshift*boxzsize
 967           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 968           if(dist_temp.lt.dist_init) then
 969             dist_init=dist_temp
 970             xj_temp=xj
 971             yj_temp=yj
 972             zj_temp=zj
 973             subchap=1
 974           endif
 975        enddo
 976        enddo
 977        enddo
 978        if (subchap.eq.1) then
 979           xj=xj_temp-xi
 980           yj=yj_temp-yi
 981           zj=zj_temp-zi
 982        else
 983           xj=xj_safe-xi
 984           yj=yj_safe-yi
 985           zj=zj_safe-zi
 986        endif
 987
 988             dxj=dc_norm(1,nres+j)
 989             dyj=dc_norm(2,nres+j)
 990             dzj=dc_norm(3,nres+j)
 991 c            write (iout,*) i,j,xj,yj,zj
 992             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 993             rij=dsqrt(rrij)
 994             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
 995             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
 996             if (sss.le.0.0) cycle
 997 C Calculate angle-dependent terms of energy and contributions to their
 998 C derivatives.
 999
1000             call sc_angular
1001             sigsq=1.0D0/sigsq
1002             sig=sig0ij*dsqrt(sigsq)
1003             rij_shift=1.0D0/rij-sig+sig0ij
1004 C I hate to put IF's in the loops, but here don't have another choice!!!!
1005             if (rij_shift.le.0.0D0) then
1006               evdw=1.0D20
1007               return
1008             endif
1009             sigder=-sig*sigsq
1010 c---------------------------------------------------------------
1011             rij_shift=1.0D0/rij_shift
1012             fac=rij_shift**expon
1013             e1=fac*fac*aa
1014             e2=fac*bb
1015             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1016             eps2der=evdwij*eps3rt
1017             eps3der=evdwij*eps2rt
1018             evdwij=evdwij*eps2rt*eps3rt
1019             if (bb.gt.0) then
1020               evdw=evdw+evdwij*sss
1021             else
1022               evdw_t=evdw_t+evdwij*sss
1023             endif
1024             ij=icant(itypi,itypj)
1025             aux=eps1*eps2rt**2*eps3rt**2
1026             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1027      &        /dabs(eps(itypi,itypj))
1028             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1029 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1030 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1031 c     &         aux*e2/eps(itypi,itypj)
1032 c            if (lprn) then
1033             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1034             epsi=bb**2/aa
1035 #ifdef DEBUG
1036             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1037      &        restyp(itypi),i,restyp(itypj),j,
1038      &        epsi,sigm,chi1,chi2,chip1,chip2,
1039      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1040      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1041      &        evdwij
1042              write (iout,*) "partial sum", evdw, evdw_t
1043 #endif
1044 c            endif
1045             if (calc_grad) then
1046 C Calculate gradient components.
1047             e1=e1*eps1*eps2rt**2*eps3rt**2
1048             fac=-expon*(e1+evdwij)*rij_shift
1049             sigder=fac*sigder
1050             fac=rij*fac
1051             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1052 C Calculate the radial part of the gradient
1053             gg(1)=xj*fac
1054             gg(2)=yj*fac
1055             gg(3)=zj*fac
1056 C Calculate angular part of the gradient.
1057             call sc_grad
1058             endif
1059 C            write(iout,*)  "partial sum", evdw, evdw_t
1060             ENDIF    ! dyn_ss
1061           enddo      ! j
1062         enddo        ! iint
1063       enddo          ! i
1064       return
1065       end
1066 C-----------------------------------------------------------------------------
1067       subroutine egbv(evdw,evdw_t)
1068 C
1069 C This subroutine calculates the interaction energy of nonbonded side chains
1070 C assuming the Gay-Berne-Vorobjev potential of interaction.
1071 C
1072       implicit real*8 (a-h,o-z)
1073       include 'DIMENSIONS'
1074       include 'DIMENSIONS.ZSCOPT'
1075       include "DIMENSIONS.COMPAR"
1076       include 'COMMON.GEO'
1077       include 'COMMON.VAR'
1078       include 'COMMON.LOCAL'
1079       include 'COMMON.CHAIN'
1080       include 'COMMON.DERIV'
1081       include 'COMMON.NAMES'
1082       include 'COMMON.INTERACT'
1083       include 'COMMON.ENEPS'
1084       include 'COMMON.IOUNITS'
1085       include 'COMMON.CALC'
1086       common /srutu/ icall
1087       logical lprn
1088       integer icant
1089       external icant
1090       do i=1,210
1091         do j=1,2
1092           eneps_temp(j,i)=0.0d0
1093         enddo
1094       enddo
1095       evdw=0.0D0
1096       evdw_t=0.0d0
1097 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1098       evdw=0.0D0
1099       lprn=.false.
1100 c      if (icall.gt.0) lprn=.true.
1101       ind=0
1102       do i=iatsc_s,iatsc_e
1103         itypi=iabs(itype(i))
1104         if (itypi.eq.ntyp1) cycle
1105         itypi1=iabs(itype(i+1))
1106         xi=c(1,nres+i)
1107         yi=c(2,nres+i)
1108         zi=c(3,nres+i)
1109         dxi=dc_norm(1,nres+i)
1110         dyi=dc_norm(2,nres+i)
1111         dzi=dc_norm(3,nres+i)
1112         dsci_inv=vbld_inv(i+nres)
1113 C
1114 C Calculate SC interaction energy.
1115 C
1116         do iint=1,nint_gr(i)
1117           do j=istart(i,iint),iend(i,iint)
1118             ind=ind+1
1119             itypj=iabs(itype(j))
1120             if (itypj.eq.ntyp1) cycle
1121             dscj_inv=vbld_inv(j+nres)
1122             sig0ij=sigma(itypi,itypj)
1123             r0ij=r0(itypi,itypj)
1124             chi1=chi(itypi,itypj)
1125             chi2=chi(itypj,itypi)
1126             chi12=chi1*chi2
1127             chip1=chip(itypi)
1128             chip2=chip(itypj)
1129             chip12=chip1*chip2
1130             alf1=alp(itypi)
1131             alf2=alp(itypj)
1132             alf12=0.5D0*(alf1+alf2)
1133 C For diagnostics only!!!
1134 c           chi1=0.0D0
1135 c           chi2=0.0D0
1136 c           chi12=0.0D0
1137 c           chip1=0.0D0
1138 c           chip2=0.0D0
1139 c           chip12=0.0D0
1140 c           alf1=0.0D0
1141 c           alf2=0.0D0
1142 c           alf12=0.0D0
1143             xj=c(1,nres+j)-xi
1144             yj=c(2,nres+j)-yi
1145             zj=c(3,nres+j)-zi
1146             dxj=dc_norm(1,nres+j)
1147             dyj=dc_norm(2,nres+j)
1148             dzj=dc_norm(3,nres+j)
1149             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1150             rij=dsqrt(rrij)
1151 C Calculate angle-dependent terms of energy and contributions to their
1152 C derivatives.
1153             call sc_angular
1154             sigsq=1.0D0/sigsq
1155             sig=sig0ij*dsqrt(sigsq)
1156             rij_shift=1.0D0/rij-sig+r0ij
1157 C I hate to put IF's in the loops, but here don't have another choice!!!!
1158             if (rij_shift.le.0.0D0) then
1159               evdw=1.0D20
1160               return
1161             endif
1162             sigder=-sig*sigsq
1163 c---------------------------------------------------------------
1164             rij_shift=1.0D0/rij_shift
1165             fac=rij_shift**expon
1166             e1=fac*fac*aa
1167             e2=fac*bb
1168             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1169             eps2der=evdwij*eps3rt
1170             eps3der=evdwij*eps2rt
1171             fac_augm=rrij**expon
1172             e_augm=augm(itypi,itypj)*fac_augm
1173             evdwij=evdwij*eps2rt*eps3rt
1174             if (bb.gt.0.0d0) then
1175               evdw=evdw+evdwij+e_augm
1176             else
1177               evdw_t=evdw_t+evdwij+e_augm
1178             endif
1179             ij=icant(itypi,itypj)
1180             aux=eps1*eps2rt**2*eps3rt**2
1181             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1182      &        /dabs(eps(itypi,itypj))
1183             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1184 c            eneps_temp(ij)=eneps_temp(ij)
1185 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1186 c            if (lprn) then
1187 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1188 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1189 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1190 c     &        restyp(itypi),i,restyp(itypj),j,
1191 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1192 c     &        chi1,chi2,chip1,chip2,
1193 c     &        eps1,eps2rt**2,eps3rt**2,
1194 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1195 c     &        evdwij+e_augm
1196 c            endif
1197             if (calc_grad) then
1198 C Calculate gradient components.
1199             e1=e1*eps1*eps2rt**2*eps3rt**2
1200             fac=-expon*(e1+evdwij)*rij_shift
1201             sigder=fac*sigder
1202             fac=rij*fac-2*expon*rrij*e_augm
1203 C Calculate the radial part of the gradient
1204             gg(1)=xj*fac
1205             gg(2)=yj*fac
1206             gg(3)=zj*fac
1207 C Calculate angular part of the gradient.
1208             call sc_grad
1209             endif
1210           enddo      ! j
1211         enddo        ! iint
1212       enddo          ! i
1213       return
1214       end
1215 C-----------------------------------------------------------------------------
1216       subroutine sc_angular
1217 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1218 C om12. Called by ebp, egb, and egbv.
1219       implicit none
1220       include 'COMMON.CALC'
1221       erij(1)=xj*rij
1222       erij(2)=yj*rij
1223       erij(3)=zj*rij
1224       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1225       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1226       om12=dxi*dxj+dyi*dyj+dzi*dzj
1227       chiom12=chi12*om12
1228 C Calculate eps1(om12) and its derivative in om12
1229       faceps1=1.0D0-om12*chiom12
1230       faceps1_inv=1.0D0/faceps1
1231       eps1=dsqrt(faceps1_inv)
1232 C Following variable is eps1*deps1/dom12
1233       eps1_om12=faceps1_inv*chiom12
1234 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1235 C and om12.
1236       om1om2=om1*om2
1237       chiom1=chi1*om1
1238       chiom2=chi2*om2
1239       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1240       sigsq=1.0D0-facsig*faceps1_inv
1241       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1242       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1243       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1244 C Calculate eps2 and its derivatives in om1, om2, and om12.
1245       chipom1=chip1*om1
1246       chipom2=chip2*om2
1247       chipom12=chip12*om12
1248       facp=1.0D0-om12*chipom12
1249       facp_inv=1.0D0/facp
1250       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1251 C Following variable is the square root of eps2
1252       eps2rt=1.0D0-facp1*facp_inv
1253 C Following three variables are the derivatives of the square root of eps
1254 C in om1, om2, and om12.
1255       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1256       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1257       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1258 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1259       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1260 C Calculate whole angle-dependent part of epsilon and contributions
1261 C to its derivatives
1262       return
1263       end
1264 C----------------------------------------------------------------------------
1265       subroutine sc_grad
1266       implicit real*8 (a-h,o-z)
1267       include 'DIMENSIONS'
1268       include 'DIMENSIONS.ZSCOPT'
1269       include 'COMMON.CHAIN'
1270       include 'COMMON.DERIV'
1271       include 'COMMON.CALC'
1272       double precision dcosom1(3),dcosom2(3)
1273       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1274       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1275       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1276      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1277       do k=1,3
1278         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1279         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1280       enddo
1281       do k=1,3
1282         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1283       enddo
1284       do k=1,3
1285         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1286      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1287      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1288         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1289      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1290      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1291       enddo
1292 C
1293 C Calculate the components of the gradient in DC and X
1294 C
1295       do k=i,j-1
1296         do l=1,3
1297           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1298         enddo
1299       enddo
1300       return
1301       end
1302 c------------------------------------------------------------------------------
1303       subroutine vec_and_deriv
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'DIMENSIONS.ZSCOPT'
1307       include 'COMMON.IOUNITS'
1308       include 'COMMON.GEO'
1309       include 'COMMON.VAR'
1310       include 'COMMON.LOCAL'
1311       include 'COMMON.CHAIN'
1312       include 'COMMON.VECTORS'
1313       include 'COMMON.DERIV'
1314       include 'COMMON.INTERACT'
1315       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1316 C Compute the local reference systems. For reference system (i), the
1317 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1318 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1319       do i=1,nres-1
1320 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1321           if (i.eq.nres-1) then
1322 C Case of the last full residue
1323 C Compute the Z-axis
1324             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1325             costh=dcos(pi-theta(nres))
1326             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1327             do k=1,3
1328               uz(k,i)=fac*uz(k,i)
1329             enddo
1330             if (calc_grad) then
1331 C Compute the derivatives of uz
1332             uzder(1,1,1)= 0.0d0
1333             uzder(2,1,1)=-dc_norm(3,i-1)
1334             uzder(3,1,1)= dc_norm(2,i-1)
1335             uzder(1,2,1)= dc_norm(3,i-1)
1336             uzder(2,2,1)= 0.0d0
1337             uzder(3,2,1)=-dc_norm(1,i-1)
1338             uzder(1,3,1)=-dc_norm(2,i-1)
1339             uzder(2,3,1)= dc_norm(1,i-1)
1340             uzder(3,3,1)= 0.0d0
1341             uzder(1,1,2)= 0.0d0
1342             uzder(2,1,2)= dc_norm(3,i)
1343             uzder(3,1,2)=-dc_norm(2,i)
1344             uzder(1,2,2)=-dc_norm(3,i)
1345             uzder(2,2,2)= 0.0d0
1346             uzder(3,2,2)= dc_norm(1,i)
1347             uzder(1,3,2)= dc_norm(2,i)
1348             uzder(2,3,2)=-dc_norm(1,i)
1349             uzder(3,3,2)= 0.0d0
1350             endif
1351 C Compute the Y-axis
1352             facy=fac
1353             do k=1,3
1354               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1355             enddo
1356             if (calc_grad) then
1357 C Compute the derivatives of uy
1358             do j=1,3
1359               do k=1,3
1360                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1361      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1362                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1363               enddo
1364               uyder(j,j,1)=uyder(j,j,1)-costh
1365               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1366             enddo
1367             do j=1,2
1368               do k=1,3
1369                 do l=1,3
1370                   uygrad(l,k,j,i)=uyder(l,k,j)
1371                   uzgrad(l,k,j,i)=uzder(l,k,j)
1372                 enddo
1373               enddo
1374             enddo
1375             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1376             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1377             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1378             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1379             endif
1380           else
1381 C Other residues
1382 C Compute the Z-axis
1383             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1384             costh=dcos(pi-theta(i+2))
1385             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1386             do k=1,3
1387               uz(k,i)=fac*uz(k,i)
1388             enddo
1389             if (calc_grad) then
1390 C Compute the derivatives of uz
1391             uzder(1,1,1)= 0.0d0
1392             uzder(2,1,1)=-dc_norm(3,i+1)
1393             uzder(3,1,1)= dc_norm(2,i+1)
1394             uzder(1,2,1)= dc_norm(3,i+1)
1395             uzder(2,2,1)= 0.0d0
1396             uzder(3,2,1)=-dc_norm(1,i+1)
1397             uzder(1,3,1)=-dc_norm(2,i+1)
1398             uzder(2,3,1)= dc_norm(1,i+1)
1399             uzder(3,3,1)= 0.0d0
1400             uzder(1,1,2)= 0.0d0
1401             uzder(2,1,2)= dc_norm(3,i)
1402             uzder(3,1,2)=-dc_norm(2,i)
1403             uzder(1,2,2)=-dc_norm(3,i)
1404             uzder(2,2,2)= 0.0d0
1405             uzder(3,2,2)= dc_norm(1,i)
1406             uzder(1,3,2)= dc_norm(2,i)
1407             uzder(2,3,2)=-dc_norm(1,i)
1408             uzder(3,3,2)= 0.0d0
1409             endif
1410 C Compute the Y-axis
1411             facy=fac
1412             do k=1,3
1413               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1414             enddo
1415             if (calc_grad) then
1416 C Compute the derivatives of uy
1417             do j=1,3
1418               do k=1,3
1419                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1420      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1421                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1422               enddo
1423               uyder(j,j,1)=uyder(j,j,1)-costh
1424               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1425             enddo
1426             do j=1,2
1427               do k=1,3
1428                 do l=1,3
1429                   uygrad(l,k,j,i)=uyder(l,k,j)
1430                   uzgrad(l,k,j,i)=uzder(l,k,j)
1431                 enddo
1432               enddo
1433             enddo
1434             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1435             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1436             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1437             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1438           endif
1439           endif
1440       enddo
1441       if (calc_grad) then
1442       do i=1,nres-1
1443         vbld_inv_temp(1)=vbld_inv(i+1)
1444         if (i.lt.nres-1) then
1445           vbld_inv_temp(2)=vbld_inv(i+2)
1446         else
1447           vbld_inv_temp(2)=vbld_inv(i)
1448         endif
1449         do j=1,2
1450           do k=1,3
1451             do l=1,3
1452               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1453               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1454             enddo
1455           enddo
1456         enddo
1457       enddo
1458       endif
1459       return
1460       end
1461 C-----------------------------------------------------------------------------
1462       subroutine vec_and_deriv_test
1463       implicit real*8 (a-h,o-z)
1464       include 'DIMENSIONS'
1465       include 'DIMENSIONS.ZSCOPT'
1466       include 'COMMON.IOUNITS'
1467       include 'COMMON.GEO'
1468       include 'COMMON.VAR'
1469       include 'COMMON.LOCAL'
1470       include 'COMMON.CHAIN'
1471       include 'COMMON.VECTORS'
1472       dimension uyder(3,3,2),uzder(3,3,2)
1473 C Compute the local reference systems. For reference system (i), the
1474 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1475 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1476       do i=1,nres-1
1477           if (i.eq.nres-1) then
1478 C Case of the last full residue
1479 C Compute the Z-axis
1480             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1481             costh=dcos(pi-theta(nres))
1482             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1483 c            write (iout,*) 'fac',fac,
1484 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1485             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1486             do k=1,3
1487               uz(k,i)=fac*uz(k,i)
1488             enddo
1489 C Compute the derivatives of uz
1490             uzder(1,1,1)= 0.0d0
1491             uzder(2,1,1)=-dc_norm(3,i-1)
1492             uzder(3,1,1)= dc_norm(2,i-1)
1493             uzder(1,2,1)= dc_norm(3,i-1)
1494             uzder(2,2,1)= 0.0d0
1495             uzder(3,2,1)=-dc_norm(1,i-1)
1496             uzder(1,3,1)=-dc_norm(2,i-1)
1497             uzder(2,3,1)= dc_norm(1,i-1)
1498             uzder(3,3,1)= 0.0d0
1499             uzder(1,1,2)= 0.0d0
1500             uzder(2,1,2)= dc_norm(3,i)
1501             uzder(3,1,2)=-dc_norm(2,i)
1502             uzder(1,2,2)=-dc_norm(3,i)
1503             uzder(2,2,2)= 0.0d0
1504             uzder(3,2,2)= dc_norm(1,i)
1505             uzder(1,3,2)= dc_norm(2,i)
1506             uzder(2,3,2)=-dc_norm(1,i)
1507             uzder(3,3,2)= 0.0d0
1508 C Compute the Y-axis
1509             do k=1,3
1510               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1511             enddo
1512             facy=fac
1513             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1514      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1515      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1516             do k=1,3
1517 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1518               uy(k,i)=
1519 c     &        facy*(
1520      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1521      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1522 c     &        )
1523             enddo
1524 c            write (iout,*) 'facy',facy,
1525 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1526             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1527             do k=1,3
1528               uy(k,i)=facy*uy(k,i)
1529             enddo
1530 C Compute the derivatives of uy
1531             do j=1,3
1532               do k=1,3
1533                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1534      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1535                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1536               enddo
1537 c              uyder(j,j,1)=uyder(j,j,1)-costh
1538 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1539               uyder(j,j,1)=uyder(j,j,1)
1540      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1541               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1542      &          +uyder(j,j,2)
1543             enddo
1544             do j=1,2
1545               do k=1,3
1546                 do l=1,3
1547                   uygrad(l,k,j,i)=uyder(l,k,j)
1548                   uzgrad(l,k,j,i)=uzder(l,k,j)
1549                 enddo
1550               enddo
1551             enddo
1552             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1553             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1554             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1555             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1556           else
1557 C Other residues
1558 C Compute the Z-axis
1559             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1560             costh=dcos(pi-theta(i+2))
1561             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1562             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1563             do k=1,3
1564               uz(k,i)=fac*uz(k,i)
1565             enddo
1566 C Compute the derivatives of uz
1567             uzder(1,1,1)= 0.0d0
1568             uzder(2,1,1)=-dc_norm(3,i+1)
1569             uzder(3,1,1)= dc_norm(2,i+1)
1570             uzder(1,2,1)= dc_norm(3,i+1)
1571             uzder(2,2,1)= 0.0d0
1572             uzder(3,2,1)=-dc_norm(1,i+1)
1573             uzder(1,3,1)=-dc_norm(2,i+1)
1574             uzder(2,3,1)= dc_norm(1,i+1)
1575             uzder(3,3,1)= 0.0d0
1576             uzder(1,1,2)= 0.0d0
1577             uzder(2,1,2)= dc_norm(3,i)
1578             uzder(3,1,2)=-dc_norm(2,i)
1579             uzder(1,2,2)=-dc_norm(3,i)
1580             uzder(2,2,2)= 0.0d0
1581             uzder(3,2,2)= dc_norm(1,i)
1582             uzder(1,3,2)= dc_norm(2,i)
1583             uzder(2,3,2)=-dc_norm(1,i)
1584             uzder(3,3,2)= 0.0d0
1585 C Compute the Y-axis
1586             facy=fac
1587             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1588      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1589      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1590             do k=1,3
1591 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1592               uy(k,i)=
1593 c     &        facy*(
1594      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1595      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1596 c     &        )
1597             enddo
1598 c            write (iout,*) 'facy',facy,
1599 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1600             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1601             do k=1,3
1602               uy(k,i)=facy*uy(k,i)
1603             enddo
1604 C Compute the derivatives of uy
1605             do j=1,3
1606               do k=1,3
1607                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1608      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1609                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1610               enddo
1611 c              uyder(j,j,1)=uyder(j,j,1)-costh
1612 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1613               uyder(j,j,1)=uyder(j,j,1)
1614      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1615               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1616      &          +uyder(j,j,2)
1617             enddo
1618             do j=1,2
1619               do k=1,3
1620                 do l=1,3
1621                   uygrad(l,k,j,i)=uyder(l,k,j)
1622                   uzgrad(l,k,j,i)=uzder(l,k,j)
1623                 enddo
1624               enddo
1625             enddo
1626             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1627             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1628             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1629             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1630           endif
1631       enddo
1632       do i=1,nres-1
1633         do j=1,2
1634           do k=1,3
1635             do l=1,3
1636               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1637               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1638             enddo
1639           enddo
1640         enddo
1641       enddo
1642       return
1643       end
1644 C-----------------------------------------------------------------------------
1645       subroutine check_vecgrad
1646       implicit real*8 (a-h,o-z)
1647       include 'DIMENSIONS'
1648       include 'DIMENSIONS.ZSCOPT'
1649       include 'COMMON.IOUNITS'
1650       include 'COMMON.GEO'
1651       include 'COMMON.VAR'
1652       include 'COMMON.LOCAL'
1653       include 'COMMON.CHAIN'
1654       include 'COMMON.VECTORS'
1655       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1656       dimension uyt(3,maxres),uzt(3,maxres)
1657       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1658       double precision delta /1.0d-7/
1659       call vec_and_deriv
1660 cd      do i=1,nres
1661 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1662 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1663 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1664 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1665 cd     &     (dc_norm(if90,i),if90=1,3)
1666 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1667 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1668 cd          write(iout,'(a)')
1669 cd      enddo
1670       do i=1,nres
1671         do j=1,2
1672           do k=1,3
1673             do l=1,3
1674               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1675               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1676             enddo
1677           enddo
1678         enddo
1679       enddo
1680       call vec_and_deriv
1681       do i=1,nres
1682         do j=1,3
1683           uyt(j,i)=uy(j,i)
1684           uzt(j,i)=uz(j,i)
1685         enddo
1686       enddo
1687       do i=1,nres
1688 cd        write (iout,*) 'i=',i
1689         do k=1,3
1690           erij(k)=dc_norm(k,i)
1691         enddo
1692         do j=1,3
1693           do k=1,3
1694             dc_norm(k,i)=erij(k)
1695           enddo
1696           dc_norm(j,i)=dc_norm(j,i)+delta
1697 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1698 c          do k=1,3
1699 c            dc_norm(k,i)=dc_norm(k,i)/fac
1700 c          enddo
1701 c          write (iout,*) (dc_norm(k,i),k=1,3)
1702 c          write (iout,*) (erij(k),k=1,3)
1703           call vec_and_deriv
1704           do k=1,3
1705             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1706             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1707             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1708             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1709           enddo
1710 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1711 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1712 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1713         enddo
1714         do k=1,3
1715           dc_norm(k,i)=erij(k)
1716         enddo
1717 cd        do k=1,3
1718 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1719 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1720 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1721 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1722 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1723 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1724 cd          write (iout,'(a)')
1725 cd        enddo
1726       enddo
1727       return
1728       end
1729 C--------------------------------------------------------------------------
1730       subroutine set_matrices
1731       implicit real*8 (a-h,o-z)
1732       include 'DIMENSIONS'
1733       include 'DIMENSIONS.ZSCOPT'
1734       include 'COMMON.IOUNITS'
1735       include 'COMMON.GEO'
1736       include 'COMMON.VAR'
1737       include 'COMMON.LOCAL'
1738       include 'COMMON.CHAIN'
1739       include 'COMMON.DERIV'
1740       include 'COMMON.INTERACT'
1741       include 'COMMON.CONTACTS'
1742       include 'COMMON.TORSION'
1743       include 'COMMON.VECTORS'
1744       include 'COMMON.FFIELD'
1745       double precision auxvec(2),auxmat(2,2)
1746 C
1747 C Compute the virtual-bond-torsional-angle dependent quantities needed
1748 C to calculate the el-loc multibody terms of various order.
1749 C
1750       do i=3,nres+1
1751         if (i .lt. nres+1) then
1752           sin1=dsin(phi(i))
1753           cos1=dcos(phi(i))
1754           sintab(i-2)=sin1
1755           costab(i-2)=cos1
1756           obrot(1,i-2)=cos1
1757           obrot(2,i-2)=sin1
1758           sin2=dsin(2*phi(i))
1759           cos2=dcos(2*phi(i))
1760           sintab2(i-2)=sin2
1761           costab2(i-2)=cos2
1762           obrot2(1,i-2)=cos2
1763           obrot2(2,i-2)=sin2
1764           Ug(1,1,i-2)=-cos1
1765           Ug(1,2,i-2)=-sin1
1766           Ug(2,1,i-2)=-sin1
1767           Ug(2,2,i-2)= cos1
1768           Ug2(1,1,i-2)=-cos2
1769           Ug2(1,2,i-2)=-sin2
1770           Ug2(2,1,i-2)=-sin2
1771           Ug2(2,2,i-2)= cos2
1772         else
1773           costab(i-2)=1.0d0
1774           sintab(i-2)=0.0d0
1775           obrot(1,i-2)=1.0d0
1776           obrot(2,i-2)=0.0d0
1777           obrot2(1,i-2)=0.0d0
1778           obrot2(2,i-2)=0.0d0
1779           Ug(1,1,i-2)=1.0d0
1780           Ug(1,2,i-2)=0.0d0
1781           Ug(2,1,i-2)=0.0d0
1782           Ug(2,2,i-2)=1.0d0
1783           Ug2(1,1,i-2)=0.0d0
1784           Ug2(1,2,i-2)=0.0d0
1785           Ug2(2,1,i-2)=0.0d0
1786           Ug2(2,2,i-2)=0.0d0
1787         endif
1788         if (i .gt. 3 .and. i .lt. nres+1) then
1789           obrot_der(1,i-2)=-sin1
1790           obrot_der(2,i-2)= cos1
1791           Ugder(1,1,i-2)= sin1
1792           Ugder(1,2,i-2)=-cos1
1793           Ugder(2,1,i-2)=-cos1
1794           Ugder(2,2,i-2)=-sin1
1795           dwacos2=cos2+cos2
1796           dwasin2=sin2+sin2
1797           obrot2_der(1,i-2)=-dwasin2
1798           obrot2_der(2,i-2)= dwacos2
1799           Ug2der(1,1,i-2)= dwasin2
1800           Ug2der(1,2,i-2)=-dwacos2
1801           Ug2der(2,1,i-2)=-dwacos2
1802           Ug2der(2,2,i-2)=-dwasin2
1803         else
1804           obrot_der(1,i-2)=0.0d0
1805           obrot_der(2,i-2)=0.0d0
1806           Ugder(1,1,i-2)=0.0d0
1807           Ugder(1,2,i-2)=0.0d0
1808           Ugder(2,1,i-2)=0.0d0
1809           Ugder(2,2,i-2)=0.0d0
1810           obrot2_der(1,i-2)=0.0d0
1811           obrot2_der(2,i-2)=0.0d0
1812           Ug2der(1,1,i-2)=0.0d0
1813           Ug2der(1,2,i-2)=0.0d0
1814           Ug2der(2,1,i-2)=0.0d0
1815           Ug2der(2,2,i-2)=0.0d0
1816         endif
1817         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1818           if (itype(i-2).le.ntyp) then
1819             iti = itortyp(itype(i-2))
1820           else
1821             iti=ntortyp+1
1822           endif
1823         else
1824           iti=ntortyp+1
1825         endif
1826         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1827           if (itype(i-1).le.ntyp) then
1828             iti1 = itortyp(itype(i-1))
1829           else
1830             iti1=ntortyp+1
1831           endif
1832         else
1833           iti1=ntortyp+1
1834         endif
1835 cd        write (iout,*) '*******i',i,' iti1',iti
1836 cd        write (iout,*) 'b1',b1(:,iti)
1837 cd        write (iout,*) 'b2',b2(:,iti)
1838 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1839 c        print *,"itilde1 i iti iti1",i,iti,iti1
1840         if (i .gt. iatel_s+2) then
1841           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1842           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1843           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1844           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1845           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1846           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1847           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1848         else
1849           do k=1,2
1850             Ub2(k,i-2)=0.0d0
1851             Ctobr(k,i-2)=0.0d0
1852             Dtobr2(k,i-2)=0.0d0
1853             do l=1,2
1854               EUg(l,k,i-2)=0.0d0
1855               CUg(l,k,i-2)=0.0d0
1856               DUg(l,k,i-2)=0.0d0
1857               DtUg2(l,k,i-2)=0.0d0
1858             enddo
1859           enddo
1860         endif
1861 c        print *,"itilde2 i iti iti1",i,iti,iti1
1862         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1863         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1864         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1865         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1866         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1867         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1868         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1869 c        print *,"itilde3 i iti iti1",i,iti,iti1
1870         do k=1,2
1871           muder(k,i-2)=Ub2der(k,i-2)
1872         enddo
1873         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1874           if (itype(i-1).le.ntyp) then
1875             iti1 = itortyp(itype(i-1))
1876           else
1877             iti1=ntortyp+1
1878           endif
1879         else
1880           iti1=ntortyp+1
1881         endif
1882         do k=1,2
1883           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1884         enddo
1885 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
1886
1887 C Vectors and matrices dependent on a single virtual-bond dihedral.
1888         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1889         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1890         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1891         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1892         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1893         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1894         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1895         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1896         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1897 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1898 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1899       enddo
1900 C Matrices dependent on two consecutive virtual-bond dihedrals.
1901 C The order of matrices is from left to right.
1902       do i=2,nres-1
1903         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1904         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1905         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1906         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1907         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1908         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1909         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1910         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1911       enddo
1912 cd      do i=1,nres
1913 cd        iti = itortyp(itype(i))
1914 cd        write (iout,*) i
1915 cd        do j=1,2
1916 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1917 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1918 cd        enddo
1919 cd      enddo
1920       return
1921       end
1922 C--------------------------------------------------------------------------
1923       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1924 C
1925 C This subroutine calculates the average interaction energy and its gradient
1926 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1927 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1928 C The potential depends both on the distance of peptide-group centers and on
1929 C the orientation of the CA-CA virtual bonds.
1930 C
1931       implicit real*8 (a-h,o-z)
1932       include 'DIMENSIONS'
1933       include 'DIMENSIONS.ZSCOPT'
1934       include 'COMMON.CONTROL'
1935       include 'COMMON.IOUNITS'
1936       include 'COMMON.GEO'
1937       include 'COMMON.VAR'
1938       include 'COMMON.LOCAL'
1939       include 'COMMON.CHAIN'
1940       include 'COMMON.DERIV'
1941       include 'COMMON.INTERACT'
1942       include 'COMMON.CONTACTS'
1943       include 'COMMON.TORSION'
1944       include 'COMMON.VECTORS'
1945       include 'COMMON.FFIELD'
1946       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1947      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1948       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1949      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1950       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1951 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1952       double precision scal_el /0.5d0/
1953 C 12/13/98
1954 C 13-go grudnia roku pamietnego...
1955       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1956      &                   0.0d0,1.0d0,0.0d0,
1957      &                   0.0d0,0.0d0,1.0d0/
1958 cd      write(iout,*) 'In EELEC'
1959 cd      do i=1,nloctyp
1960 cd        write(iout,*) 'Type',i
1961 cd        write(iout,*) 'B1',B1(:,i)
1962 cd        write(iout,*) 'B2',B2(:,i)
1963 cd        write(iout,*) 'CC',CC(:,:,i)
1964 cd        write(iout,*) 'DD',DD(:,:,i)
1965 cd        write(iout,*) 'EE',EE(:,:,i)
1966 cd      enddo
1967 cd      call check_vecgrad
1968 cd      stop
1969       if (icheckgrad.eq.1) then
1970         do i=1,nres-1
1971           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1972           do k=1,3
1973             dc_norm(k,i)=dc(k,i)*fac
1974           enddo
1975 c          write (iout,*) 'i',i,' fac',fac
1976         enddo
1977       endif
1978       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1979      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1980      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1981 cd      if (wel_loc.gt.0.0d0) then
1982         if (icheckgrad.eq.1) then
1983         call vec_and_deriv_test
1984         else
1985         call vec_and_deriv
1986         endif
1987         call set_matrices
1988       endif
1989 cd      do i=1,nres-1
1990 cd        write (iout,*) 'i=',i
1991 cd        do k=1,3
1992 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1993 cd        enddo
1994 cd        do k=1,3
1995 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1996 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1997 cd        enddo
1998 cd      enddo
1999       num_conti_hb=0
2000       ees=0.0D0
2001       evdw1=0.0D0
2002       eel_loc=0.0d0
2003       eello_turn3=0.0d0
2004       eello_turn4=0.0d0
2005       ind=0
2006       do i=1,nres
2007         num_cont_hb(i)=0
2008       enddo
2009 C      print '(a)','Enter EELEC'
2010 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2011       do i=1,nres
2012         gel_loc_loc(i)=0.0d0
2013         gcorr_loc(i)=0.0d0
2014       enddo
2015       do i=iatel_s,iatel_e
2016           if (i.eq.1) then
2017            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2018      &  .or. itype(i+2).eq.ntyp1) cycle
2019           else
2020         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2021      &  .or. itype(i+2).eq.ntyp1
2022      &  .or. itype(i-1).eq.ntyp1
2023      &) cycle
2024          endif
2025         if (itel(i).eq.0) goto 1215
2026         dxi=dc(1,i)
2027         dyi=dc(2,i)
2028         dzi=dc(3,i)
2029         dx_normi=dc_norm(1,i)
2030         dy_normi=dc_norm(2,i)
2031         dz_normi=dc_norm(3,i)
2032         xmedi=c(1,i)+0.5d0*dxi
2033         ymedi=c(2,i)+0.5d0*dyi
2034         zmedi=c(3,i)+0.5d0*dzi
2035           xmedi=mod(xmedi,boxxsize)
2036           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2037           ymedi=mod(ymedi,boxysize)
2038           if (ymedi.lt.0) ymedi=ymedi+boxysize
2039           zmedi=mod(zmedi,boxzsize)
2040           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2041         num_conti=0
2042 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2043         do j=ielstart(i),ielend(i)
2044           if (j.eq.1) then
2045            if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2046      & .or.itype(j+2).eq.ntyp1
2047      &) cycle
2048           else
2049           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2050      & .or.itype(j+2).eq.ntyp1
2051      & .or.itype(j-1).eq.ntyp1
2052      &) cycle
2053          endif
2054 C
2055 C) cycle
2056           if (itel(j).eq.0) goto 1216
2057           ind=ind+1
2058           iteli=itel(i)
2059           itelj=itel(j)
2060           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2061           aaa=app(iteli,itelj)
2062           bbb=bpp(iteli,itelj)
2063 C Diagnostics only!!!
2064 c         aaa=0.0D0
2065 c         bbb=0.0D0
2066 c         ael6i=0.0D0
2067 c         ael3i=0.0D0
2068 C End diagnostics
2069           ael6i=ael6(iteli,itelj)
2070           ael3i=ael3(iteli,itelj)
2071           dxj=dc(1,j)
2072           dyj=dc(2,j)
2073           dzj=dc(3,j)
2074           dx_normj=dc_norm(1,j)
2075           dy_normj=dc_norm(2,j)
2076           dz_normj=dc_norm(3,j)
2077           xj=c(1,j)+0.5D0*dxj
2078           yj=c(2,j)+0.5D0*dyj
2079           zj=c(3,j)+0.5D0*dzj
2080          xj=mod(xj,boxxsize)
2081           if (xj.lt.0) xj=xj+boxxsize
2082           yj=mod(yj,boxysize)
2083           if (yj.lt.0) yj=yj+boxysize
2084           zj=mod(zj,boxzsize)
2085           if (zj.lt.0) zj=zj+boxzsize
2086       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2087       xj_safe=xj
2088       yj_safe=yj
2089       zj_safe=zj
2090       isubchap=0
2091       do xshift=-1,1
2092       do yshift=-1,1
2093       do zshift=-1,1
2094           xj=xj_safe+xshift*boxxsize
2095           yj=yj_safe+yshift*boxysize
2096           zj=zj_safe+zshift*boxzsize
2097           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2098           if(dist_temp.lt.dist_init) then
2099             dist_init=dist_temp
2100             xj_temp=xj
2101             yj_temp=yj
2102             zj_temp=zj
2103             isubchap=1
2104           endif
2105        enddo
2106        enddo
2107        enddo
2108        if (isubchap.eq.1) then
2109           xj=xj_temp-xmedi
2110           yj=yj_temp-ymedi
2111           zj=zj_temp-zmedi
2112        else
2113           xj=xj_safe-xmedi
2114           yj=yj_safe-ymedi
2115           zj=zj_safe-zmedi
2116        endif
2117           rij=xj*xj+yj*yj+zj*zj
2118             sss=sscale(sqrt(rij))
2119             sssgrad=sscagrad(sqrt(rij))
2120           rrmij=1.0D0/rij
2121           rij=dsqrt(rij)
2122           rmij=1.0D0/rij
2123           r3ij=rrmij*rmij
2124           r6ij=r3ij*r3ij
2125           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2126           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2127           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2128           fac=cosa-3.0D0*cosb*cosg
2129           ev1=aaa*r6ij*r6ij
2130 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2131           if (j.eq.i+2) ev1=scal_el*ev1
2132           ev2=bbb*r6ij
2133           fac3=ael6i*r6ij
2134           fac4=ael3i*r3ij
2135           evdwij=ev1+ev2
2136           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2137           el2=fac4*fac
2138           eesij=el1+el2
2139 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2140 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2141           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2142           ees=ees+eesij
2143           evdw1=evdw1+evdwij*sss
2144 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2145 c     &'evdw1',i,j,evdwij
2146 c     &,iteli,itelj,aaa,evdw1
2147
2148 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2149 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2150 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2151 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2152 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2153 C
2154 C Calculate contributions to the Cartesian gradient.
2155 C
2156 #ifdef SPLITELE
2157           facvdw=-6*rrmij*(ev1+evdwij)*sss
2158           facel=-3*rrmij*(el1+eesij)
2159           fac1=fac
2160           erij(1)=xj*rmij
2161           erij(2)=yj*rmij
2162           erij(3)=zj*rmij
2163           if (calc_grad) then
2164 *
2165 * Radial derivatives. First process both termini of the fragment (i,j)
2166 *
2167           ggg(1)=facel*xj
2168           ggg(2)=facel*yj
2169           ggg(3)=facel*zj
2170           do k=1,3
2171             ghalf=0.5D0*ggg(k)
2172             gelc(k,i)=gelc(k,i)+ghalf
2173             gelc(k,j)=gelc(k,j)+ghalf
2174           enddo
2175 *
2176 * Loop over residues i+1 thru j-1.
2177 *
2178           do k=i+1,j-1
2179             do l=1,3
2180               gelc(l,k)=gelc(l,k)+ggg(l)
2181             enddo
2182           enddo
2183 C          ggg(1)=facvdw*xj
2184 C          ggg(2)=facvdw*yj
2185 C          ggg(3)=facvdw*zj
2186           if (sss.gt.0.0) then
2187           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2188           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2189           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2190           else
2191           ggg(1)=0.0
2192           ggg(2)=0.0
2193           ggg(3)=0.0
2194           endif
2195           do k=1,3
2196             ghalf=0.5D0*ggg(k)
2197             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2198             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2199           enddo
2200 *
2201 * Loop over residues i+1 thru j-1.
2202 *
2203           do k=i+1,j-1
2204             do l=1,3
2205               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2206             enddo
2207           enddo
2208 #else
2209           facvdw=(ev1+evdwij)*sss
2210           facel=el1+eesij
2211           fac1=fac
2212           fac=-3*rrmij*(facvdw+facvdw+facel)
2213           erij(1)=xj*rmij
2214           erij(2)=yj*rmij
2215           erij(3)=zj*rmij
2216           if (calc_grad) then
2217 *
2218 * Radial derivatives. First process both termini of the fragment (i,j)
2219 *
2220           ggg(1)=fac*xj
2221           ggg(2)=fac*yj
2222           ggg(3)=fac*zj
2223           do k=1,3
2224             ghalf=0.5D0*ggg(k)
2225             gelc(k,i)=gelc(k,i)+ghalf
2226             gelc(k,j)=gelc(k,j)+ghalf
2227           enddo
2228 *
2229 * Loop over residues i+1 thru j-1.
2230 *
2231           do k=i+1,j-1
2232             do l=1,3
2233               gelc(l,k)=gelc(l,k)+ggg(l)
2234             enddo
2235           enddo
2236 #endif
2237 *
2238 * Angular part
2239 *
2240           ecosa=2.0D0*fac3*fac1+fac4
2241           fac4=-3.0D0*fac4
2242           fac3=-6.0D0*fac3
2243           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2244           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2245           do k=1,3
2246             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2247             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2248           enddo
2249 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2250 cd   &          (dcosg(k),k=1,3)
2251           do k=1,3
2252             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2253           enddo
2254           do k=1,3
2255             ghalf=0.5D0*ggg(k)
2256             gelc(k,i)=gelc(k,i)+ghalf
2257      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2258      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2259             gelc(k,j)=gelc(k,j)+ghalf
2260      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2261      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2262           enddo
2263           do k=i+1,j-1
2264             do l=1,3
2265               gelc(l,k)=gelc(l,k)+ggg(l)
2266             enddo
2267           enddo
2268           endif
2269
2270           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2271      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2272      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2273 C
2274 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2275 C   energy of a peptide unit is assumed in the form of a second-order
2276 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2277 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2278 C   are computed for EVERY pair of non-contiguous peptide groups.
2279 C
2280           if (j.lt.nres-1) then
2281             j1=j+1
2282             j2=j-1
2283           else
2284             j1=j-1
2285             j2=j-2
2286           endif
2287           kkk=0
2288           do k=1,2
2289             do l=1,2
2290               kkk=kkk+1
2291               muij(kkk)=mu(k,i)*mu(l,j)
2292             enddo
2293           enddo
2294 cd         write (iout,*) 'EELEC: i',i,' j',j
2295 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2296 cd          write(iout,*) 'muij',muij
2297           ury=scalar(uy(1,i),erij)
2298           urz=scalar(uz(1,i),erij)
2299           vry=scalar(uy(1,j),erij)
2300           vrz=scalar(uz(1,j),erij)
2301           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2302           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2303           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2304           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2305 C For diagnostics only
2306 cd          a22=1.0d0
2307 cd          a23=1.0d0
2308 cd          a32=1.0d0
2309 cd          a33=1.0d0
2310           fac=dsqrt(-ael6i)*r3ij
2311 cd          write (2,*) 'fac=',fac
2312 C For diagnostics only
2313 cd          fac=1.0d0
2314           a22=a22*fac
2315           a23=a23*fac
2316           a32=a32*fac
2317           a33=a33*fac
2318 cd          write (iout,'(4i5,4f10.5)')
2319 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2320 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2321 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2322 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2323 cd          write (iout,'(4f10.5)')
2324 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2325 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2326 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2327 cd           write (iout,'(2i3,9f10.5/)') i,j,
2328 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2329           if (calc_grad) then
2330 C Derivatives of the elements of A in virtual-bond vectors
2331           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2332 cd          do k=1,3
2333 cd            do l=1,3
2334 cd              erder(k,l)=0.0d0
2335 cd            enddo
2336 cd          enddo
2337           do k=1,3
2338             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2339             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2340             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2341             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2342             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2343             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2344             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2345             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2346             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2347             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2348             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2349             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2350           enddo
2351 cd          do k=1,3
2352 cd            do l=1,3
2353 cd              uryg(k,l)=0.0d0
2354 cd              urzg(k,l)=0.0d0
2355 cd              vryg(k,l)=0.0d0
2356 cd              vrzg(k,l)=0.0d0
2357 cd            enddo
2358 cd          enddo
2359 C Compute radial contributions to the gradient
2360           facr=-3.0d0*rrmij
2361           a22der=a22*facr
2362           a23der=a23*facr
2363           a32der=a32*facr
2364           a33der=a33*facr
2365 cd          a22der=0.0d0
2366 cd          a23der=0.0d0
2367 cd          a32der=0.0d0
2368 cd          a33der=0.0d0
2369           agg(1,1)=a22der*xj
2370           agg(2,1)=a22der*yj
2371           agg(3,1)=a22der*zj
2372           agg(1,2)=a23der*xj
2373           agg(2,2)=a23der*yj
2374           agg(3,2)=a23der*zj
2375           agg(1,3)=a32der*xj
2376           agg(2,3)=a32der*yj
2377           agg(3,3)=a32der*zj
2378           agg(1,4)=a33der*xj
2379           agg(2,4)=a33der*yj
2380           agg(3,4)=a33der*zj
2381 C Add the contributions coming from er
2382           fac3=-3.0d0*fac
2383           do k=1,3
2384             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2385             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2386             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2387             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2388           enddo
2389           do k=1,3
2390 C Derivatives in DC(i)
2391             ghalf1=0.5d0*agg(k,1)
2392             ghalf2=0.5d0*agg(k,2)
2393             ghalf3=0.5d0*agg(k,3)
2394             ghalf4=0.5d0*agg(k,4)
2395             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2396      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2397             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2398      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2399             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2400      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2401             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2402      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2403 C Derivatives in DC(i+1)
2404             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2405      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2406             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2407      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2408             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2409      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2410             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2411      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2412 C Derivatives in DC(j)
2413             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2414      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2415             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2416      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2417             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2418      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2419             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2420      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2421 C Derivatives in DC(j+1) or DC(nres-1)
2422             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2423      &      -3.0d0*vryg(k,3)*ury)
2424             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2425      &      -3.0d0*vrzg(k,3)*ury)
2426             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2427      &      -3.0d0*vryg(k,3)*urz)
2428             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2429      &      -3.0d0*vrzg(k,3)*urz)
2430 cd            aggi(k,1)=ghalf1
2431 cd            aggi(k,2)=ghalf2
2432 cd            aggi(k,3)=ghalf3
2433 cd            aggi(k,4)=ghalf4
2434 C Derivatives in DC(i+1)
2435 cd            aggi1(k,1)=agg(k,1)
2436 cd            aggi1(k,2)=agg(k,2)
2437 cd            aggi1(k,3)=agg(k,3)
2438 cd            aggi1(k,4)=agg(k,4)
2439 C Derivatives in DC(j)
2440 cd            aggj(k,1)=ghalf1
2441 cd            aggj(k,2)=ghalf2
2442 cd            aggj(k,3)=ghalf3
2443 cd            aggj(k,4)=ghalf4
2444 C Derivatives in DC(j+1)
2445 cd            aggj1(k,1)=0.0d0
2446 cd            aggj1(k,2)=0.0d0
2447 cd            aggj1(k,3)=0.0d0
2448 cd            aggj1(k,4)=0.0d0
2449             if (j.eq.nres-1 .and. i.lt.j-2) then
2450               do l=1,4
2451                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2452 cd                aggj1(k,l)=agg(k,l)
2453               enddo
2454             endif
2455           enddo
2456           endif
2457 c          goto 11111
2458 C Check the loc-el terms by numerical integration
2459           acipa(1,1)=a22
2460           acipa(1,2)=a23
2461           acipa(2,1)=a32
2462           acipa(2,2)=a33
2463           a22=-a22
2464           a23=-a23
2465           do l=1,2
2466             do k=1,3
2467               agg(k,l)=-agg(k,l)
2468               aggi(k,l)=-aggi(k,l)
2469               aggi1(k,l)=-aggi1(k,l)
2470               aggj(k,l)=-aggj(k,l)
2471               aggj1(k,l)=-aggj1(k,l)
2472             enddo
2473           enddo
2474           if (j.lt.nres-1) then
2475             a22=-a22
2476             a32=-a32
2477             do l=1,3,2
2478               do k=1,3
2479                 agg(k,l)=-agg(k,l)
2480                 aggi(k,l)=-aggi(k,l)
2481                 aggi1(k,l)=-aggi1(k,l)
2482                 aggj(k,l)=-aggj(k,l)
2483                 aggj1(k,l)=-aggj1(k,l)
2484               enddo
2485             enddo
2486           else
2487             a22=-a22
2488             a23=-a23
2489             a32=-a32
2490             a33=-a33
2491             do l=1,4
2492               do k=1,3
2493                 agg(k,l)=-agg(k,l)
2494                 aggi(k,l)=-aggi(k,l)
2495                 aggi1(k,l)=-aggi1(k,l)
2496                 aggj(k,l)=-aggj(k,l)
2497                 aggj1(k,l)=-aggj1(k,l)
2498               enddo
2499             enddo
2500           endif
2501           ENDIF ! WCORR
2502 11111     continue
2503           IF (wel_loc.gt.0.0d0) THEN
2504 C Contribution to the local-electrostatic energy coming from the i-j pair
2505           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2506      &     +a33*muij(4)
2507 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2508 C          write (iout,'(a6,2i5,0pf7.3)')
2509 C     &            'eelloc',i,j,eel_loc_ij
2510 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2511 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2512           eel_loc=eel_loc+eel_loc_ij
2513 C Partial derivatives in virtual-bond dihedral angles gamma
2514           if (calc_grad) then
2515           if (i.gt.1)
2516      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2517      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2518      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2519           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2520      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2521      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2522 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2523 cd          write(iout,*) 'agg  ',agg
2524 cd          write(iout,*) 'aggi ',aggi
2525 cd          write(iout,*) 'aggi1',aggi1
2526 cd          write(iout,*) 'aggj ',aggj
2527 cd          write(iout,*) 'aggj1',aggj1
2528
2529 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2530           do l=1,3
2531             ggg(l)=agg(l,1)*muij(1)+
2532      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2533           enddo
2534           do k=i+2,j2
2535             do l=1,3
2536               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2537             enddo
2538           enddo
2539 C Remaining derivatives of eello
2540           do l=1,3
2541             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2542      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2543             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2544      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2545             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2546      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2547             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2548      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2549           enddo
2550           endif
2551           ENDIF
2552           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2553 C Contributions from turns
2554             a_temp(1,1)=a22
2555             a_temp(1,2)=a23
2556             a_temp(2,1)=a32
2557             a_temp(2,2)=a33
2558             call eturn34(i,j,eello_turn3,eello_turn4)
2559           endif
2560 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2561           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2562 C
2563 C Calculate the contact function. The ith column of the array JCONT will
2564 C contain the numbers of atoms that make contacts with the atom I (of numbers
2565 C greater than I). The arrays FACONT and GACONT will contain the values of
2566 C the contact function and its derivative.
2567 c           r0ij=1.02D0*rpp(iteli,itelj)
2568 c           r0ij=1.11D0*rpp(iteli,itelj)
2569             r0ij=2.20D0*rpp(iteli,itelj)
2570 c           r0ij=1.55D0*rpp(iteli,itelj)
2571             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2572             if (fcont.gt.0.0D0) then
2573               num_conti=num_conti+1
2574               if (num_conti.gt.maxconts) then
2575                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2576      &                         ' will skip next contacts for this conf.'
2577               else
2578                 jcont_hb(num_conti,i)=j
2579                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2580      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2581 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2582 C  terms.
2583                 d_cont(num_conti,i)=rij
2584 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2585 C     --- Electrostatic-interaction matrix ---
2586                 a_chuj(1,1,num_conti,i)=a22
2587                 a_chuj(1,2,num_conti,i)=a23
2588                 a_chuj(2,1,num_conti,i)=a32
2589                 a_chuj(2,2,num_conti,i)=a33
2590 C     --- Gradient of rij
2591                 do kkk=1,3
2592                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2593                 enddo
2594 c             if (i.eq.1) then
2595 c                a_chuj(1,1,num_conti,i)=-0.61d0
2596 c                a_chuj(1,2,num_conti,i)= 0.4d0
2597 c                a_chuj(2,1,num_conti,i)= 0.65d0
2598 c                a_chuj(2,2,num_conti,i)= 0.50d0
2599 c             else if (i.eq.2) then
2600 c                a_chuj(1,1,num_conti,i)= 0.0d0
2601 c                a_chuj(1,2,num_conti,i)= 0.0d0
2602 c                a_chuj(2,1,num_conti,i)= 0.0d0
2603 c                a_chuj(2,2,num_conti,i)= 0.0d0
2604 c             endif
2605 C     --- and its gradients
2606 cd                write (iout,*) 'i',i,' j',j
2607 cd                do kkk=1,3
2608 cd                write (iout,*) 'iii 1 kkk',kkk
2609 cd                write (iout,*) agg(kkk,:)
2610 cd                enddo
2611 cd                do kkk=1,3
2612 cd                write (iout,*) 'iii 2 kkk',kkk
2613 cd                write (iout,*) aggi(kkk,:)
2614 cd                enddo
2615 cd                do kkk=1,3
2616 cd                write (iout,*) 'iii 3 kkk',kkk
2617 cd                write (iout,*) aggi1(kkk,:)
2618 cd                enddo
2619 cd                do kkk=1,3
2620 cd                write (iout,*) 'iii 4 kkk',kkk
2621 cd                write (iout,*) aggj(kkk,:)
2622 cd                enddo
2623 cd                do kkk=1,3
2624 cd                write (iout,*) 'iii 5 kkk',kkk
2625 cd                write (iout,*) aggj1(kkk,:)
2626 cd                enddo
2627                 kkll=0
2628                 do k=1,2
2629                   do l=1,2
2630                     kkll=kkll+1
2631                     do m=1,3
2632                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2633                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2634                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2635                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2636                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2637 c                      do mm=1,5
2638 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2639 c                      enddo
2640                     enddo
2641                   enddo
2642                 enddo
2643                 ENDIF
2644                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2645 C Calculate contact energies
2646                 cosa4=4.0D0*cosa
2647                 wij=cosa-3.0D0*cosb*cosg
2648                 cosbg1=cosb+cosg
2649                 cosbg2=cosb-cosg
2650 c               fac3=dsqrt(-ael6i)/r0ij**3
2651                 fac3=dsqrt(-ael6i)*r3ij
2652                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2653                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2654 c               ees0mij=0.0D0
2655                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2656                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2657 C Diagnostics. Comment out or remove after debugging!
2658 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2659 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2660 c               ees0m(num_conti,i)=0.0D0
2661 C End diagnostics.
2662 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2663 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2664                 facont_hb(num_conti,i)=fcont
2665                 if (calc_grad) then
2666 C Angular derivatives of the contact function
2667                 ees0pij1=fac3/ees0pij
2668                 ees0mij1=fac3/ees0mij
2669                 fac3p=-3.0D0*fac3*rrmij
2670                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2671                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2672 c               ees0mij1=0.0D0
2673                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2674                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2675                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2676                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2677                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2678                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2679                 ecosap=ecosa1+ecosa2
2680                 ecosbp=ecosb1+ecosb2
2681                 ecosgp=ecosg1+ecosg2
2682                 ecosam=ecosa1-ecosa2
2683                 ecosbm=ecosb1-ecosb2
2684                 ecosgm=ecosg1-ecosg2
2685 C Diagnostics
2686 c               ecosap=ecosa1
2687 c               ecosbp=ecosb1
2688 c               ecosgp=ecosg1
2689 c               ecosam=0.0D0
2690 c               ecosbm=0.0D0
2691 c               ecosgm=0.0D0
2692 C End diagnostics
2693                 fprimcont=fprimcont/rij
2694 cd              facont_hb(num_conti,i)=1.0D0
2695 C Following line is for diagnostics.
2696 cd              fprimcont=0.0D0
2697                 do k=1,3
2698                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2699                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2700                 enddo
2701                 do k=1,3
2702                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2703                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2704                 enddo
2705                 gggp(1)=gggp(1)+ees0pijp*xj
2706                 gggp(2)=gggp(2)+ees0pijp*yj
2707                 gggp(3)=gggp(3)+ees0pijp*zj
2708                 gggm(1)=gggm(1)+ees0mijp*xj
2709                 gggm(2)=gggm(2)+ees0mijp*yj
2710                 gggm(3)=gggm(3)+ees0mijp*zj
2711 C Derivatives due to the contact function
2712                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2713                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2714                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2715                 do k=1,3
2716                   ghalfp=0.5D0*gggp(k)
2717                   ghalfm=0.5D0*gggm(k)
2718                   gacontp_hb1(k,num_conti,i)=ghalfp
2719      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2720      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2721                   gacontp_hb2(k,num_conti,i)=ghalfp
2722      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2723      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2724                   gacontp_hb3(k,num_conti,i)=gggp(k)
2725                   gacontm_hb1(k,num_conti,i)=ghalfm
2726      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2727      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2728                   gacontm_hb2(k,num_conti,i)=ghalfm
2729      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2730      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2731                   gacontm_hb3(k,num_conti,i)=gggm(k)
2732                 enddo
2733                 endif
2734 C Diagnostics. Comment out or remove after debugging!
2735 cdiag           do k=1,3
2736 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2737 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2738 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2739 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2740 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2741 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2742 cdiag           enddo
2743               ENDIF ! wcorr
2744               endif  ! num_conti.le.maxconts
2745             endif  ! fcont.gt.0
2746           endif    ! j.gt.i+1
2747  1216     continue
2748         enddo ! j
2749         num_cont_hb(i)=num_conti
2750  1215   continue
2751       enddo   ! i
2752 cd      do i=1,nres
2753 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2754 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2755 cd      enddo
2756 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2757 ccc      eel_loc=eel_loc+eello_turn3
2758       return
2759       end
2760 C-----------------------------------------------------------------------------
2761       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2762 C Third- and fourth-order contributions from turns
2763       implicit real*8 (a-h,o-z)
2764       include 'DIMENSIONS'
2765       include 'DIMENSIONS.ZSCOPT'
2766       include 'COMMON.IOUNITS'
2767       include 'COMMON.GEO'
2768       include 'COMMON.VAR'
2769       include 'COMMON.LOCAL'
2770       include 'COMMON.CHAIN'
2771       include 'COMMON.DERIV'
2772       include 'COMMON.INTERACT'
2773       include 'COMMON.CONTACTS'
2774       include 'COMMON.TORSION'
2775       include 'COMMON.VECTORS'
2776       include 'COMMON.FFIELD'
2777       dimension ggg(3)
2778       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2779      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2780      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2781       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2782      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2783       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2784       if (j.eq.i+2) then
2785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2786 C
2787 C               Third-order contributions
2788 C
2789 C                 (i+2)o----(i+3)
2790 C                      | |
2791 C                      | |
2792 C                 (i+1)o----i
2793 C
2794 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2795 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2796         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2797         call transpose2(auxmat(1,1),auxmat1(1,1))
2798         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2799         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2800 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2801 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2802 cd     &    ' eello_turn3_num',4*eello_turn3_num
2803         if (calc_grad) then
2804 C Derivatives in gamma(i)
2805         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2806         call transpose2(auxmat2(1,1),pizda(1,1))
2807         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2808         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2809 C Derivatives in gamma(i+1)
2810         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2811         call transpose2(auxmat2(1,1),pizda(1,1))
2812         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2813         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2814      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2815 C Cartesian derivatives
2816         do l=1,3
2817           a_temp(1,1)=aggi(l,1)
2818           a_temp(1,2)=aggi(l,2)
2819           a_temp(2,1)=aggi(l,3)
2820           a_temp(2,2)=aggi(l,4)
2821           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2822           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2823      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2824           a_temp(1,1)=aggi1(l,1)
2825           a_temp(1,2)=aggi1(l,2)
2826           a_temp(2,1)=aggi1(l,3)
2827           a_temp(2,2)=aggi1(l,4)
2828           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2829           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2830      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2831           a_temp(1,1)=aggj(l,1)
2832           a_temp(1,2)=aggj(l,2)
2833           a_temp(2,1)=aggj(l,3)
2834           a_temp(2,2)=aggj(l,4)
2835           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2836           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2837      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2838           a_temp(1,1)=aggj1(l,1)
2839           a_temp(1,2)=aggj1(l,2)
2840           a_temp(2,1)=aggj1(l,3)
2841           a_temp(2,2)=aggj1(l,4)
2842           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2843           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2844      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2845         enddo
2846         endif
2847       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2848       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2849 C changes suggested by Ana to avoid out of bounds
2850      & .or.((i+5).gt.nres)
2851      & .or.((i-1).le.0)
2852 C end of changes suggested by Ana
2853      &    .or. itype(i+3).eq.ntyp1
2854      &    .or. itype(i+4).eq.ntyp1
2855      &    .or. itype(i+5).eq.ntyp1
2856      &    .or. itype(i).eq.ntyp1
2857      &    .or. itype(i-1).eq.ntyp1) goto 178
2858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2859 C
2860 C               Fourth-order contributions
2861 C
2862 C                 (i+3)o----(i+4)
2863 C                     /  |
2864 C               (i+2)o   |
2865 C                     \  |
2866 C                 (i+1)o----i
2867 C
2868 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2869 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2870         iti1=itortyp(itype(i+1))
2871         iti2=itortyp(itype(i+2))
2872         iti3=itortyp(itype(i+3))
2873         call transpose2(EUg(1,1,i+1),e1t(1,1))
2874         call transpose2(Eug(1,1,i+2),e2t(1,1))
2875         call transpose2(Eug(1,1,i+3),e3t(1,1))
2876         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2877         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2878         s1=scalar2(b1(1,iti2),auxvec(1))
2879         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2880         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2881         s2=scalar2(b1(1,iti1),auxvec(1))
2882         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2883         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2885         eello_turn4=eello_turn4-(s1+s2+s3)
2886 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2887 cd     &    ' eello_turn4_num',8*eello_turn4_num
2888 C Derivatives in gamma(i)
2889         if (calc_grad) then
2890         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2891         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2892         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2893         s1=scalar2(b1(1,iti2),auxvec(1))
2894         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2895         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2896         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2897 C Derivatives in gamma(i+1)
2898         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2899         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2900         s2=scalar2(b1(1,iti1),auxvec(1))
2901         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2902         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2903         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2904         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2905 C Derivatives in gamma(i+2)
2906         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2907         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2908         s1=scalar2(b1(1,iti2),auxvec(1))
2909         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2910         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2911         s2=scalar2(b1(1,iti1),auxvec(1))
2912         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2913         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2914         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2915         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2916 C Cartesian derivatives
2917 C Derivatives of this turn contributions in DC(i+2)
2918         if (j.lt.nres-1) then
2919           do l=1,3
2920             a_temp(1,1)=agg(l,1)
2921             a_temp(1,2)=agg(l,2)
2922             a_temp(2,1)=agg(l,3)
2923             a_temp(2,2)=agg(l,4)
2924             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2925             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2926             s1=scalar2(b1(1,iti2),auxvec(1))
2927             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2928             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2929             s2=scalar2(b1(1,iti1),auxvec(1))
2930             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2931             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2932             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2933             ggg(l)=-(s1+s2+s3)
2934             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2935           enddo
2936         endif
2937 C Remaining derivatives of this turn contribution
2938         do l=1,3
2939           a_temp(1,1)=aggi(l,1)
2940           a_temp(1,2)=aggi(l,2)
2941           a_temp(2,1)=aggi(l,3)
2942           a_temp(2,2)=aggi(l,4)
2943           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2944           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2945           s1=scalar2(b1(1,iti2),auxvec(1))
2946           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2947           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2948           s2=scalar2(b1(1,iti1),auxvec(1))
2949           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2950           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2951           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2952           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2953           a_temp(1,1)=aggi1(l,1)
2954           a_temp(1,2)=aggi1(l,2)
2955           a_temp(2,1)=aggi1(l,3)
2956           a_temp(2,2)=aggi1(l,4)
2957           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2958           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2959           s1=scalar2(b1(1,iti2),auxvec(1))
2960           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2961           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2962           s2=scalar2(b1(1,iti1),auxvec(1))
2963           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2964           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2965           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2966           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2967           a_temp(1,1)=aggj(l,1)
2968           a_temp(1,2)=aggj(l,2)
2969           a_temp(2,1)=aggj(l,3)
2970           a_temp(2,2)=aggj(l,4)
2971           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2972           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2973           s1=scalar2(b1(1,iti2),auxvec(1))
2974           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2975           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2976           s2=scalar2(b1(1,iti1),auxvec(1))
2977           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2978           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2979           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2980           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2981           a_temp(1,1)=aggj1(l,1)
2982           a_temp(1,2)=aggj1(l,2)
2983           a_temp(2,1)=aggj1(l,3)
2984           a_temp(2,2)=aggj1(l,4)
2985           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2986           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2987           s1=scalar2(b1(1,iti2),auxvec(1))
2988           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2989           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2990           s2=scalar2(b1(1,iti1),auxvec(1))
2991           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2992           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2993           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2994           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2995         enddo
2996         endif
2997  178  continue
2998       endif
2999       return
3000       end
3001 C-----------------------------------------------------------------------------
3002       subroutine vecpr(u,v,w)
3003       implicit real*8(a-h,o-z)
3004       dimension u(3),v(3),w(3)
3005       w(1)=u(2)*v(3)-u(3)*v(2)
3006       w(2)=-u(1)*v(3)+u(3)*v(1)
3007       w(3)=u(1)*v(2)-u(2)*v(1)
3008       return
3009       end
3010 C-----------------------------------------------------------------------------
3011       subroutine unormderiv(u,ugrad,unorm,ungrad)
3012 C This subroutine computes the derivatives of a normalized vector u, given
3013 C the derivatives computed without normalization conditions, ugrad. Returns
3014 C ungrad.
3015       implicit none
3016       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3017       double precision vec(3)
3018       double precision scalar
3019       integer i,j
3020 c      write (2,*) 'ugrad',ugrad
3021 c      write (2,*) 'u',u
3022       do i=1,3
3023         vec(i)=scalar(ugrad(1,i),u(1))
3024       enddo
3025 c      write (2,*) 'vec',vec
3026       do i=1,3
3027         do j=1,3
3028           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3029         enddo
3030       enddo
3031 c      write (2,*) 'ungrad',ungrad
3032       return
3033       end
3034 C-----------------------------------------------------------------------------
3035       subroutine escp(evdw2,evdw2_14)
3036 C
3037 C This subroutine calculates the excluded-volume interaction energy between
3038 C peptide-group centers and side chains and its gradient in virtual-bond and
3039 C side-chain vectors.
3040 C
3041       implicit real*8 (a-h,o-z)
3042       include 'DIMENSIONS'
3043       include 'DIMENSIONS.ZSCOPT'
3044       include 'COMMON.GEO'
3045       include 'COMMON.VAR'
3046       include 'COMMON.LOCAL'
3047       include 'COMMON.CHAIN'
3048       include 'COMMON.DERIV'
3049       include 'COMMON.INTERACT'
3050       include 'COMMON.FFIELD'
3051       include 'COMMON.IOUNITS'
3052       dimension ggg(3)
3053       evdw2=0.0D0
3054       evdw2_14=0.0d0
3055 cd    print '(a)','Enter ESCP'
3056 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3057 c     &  ' scal14',scal14
3058       do i=iatscp_s,iatscp_e
3059         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3060         iteli=itel(i)
3061 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3062 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3063         if (iteli.eq.0) goto 1225
3064         xi=0.5D0*(c(1,i)+c(1,i+1))
3065         yi=0.5D0*(c(2,i)+c(2,i+1))
3066         zi=0.5D0*(c(3,i)+c(3,i+1))
3067 C Returning the ith atom to box
3068           xi=mod(xi,boxxsize)
3069           if (xi.lt.0) xi=xi+boxxsize
3070           yi=mod(yi,boxysize)
3071           if (yi.lt.0) yi=yi+boxysize
3072           zi=mod(zi,boxzsize)
3073           if (zi.lt.0) zi=zi+boxzsize
3074         do iint=1,nscp_gr(i)
3075
3076         do j=iscpstart(i,iint),iscpend(i,iint)
3077           itypj=iabs(itype(j))
3078           if (itypj.eq.ntyp1) cycle
3079 C Uncomment following three lines for SC-p interactions
3080 c         xj=c(1,nres+j)-xi
3081 c         yj=c(2,nres+j)-yi
3082 c         zj=c(3,nres+j)-zi
3083 C Uncomment following three lines for Ca-p interactions
3084           xj=c(1,j)
3085           yj=c(2,j)
3086           zj=c(3,j)
3087 C returning the jth atom to box
3088           xj=mod(xj,boxxsize)
3089           if (xj.lt.0) xj=xj+boxxsize
3090           yj=mod(yj,boxysize)
3091           if (yj.lt.0) yj=yj+boxysize
3092           zj=mod(zj,boxzsize)
3093           if (zj.lt.0) zj=zj+boxzsize
3094       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3095       xj_safe=xj
3096       yj_safe=yj
3097       zj_safe=zj
3098       subchap=0
3099 C Finding the closest jth atom
3100       do xshift=-1,1
3101       do yshift=-1,1
3102       do zshift=-1,1
3103           xj=xj_safe+xshift*boxxsize
3104           yj=yj_safe+yshift*boxysize
3105           zj=zj_safe+zshift*boxzsize
3106           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3107           if(dist_temp.lt.dist_init) then
3108             dist_init=dist_temp
3109             xj_temp=xj
3110             yj_temp=yj
3111             zj_temp=zj
3112             subchap=1
3113           endif
3114        enddo
3115        enddo
3116        enddo
3117        if (subchap.eq.1) then
3118           xj=xj_temp-xi
3119           yj=yj_temp-yi
3120           zj=zj_temp-zi
3121        else
3122           xj=xj_safe-xi
3123           yj=yj_safe-yi
3124           zj=zj_safe-zi
3125        endif
3126           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3127 C sss is scaling function for smoothing the cutoff gradient otherwise
3128 C the gradient would not be continuouse
3129           sss=sscale(1.0d0/(dsqrt(rrij)))
3130           if (sss.le.0.0d0) cycle
3131           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3132           fac=rrij**expon2
3133           e1=fac*fac*aad(itypj,iteli)
3134           e2=fac*bad(itypj,iteli)
3135           if (iabs(j-i) .le. 2) then
3136             e1=scal14*e1
3137             e2=scal14*e2
3138             evdw2_14=evdw2_14+(e1+e2)*sss
3139           endif
3140           evdwij=e1+e2
3141 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3142 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3143 c     &       bad(itypj,iteli)
3144           evdw2=evdw2+evdwij*sss
3145           if (calc_grad) then
3146 C
3147 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3148 C
3149           fac=-(evdwij+e1)*rrij*sss
3150           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3151           ggg(1)=xj*fac
3152           ggg(2)=yj*fac
3153           ggg(3)=zj*fac
3154           if (j.lt.i) then
3155 cd          write (iout,*) 'j<i'
3156 C Uncomment following three lines for SC-p interactions
3157 c           do k=1,3
3158 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3159 c           enddo
3160           else
3161 cd          write (iout,*) 'j>i'
3162             do k=1,3
3163               ggg(k)=-ggg(k)
3164 C Uncomment following line for SC-p interactions
3165 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3166             enddo
3167           endif
3168           do k=1,3
3169             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3170           enddo
3171           kstart=min0(i+1,j)
3172           kend=max0(i-1,j-1)
3173 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3174 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3175           do k=kstart,kend
3176             do l=1,3
3177               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3178             enddo
3179           enddo
3180           endif
3181         enddo
3182         enddo ! iint
3183  1225   continue
3184       enddo ! i
3185       do i=1,nct
3186         do j=1,3
3187           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3188           gradx_scp(j,i)=expon*gradx_scp(j,i)
3189         enddo
3190       enddo
3191 C******************************************************************************
3192 C
3193 C                              N O T E !!!
3194 C
3195 C To save time the factor EXPON has been extracted from ALL components
3196 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3197 C use!
3198 C
3199 C******************************************************************************
3200       return
3201       end
3202 C--------------------------------------------------------------------------
3203       subroutine edis(ehpb)
3204 C
3205 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3206 C
3207       implicit real*8 (a-h,o-z)
3208       include 'DIMENSIONS'
3209       include 'DIMENSIONS.ZSCOPT'
3210       include 'COMMON.SBRIDGE'
3211       include 'COMMON.CHAIN'
3212       include 'COMMON.DERIV'
3213       include 'COMMON.VAR'
3214       include 'COMMON.INTERACT'
3215       include 'COMMON.CONTROL'
3216       include 'COMMON.IOUNITS'
3217       dimension ggg(3)
3218       ehpb=0.0D0
3219 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3220 cd    print *,'link_start=',link_start,' link_end=',link_end
3221 C      write(iout,*) link_end, "link_end"
3222       if (link_end.eq.0) return
3223       do i=link_start,link_end
3224 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3225 C CA-CA distance used in regularization of structure.
3226         ii=ihpb(i)
3227         jj=jhpb(i)
3228 C iii and jjj point to the residues for which the distance is assigned.
3229         if (ii.gt.nres) then
3230           iii=ii-nres
3231           jjj=jj-nres
3232         else
3233           iii=ii
3234           jjj=jj
3235         endif
3236 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3237 C    distance and angle dependent SS bond potential.
3238 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3239 C     & iabs(itype(jjj)).eq.1) then
3240 C       write(iout,*) constr_dist,"const"
3241        if (.not.dyn_ss .and. i.le.nss) then
3242          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3243      & iabs(itype(jjj)).eq.1) then
3244           call ssbond_ene(iii,jjj,eij)
3245           ehpb=ehpb+2*eij
3246            endif !ii.gt.neres
3247         else if (ii.gt.nres .and. jj.gt.nres) then
3248 c Restraints from contact prediction
3249           dd=dist(ii,jj)
3250           if (constr_dist.eq.11) then
3251 C            ehpb=ehpb+fordepth(i)**4.0d0
3252 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3253             ehpb=ehpb+fordepth(i)**4.0d0
3254      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3255             fac=fordepth(i)**4.0d0
3256      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3257 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3258 C     &    ehpb,fordepth(i),dd
3259 C            write(iout,*) ehpb,"atu?"
3260 C            ehpb,"tu?"
3261 C            fac=fordepth(i)**4.0d0
3262 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3263            else
3264           if (dhpb1(i).gt.0.0d0) then
3265             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3266             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3267 c            write (iout,*) "beta nmr",
3268 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3269           else
3270             dd=dist(ii,jj)
3271             rdis=dd-dhpb(i)
3272 C Get the force constant corresponding to this distance.
3273             waga=forcon(i)
3274 C Calculate the contribution to energy.
3275             ehpb=ehpb+waga*rdis*rdis
3276 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3277 C
3278 C Evaluate gradient.
3279 C
3280             fac=waga*rdis/dd
3281           endif !end dhpb1(i).gt.0
3282           endif !end const_dist=11
3283           do j=1,3
3284             ggg(j)=fac*(c(j,jj)-c(j,ii))
3285           enddo
3286           do j=1,3
3287             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3288             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3289           enddo
3290           do k=1,3
3291             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3292             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3293           enddo
3294         else !ii.gt.nres
3295 C          write(iout,*) "before"
3296           dd=dist(ii,jj)
3297 C          write(iout,*) "after",dd
3298           if (constr_dist.eq.11) then
3299             ehpb=ehpb+fordepth(i)**4.0d0
3300      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3301             fac=fordepth(i)**4.0d0
3302      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3303 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3304 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3305 C            print *,ehpb,"tu?"
3306 C            write(iout,*) ehpb,"btu?",
3307 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3308 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3309 C     &    ehpb,fordepth(i),dd
3310            else
3311           if (dhpb1(i).gt.0.0d0) then
3312             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3313             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3314 c            write (iout,*) "alph nmr",
3315 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3316           else
3317             rdis=dd-dhpb(i)
3318 C Get the force constant corresponding to this distance.
3319             waga=forcon(i)
3320 C Calculate the contribution to energy.
3321             ehpb=ehpb+waga*rdis*rdis
3322 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3323 C
3324 C Evaluate gradient.
3325 C
3326             fac=waga*rdis/dd
3327           endif
3328           endif
3329
3330         do j=1,3
3331           ggg(j)=fac*(c(j,jj)-c(j,ii))
3332         enddo
3333 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3334 C If this is a SC-SC distance, we need to calculate the contributions to the
3335 C Cartesian gradient in the SC vectors (ghpbx).
3336         if (iii.lt.ii) then
3337           do j=1,3
3338             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3339             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3340           enddo
3341         endif
3342         do j=iii,jjj-1
3343           do k=1,3
3344             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3345           enddo
3346         enddo
3347         endif
3348       enddo
3349       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3350       return
3351       end
3352 C--------------------------------------------------------------------------
3353       subroutine ssbond_ene(i,j,eij)
3354 C
3355 C Calculate the distance and angle dependent SS-bond potential energy
3356 C using a free-energy function derived based on RHF/6-31G** ab initio
3357 C calculations of diethyl disulfide.
3358 C
3359 C A. Liwo and U. Kozlowska, 11/24/03
3360 C
3361       implicit real*8 (a-h,o-z)
3362       include 'DIMENSIONS'
3363       include 'DIMENSIONS.ZSCOPT'
3364       include 'COMMON.SBRIDGE'
3365       include 'COMMON.CHAIN'
3366       include 'COMMON.DERIV'
3367       include 'COMMON.LOCAL'
3368       include 'COMMON.INTERACT'
3369       include 'COMMON.VAR'
3370       include 'COMMON.IOUNITS'
3371       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3372       itypi=iabs(itype(i))
3373       xi=c(1,nres+i)
3374       yi=c(2,nres+i)
3375       zi=c(3,nres+i)
3376       dxi=dc_norm(1,nres+i)
3377       dyi=dc_norm(2,nres+i)
3378       dzi=dc_norm(3,nres+i)
3379       dsci_inv=dsc_inv(itypi)
3380       itypj=iabs(itype(j))
3381       dscj_inv=dsc_inv(itypj)
3382       xj=c(1,nres+j)-xi
3383       yj=c(2,nres+j)-yi
3384       zj=c(3,nres+j)-zi
3385       dxj=dc_norm(1,nres+j)
3386       dyj=dc_norm(2,nres+j)
3387       dzj=dc_norm(3,nres+j)
3388       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3389       rij=dsqrt(rrij)
3390       erij(1)=xj*rij
3391       erij(2)=yj*rij
3392       erij(3)=zj*rij
3393       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3394       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3395       om12=dxi*dxj+dyi*dyj+dzi*dzj
3396       do k=1,3
3397         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3398         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3399       enddo
3400       rij=1.0d0/rij
3401       deltad=rij-d0cm
3402       deltat1=1.0d0-om1
3403       deltat2=1.0d0+om2
3404       deltat12=om2-om1+2.0d0
3405       cosphi=om12-om1*om2
3406       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3407      &  +akct*deltad*deltat12
3408      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3409 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3410 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3411 c     &  " deltat12",deltat12," eij",eij
3412       ed=2*akcm*deltad+akct*deltat12
3413       pom1=akct*deltad
3414       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3415       eom1=-2*akth*deltat1-pom1-om2*pom2
3416       eom2= 2*akth*deltat2+pom1-om1*pom2
3417       eom12=pom2
3418       do k=1,3
3419         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3420       enddo
3421       do k=1,3
3422         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3423      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3424         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3425      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3426       enddo
3427 C
3428 C Calculate the components of the gradient in DC and X
3429 C
3430       do k=i,j-1
3431         do l=1,3
3432           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3433         enddo
3434       enddo
3435       return
3436       end
3437 C--------------------------------------------------------------------------
3438       subroutine ebond(estr)
3439 c
3440 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3441 c
3442       implicit real*8 (a-h,o-z)
3443       include 'DIMENSIONS'
3444       include 'DIMENSIONS.ZSCOPT'
3445       include 'COMMON.LOCAL'
3446       include 'COMMON.GEO'
3447       include 'COMMON.INTERACT'
3448       include 'COMMON.DERIV'
3449       include 'COMMON.VAR'
3450       include 'COMMON.CHAIN'
3451       include 'COMMON.IOUNITS'
3452       include 'COMMON.NAMES'
3453       include 'COMMON.FFIELD'
3454       include 'COMMON.CONTROL'
3455       logical energy_dec /.false./
3456       double precision u(3),ud(3)
3457       estr=0.0d0
3458       estr1=0.0d0
3459 c      write (iout,*) "distchainmax",distchainmax
3460       do i=nnt+1,nct
3461         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3462 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3463 C          do j=1,3
3464 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3465 C     &      *dc(j,i-1)/vbld(i)
3466 C          enddo
3467 C          if (energy_dec) write(iout,*)
3468 C     &       "estr1",i,vbld(i),distchainmax,
3469 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3470 C        else
3471          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3472         diff = vbld(i)-vbldpDUM
3473          else
3474           diff = vbld(i)-vbldp0
3475 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3476          endif
3477           estr=estr+diff*diff
3478           do j=1,3
3479             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3480           enddo
3481 C        endif
3482 C        write (iout,'(a7,i5,4f7.3)')
3483 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3484       enddo
3485       estr=0.5d0*AKP*estr+estr1
3486 c
3487 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3488 c
3489       do i=nnt,nct
3490         iti=iabs(itype(i))
3491         if (iti.ne.10 .and. iti.ne.ntyp1) then
3492           nbi=nbondterm(iti)
3493           if (nbi.eq.1) then
3494             diff=vbld(i+nres)-vbldsc0(1,iti)
3495 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3496 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3497             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3498             do j=1,3
3499               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3500             enddo
3501           else
3502             do j=1,nbi
3503               diff=vbld(i+nres)-vbldsc0(j,iti)
3504               ud(j)=aksc(j,iti)*diff
3505               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3506             enddo
3507             uprod=u(1)
3508             do j=2,nbi
3509               uprod=uprod*u(j)
3510             enddo
3511             usum=0.0d0
3512             usumsqder=0.0d0
3513             do j=1,nbi
3514               uprod1=1.0d0
3515               uprod2=1.0d0
3516               do k=1,nbi
3517                 if (k.ne.j) then
3518                   uprod1=uprod1*u(k)
3519                   uprod2=uprod2*u(k)*u(k)
3520                 endif
3521               enddo
3522               usum=usum+uprod1
3523               usumsqder=usumsqder+ud(j)*uprod2
3524             enddo
3525 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3526 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3527             estr=estr+uprod/usum
3528             do j=1,3
3529              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3530             enddo
3531           endif
3532         endif
3533       enddo
3534       return
3535       end
3536 #ifdef CRYST_THETA
3537 C--------------------------------------------------------------------------
3538       subroutine ebend(etheta,ethetacnstr)
3539 C
3540 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3541 C angles gamma and its derivatives in consecutive thetas and gammas.
3542 C
3543       implicit real*8 (a-h,o-z)
3544       include 'DIMENSIONS'
3545       include 'DIMENSIONS.ZSCOPT'
3546       include 'COMMON.LOCAL'
3547       include 'COMMON.GEO'
3548       include 'COMMON.INTERACT'
3549       include 'COMMON.DERIV'
3550       include 'COMMON.VAR'
3551       include 'COMMON.CHAIN'
3552       include 'COMMON.IOUNITS'
3553       include 'COMMON.NAMES'
3554       include 'COMMON.FFIELD'
3555       include 'COMMON.TORCNSTR'
3556       common /calcthet/ term1,term2,termm,diffak,ratak,
3557      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3558      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3559       double precision y(2),z(2)
3560       delta=0.02d0*pi
3561 c      time11=dexp(-2*time)
3562 c      time12=1.0d0
3563       etheta=0.0D0
3564 c      write (iout,*) "nres",nres
3565 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3566 c      write (iout,*) ithet_start,ithet_end
3567       do i=ithet_start,ithet_end
3568 C        if (itype(i-1).eq.ntyp1) cycle
3569         if (i.le.2) cycle
3570         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3571      &  .or.itype(i).eq.ntyp1) cycle
3572 C Zero the energy function and its derivative at 0 or pi.
3573         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3574         it=itype(i-1)
3575         ichir1=isign(1,itype(i-2))
3576         ichir2=isign(1,itype(i))
3577          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3578          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3579          if (itype(i-1).eq.10) then
3580           itype1=isign(10,itype(i-2))
3581           ichir11=isign(1,itype(i-2))
3582           ichir12=isign(1,itype(i-2))
3583           itype2=isign(10,itype(i))
3584           ichir21=isign(1,itype(i))
3585           ichir22=isign(1,itype(i))
3586          endif
3587          if (i.eq.3) then
3588           y(1)=0.0D0
3589           y(2)=0.0D0
3590           else
3591
3592         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3593 #ifdef OSF
3594           phii=phi(i)
3595 c          icrc=0
3596 c          call proc_proc(phii,icrc)
3597           if (icrc.eq.1) phii=150.0
3598 #else
3599           phii=phi(i)
3600 #endif
3601           y(1)=dcos(phii)
3602           y(2)=dsin(phii)
3603         else
3604           y(1)=0.0D0
3605           y(2)=0.0D0
3606         endif
3607         endif
3608         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3609 #ifdef OSF
3610           phii1=phi(i+1)
3611 c          icrc=0
3612 c          call proc_proc(phii1,icrc)
3613           if (icrc.eq.1) phii1=150.0
3614           phii1=pinorm(phii1)
3615           z(1)=cos(phii1)
3616 #else
3617           phii1=phi(i+1)
3618           z(1)=dcos(phii1)
3619 #endif
3620           z(2)=dsin(phii1)
3621         else
3622           z(1)=0.0D0
3623           z(2)=0.0D0
3624         endif
3625 C Calculate the "mean" value of theta from the part of the distribution
3626 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3627 C In following comments this theta will be referred to as t_c.
3628         thet_pred_mean=0.0d0
3629         do k=1,2
3630             athetk=athet(k,it,ichir1,ichir2)
3631             bthetk=bthet(k,it,ichir1,ichir2)
3632           if (it.eq.10) then
3633              athetk=athet(k,itype1,ichir11,ichir12)
3634              bthetk=bthet(k,itype2,ichir21,ichir22)
3635           endif
3636           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3637         enddo
3638 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3639         dthett=thet_pred_mean*ssd
3640         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3641 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3642 C Derivatives of the "mean" values in gamma1 and gamma2.
3643         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3644      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3645          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3646      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3647          if (it.eq.10) then
3648       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3649      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3650         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3651      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3652          endif
3653         if (theta(i).gt.pi-delta) then
3654           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3655      &         E_tc0)
3656           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3657           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3658           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3659      &        E_theta)
3660           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3661      &        E_tc)
3662         else if (theta(i).lt.delta) then
3663           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3664           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3665           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3666      &        E_theta)
3667           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3668           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3669      &        E_tc)
3670         else
3671           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3672      &        E_theta,E_tc)
3673         endif
3674         etheta=etheta+ethetai
3675 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
3676 c     &      'ebend',i,ethetai,theta(i),itype(i)
3677 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3678 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3679         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3680         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3681         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3682 c 1215   continue
3683       enddo
3684       ethetacnstr=0.0d0
3685 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3686       do i=1,ntheta_constr
3687         itheta=itheta_constr(i)
3688         thetiii=theta(itheta)
3689         difi=pinorm(thetiii-theta_constr0(i))
3690         if (difi.gt.theta_drange(i)) then
3691           difi=difi-theta_drange(i)
3692           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3693           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3694      &    +for_thet_constr(i)*difi**3
3695         else if (difi.lt.-drange(i)) then
3696           difi=difi+drange(i)
3697           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3698           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3699      &    +for_thet_constr(i)*difi**3
3700         else
3701           difi=0.0
3702         endif
3703 C       if (energy_dec) then
3704 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3705 C     &    i,itheta,rad2deg*thetiii,
3706 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3707 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3708 C     &    gloc(itheta+nphi-2,icg)
3709         endif
3710       enddo
3711 C Ufff.... We've done all this!!!
3712       return
3713       end
3714 C---------------------------------------------------------------------------
3715       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3716      &     E_tc)
3717       implicit real*8 (a-h,o-z)
3718       include 'DIMENSIONS'
3719       include 'COMMON.LOCAL'
3720       include 'COMMON.IOUNITS'
3721       common /calcthet/ term1,term2,termm,diffak,ratak,
3722      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3723      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3724 C Calculate the contributions to both Gaussian lobes.
3725 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3726 C The "polynomial part" of the "standard deviation" of this part of
3727 C the distribution.
3728         sig=polthet(3,it)
3729         do j=2,0,-1
3730           sig=sig*thet_pred_mean+polthet(j,it)
3731         enddo
3732 C Derivative of the "interior part" of the "standard deviation of the"
3733 C gamma-dependent Gaussian lobe in t_c.
3734         sigtc=3*polthet(3,it)
3735         do j=2,1,-1
3736           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3737         enddo
3738         sigtc=sig*sigtc
3739 C Set the parameters of both Gaussian lobes of the distribution.
3740 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3741         fac=sig*sig+sigc0(it)
3742         sigcsq=fac+fac
3743         sigc=1.0D0/sigcsq
3744 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3745         sigsqtc=-4.0D0*sigcsq*sigtc
3746 c       print *,i,sig,sigtc,sigsqtc
3747 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3748         sigtc=-sigtc/(fac*fac)
3749 C Following variable is sigma(t_c)**(-2)
3750         sigcsq=sigcsq*sigcsq
3751         sig0i=sig0(it)
3752         sig0inv=1.0D0/sig0i**2
3753         delthec=thetai-thet_pred_mean
3754         delthe0=thetai-theta0i
3755         term1=-0.5D0*sigcsq*delthec*delthec
3756         term2=-0.5D0*sig0inv*delthe0*delthe0
3757 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3758 C NaNs in taking the logarithm. We extract the largest exponent which is added
3759 C to the energy (this being the log of the distribution) at the end of energy
3760 C term evaluation for this virtual-bond angle.
3761         if (term1.gt.term2) then
3762           termm=term1
3763           term2=dexp(term2-termm)
3764           term1=1.0d0
3765         else
3766           termm=term2
3767           term1=dexp(term1-termm)
3768           term2=1.0d0
3769         endif
3770 C The ratio between the gamma-independent and gamma-dependent lobes of
3771 C the distribution is a Gaussian function of thet_pred_mean too.
3772         diffak=gthet(2,it)-thet_pred_mean
3773         ratak=diffak/gthet(3,it)**2
3774         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3775 C Let's differentiate it in thet_pred_mean NOW.
3776         aktc=ak*ratak
3777 C Now put together the distribution terms to make complete distribution.
3778         termexp=term1+ak*term2
3779         termpre=sigc+ak*sig0i
3780 C Contribution of the bending energy from this theta is just the -log of
3781 C the sum of the contributions from the two lobes and the pre-exponential
3782 C factor. Simple enough, isn't it?
3783         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3784 C NOW the derivatives!!!
3785 C 6/6/97 Take into account the deformation.
3786         E_theta=(delthec*sigcsq*term1
3787      &       +ak*delthe0*sig0inv*term2)/termexp
3788         E_tc=((sigtc+aktc*sig0i)/termpre
3789      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3790      &       aktc*term2)/termexp)
3791       return
3792       end
3793 c-----------------------------------------------------------------------------
3794       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3795       implicit real*8 (a-h,o-z)
3796       include 'DIMENSIONS'
3797       include 'COMMON.LOCAL'
3798       include 'COMMON.IOUNITS'
3799       common /calcthet/ term1,term2,termm,diffak,ratak,
3800      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3801      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3802       delthec=thetai-thet_pred_mean
3803       delthe0=thetai-theta0i
3804 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3805       t3 = thetai-thet_pred_mean
3806       t6 = t3**2
3807       t9 = term1
3808       t12 = t3*sigcsq
3809       t14 = t12+t6*sigsqtc
3810       t16 = 1.0d0
3811       t21 = thetai-theta0i
3812       t23 = t21**2
3813       t26 = term2
3814       t27 = t21*t26
3815       t32 = termexp
3816       t40 = t32**2
3817       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3818      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3819      & *(-t12*t9-ak*sig0inv*t27)
3820       return
3821       end
3822 #else
3823 C--------------------------------------------------------------------------
3824       subroutine ebend(etheta,ethetacnstr)
3825 C
3826 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3827 C angles gamma and its derivatives in consecutive thetas and gammas.
3828 C ab initio-derived potentials from
3829 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3830 C
3831       implicit real*8 (a-h,o-z)
3832       include 'DIMENSIONS'
3833       include 'DIMENSIONS.ZSCOPT'
3834       include 'COMMON.LOCAL'
3835       include 'COMMON.GEO'
3836       include 'COMMON.INTERACT'
3837       include 'COMMON.DERIV'
3838       include 'COMMON.VAR'
3839       include 'COMMON.CHAIN'
3840       include 'COMMON.IOUNITS'
3841       include 'COMMON.NAMES'
3842       include 'COMMON.FFIELD'
3843       include 'COMMON.CONTROL'
3844       include 'COMMON.TORCNSTR'
3845       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3846      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3847      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3848      & sinph1ph2(maxdouble,maxdouble)
3849       logical lprn /.false./, lprn1 /.false./
3850       etheta=0.0D0
3851 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3852       do i=ithet_start,ithet_end
3853 C         if (i.eq.2) cycle
3854 C        if (itype(i-1).eq.ntyp1) cycle
3855         if (i.le.2) cycle
3856         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3857      &  .or.itype(i).eq.ntyp1) cycle
3858         if (iabs(itype(i+1)).eq.20) iblock=2
3859         if (iabs(itype(i+1)).ne.20) iblock=1
3860         dethetai=0.0d0
3861         dephii=0.0d0
3862         dephii1=0.0d0
3863         theti2=0.5d0*theta(i)
3864         ityp2=ithetyp((itype(i-1)))
3865         do k=1,nntheterm
3866           coskt(k)=dcos(k*theti2)
3867           sinkt(k)=dsin(k*theti2)
3868         enddo
3869         if (i.eq.3) then
3870           phii=0.0d0
3871           ityp1=nthetyp+1
3872           do k=1,nsingle
3873             cosph1(k)=0.0d0
3874             sinph1(k)=0.0d0
3875           enddo
3876         else
3877         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3878 #ifdef OSF
3879           phii=phi(i)
3880           if (phii.ne.phii) phii=150.0
3881 #else
3882           phii=phi(i)
3883 #endif
3884           ityp1=ithetyp((itype(i-2)))
3885           do k=1,nsingle
3886             cosph1(k)=dcos(k*phii)
3887             sinph1(k)=dsin(k*phii)
3888           enddo
3889         else
3890           phii=0.0d0
3891 c          ityp1=nthetyp+1
3892           do k=1,nsingle
3893             ityp1=ithetyp((itype(i-2)))
3894             cosph1(k)=0.0d0
3895             sinph1(k)=0.0d0
3896           enddo
3897         endif
3898         endif
3899         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3900 #ifdef OSF
3901           phii1=phi(i+1)
3902           if (phii1.ne.phii1) phii1=150.0
3903           phii1=pinorm(phii1)
3904 #else
3905           phii1=phi(i+1)
3906 #endif
3907           ityp3=ithetyp((itype(i)))
3908           do k=1,nsingle
3909             cosph2(k)=dcos(k*phii1)
3910             sinph2(k)=dsin(k*phii1)
3911           enddo
3912         else
3913           phii1=0.0d0
3914 c          ityp3=nthetyp+1
3915           ityp3=ithetyp((itype(i)))
3916           do k=1,nsingle
3917             cosph2(k)=0.0d0
3918             sinph2(k)=0.0d0
3919           enddo
3920         endif
3921 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3922 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3923 c        call flush(iout)
3924         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
3925         do k=1,ndouble
3926           do l=1,k-1
3927             ccl=cosph1(l)*cosph2(k-l)
3928             ssl=sinph1(l)*sinph2(k-l)
3929             scl=sinph1(l)*cosph2(k-l)
3930             csl=cosph1(l)*sinph2(k-l)
3931             cosph1ph2(l,k)=ccl-ssl
3932             cosph1ph2(k,l)=ccl+ssl
3933             sinph1ph2(l,k)=scl+csl
3934             sinph1ph2(k,l)=scl-csl
3935           enddo
3936         enddo
3937         if (lprn) then
3938         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3939      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3940         write (iout,*) "coskt and sinkt"
3941         do k=1,nntheterm
3942           write (iout,*) k,coskt(k),sinkt(k)
3943         enddo
3944         endif
3945         do k=1,ntheterm
3946           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
3947           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
3948      &      *coskt(k)
3949           if (lprn)
3950      &    write (iout,*) "k",k,"
3951      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
3952      &     " ethetai",ethetai
3953         enddo
3954         if (lprn) then
3955         write (iout,*) "cosph and sinph"
3956         do k=1,nsingle
3957           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3958         enddo
3959         write (iout,*) "cosph1ph2 and sinph2ph2"
3960         do k=2,ndouble
3961           do l=1,k-1
3962             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3963      &         sinph1ph2(l,k),sinph1ph2(k,l)
3964           enddo
3965         enddo
3966         write(iout,*) "ethetai",ethetai
3967         endif
3968         do m=1,ntheterm2
3969           do k=1,nsingle
3970             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
3971      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
3972      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
3973      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
3974             ethetai=ethetai+sinkt(m)*aux
3975             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3976             dephii=dephii+k*sinkt(m)*(
3977      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
3978      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
3979             dephii1=dephii1+k*sinkt(m)*(
3980      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
3981      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
3982             if (lprn)
3983      &      write (iout,*) "m",m," k",k," bbthet",
3984      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
3985      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
3986      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
3987      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
3988           enddo
3989         enddo
3990         if (lprn)
3991      &  write(iout,*) "ethetai",ethetai
3992         do m=1,ntheterm3
3993           do k=2,ndouble
3994             do l=1,k-1
3995               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3996      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
3997      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3998      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
3999               ethetai=ethetai+sinkt(m)*aux
4000               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4001               dephii=dephii+l*sinkt(m)*(
4002      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4003      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4004      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4005      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4006               dephii1=dephii1+(k-l)*sinkt(m)*(
4007      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4008      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4009      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4010      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4011               if (lprn) then
4012               write (iout,*) "m",m," k",k," l",l," ffthet",
4013      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4014      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4015      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4016      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4017      &            " ethetai",ethetai
4018               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4019      &            cosph1ph2(k,l)*sinkt(m),
4020      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4021               endif
4022             enddo
4023           enddo
4024         enddo
4025 10      continue
4026         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4027      &   i,theta(i)*rad2deg,phii*rad2deg,
4028      &   phii1*rad2deg,ethetai
4029         etheta=etheta+ethetai
4030         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4031         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4032 c        gloc(nphi+i-2,icg)=wang*dethetai
4033         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4034       enddo
4035 C now constrains
4036       ethetacnstr=0.0d0
4037 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4038       do i=1,ntheta_constr
4039         itheta=itheta_constr(i)
4040         thetiii=theta(itheta)
4041         difi=pinorm(thetiii-theta_constr0(i))
4042         if (difi.gt.theta_drange(i)) then
4043           difi=difi-theta_drange(i)
4044           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4045           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4046      &    +for_thet_constr(i)*difi**3
4047         else if (difi.lt.-drange(i)) then
4048           difi=difi+drange(i)
4049           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4050           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4051      &    +for_thet_constr(i)*difi**3
4052         else
4053           difi=0.0
4054         endif
4055 C       if (energy_dec) then
4056 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4057 C     &    i,itheta,rad2deg*thetiii,
4058 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4059 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4060 C     &    gloc(itheta+nphi-2,icg)
4061 C        endif
4062       enddo
4063       return
4064       end
4065 #endif
4066 #ifdef CRYST_SC
4067 c-----------------------------------------------------------------------------
4068       subroutine esc(escloc)
4069 C Calculate the local energy of a side chain and its derivatives in the
4070 C corresponding virtual-bond valence angles THETA and the spherical angles
4071 C ALPHA and OMEGA.
4072       implicit real*8 (a-h,o-z)
4073       include 'DIMENSIONS'
4074       include 'DIMENSIONS.ZSCOPT'
4075       include 'COMMON.GEO'
4076       include 'COMMON.LOCAL'
4077       include 'COMMON.VAR'
4078       include 'COMMON.INTERACT'
4079       include 'COMMON.DERIV'
4080       include 'COMMON.CHAIN'
4081       include 'COMMON.IOUNITS'
4082       include 'COMMON.NAMES'
4083       include 'COMMON.FFIELD'
4084       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4085      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4086       common /sccalc/ time11,time12,time112,theti,it,nlobit
4087       delta=0.02d0*pi
4088       escloc=0.0D0
4089 C      write (iout,*) 'ESC'
4090       do i=loc_start,loc_end
4091         it=itype(i)
4092         if (it.eq.ntyp1) cycle
4093         if (it.eq.10) goto 1
4094         nlobit=nlob(iabs(it))
4095 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4096 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4097         theti=theta(i+1)-pipol
4098         x(1)=dtan(theti)
4099         x(2)=alph(i)
4100         x(3)=omeg(i)
4101 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4102
4103         if (x(2).gt.pi-delta) then
4104           xtemp(1)=x(1)
4105           xtemp(2)=pi-delta
4106           xtemp(3)=x(3)
4107           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4108           xtemp(2)=pi
4109           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4110           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4111      &        escloci,dersc(2))
4112           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4113      &        ddersc0(1),dersc(1))
4114           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4115      &        ddersc0(3),dersc(3))
4116           xtemp(2)=pi-delta
4117           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4118           xtemp(2)=pi
4119           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4120           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4121      &            dersc0(2),esclocbi,dersc02)
4122           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4123      &            dersc12,dersc01)
4124           call splinthet(x(2),0.5d0*delta,ss,ssd)
4125           dersc0(1)=dersc01
4126           dersc0(2)=dersc02
4127           dersc0(3)=0.0d0
4128           do k=1,3
4129             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4130           enddo
4131           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4132           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4133      &             esclocbi,ss,ssd
4134           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4135 c         escloci=esclocbi
4136 c         write (iout,*) escloci
4137         else if (x(2).lt.delta) then
4138           xtemp(1)=x(1)
4139           xtemp(2)=delta
4140           xtemp(3)=x(3)
4141           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4142           xtemp(2)=0.0d0
4143           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4144           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4145      &        escloci,dersc(2))
4146           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4147      &        ddersc0(1),dersc(1))
4148           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4149      &        ddersc0(3),dersc(3))
4150           xtemp(2)=delta
4151           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4152           xtemp(2)=0.0d0
4153           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4154           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4155      &            dersc0(2),esclocbi,dersc02)
4156           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4157      &            dersc12,dersc01)
4158           dersc0(1)=dersc01
4159           dersc0(2)=dersc02
4160           dersc0(3)=0.0d0
4161           call splinthet(x(2),0.5d0*delta,ss,ssd)
4162           do k=1,3
4163             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4164           enddo
4165           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4166 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4167 c     &             esclocbi,ss,ssd
4168           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4169 C         write (iout,*) 'i=',i, escloci
4170         else
4171           call enesc(x,escloci,dersc,ddummy,.false.)
4172         endif
4173
4174         escloc=escloc+escloci
4175 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4176             write (iout,'(a6,i5,0pf7.3)')
4177      &     'escloc',i,escloci
4178
4179         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4180      &   wscloc*dersc(1)
4181         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4182         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4183     1   continue
4184       enddo
4185       return
4186       end
4187 C---------------------------------------------------------------------------
4188       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4189       implicit real*8 (a-h,o-z)
4190       include 'DIMENSIONS'
4191       include 'COMMON.GEO'
4192       include 'COMMON.LOCAL'
4193       include 'COMMON.IOUNITS'
4194       common /sccalc/ time11,time12,time112,theti,it,nlobit
4195       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4196       double precision contr(maxlob,-1:1)
4197       logical mixed
4198 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4199         escloc_i=0.0D0
4200         do j=1,3
4201           dersc(j)=0.0D0
4202           if (mixed) ddersc(j)=0.0d0
4203         enddo
4204         x3=x(3)
4205
4206 C Because of periodicity of the dependence of the SC energy in omega we have
4207 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4208 C To avoid underflows, first compute & store the exponents.
4209
4210         do iii=-1,1
4211
4212           x(3)=x3+iii*dwapi
4213
4214           do j=1,nlobit
4215             do k=1,3
4216               z(k)=x(k)-censc(k,j,it)
4217             enddo
4218             do k=1,3
4219               Axk=0.0D0
4220               do l=1,3
4221                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4222               enddo
4223               Ax(k,j,iii)=Axk
4224             enddo
4225             expfac=0.0D0
4226             do k=1,3
4227               expfac=expfac+Ax(k,j,iii)*z(k)
4228             enddo
4229             contr(j,iii)=expfac
4230           enddo ! j
4231
4232         enddo ! iii
4233
4234         x(3)=x3
4235 C As in the case of ebend, we want to avoid underflows in exponentiation and
4236 C subsequent NaNs and INFs in energy calculation.
4237 C Find the largest exponent
4238         emin=contr(1,-1)
4239         do iii=-1,1
4240           do j=1,nlobit
4241             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4242           enddo
4243         enddo
4244         emin=0.5D0*emin
4245 cd      print *,'it=',it,' emin=',emin
4246
4247 C Compute the contribution to SC energy and derivatives
4248         do iii=-1,1
4249
4250           do j=1,nlobit
4251             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4252 cd          print *,'j=',j,' expfac=',expfac
4253             escloc_i=escloc_i+expfac
4254             do k=1,3
4255               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4256             enddo
4257             if (mixed) then
4258               do k=1,3,2
4259                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4260      &            +gaussc(k,2,j,it))*expfac
4261               enddo
4262             endif
4263           enddo
4264
4265         enddo ! iii
4266
4267         dersc(1)=dersc(1)/cos(theti)**2
4268         ddersc(1)=ddersc(1)/cos(theti)**2
4269         ddersc(3)=ddersc(3)
4270
4271         escloci=-(dlog(escloc_i)-emin)
4272         do j=1,3
4273           dersc(j)=dersc(j)/escloc_i
4274         enddo
4275         if (mixed) then
4276           do j=1,3,2
4277             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4278           enddo
4279         endif
4280       return
4281       end
4282 C------------------------------------------------------------------------------
4283       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4284       implicit real*8 (a-h,o-z)
4285       include 'DIMENSIONS'
4286       include 'COMMON.GEO'
4287       include 'COMMON.LOCAL'
4288       include 'COMMON.IOUNITS'
4289       common /sccalc/ time11,time12,time112,theti,it,nlobit
4290       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4291       double precision contr(maxlob)
4292       logical mixed
4293
4294       escloc_i=0.0D0
4295
4296       do j=1,3
4297         dersc(j)=0.0D0
4298       enddo
4299
4300       do j=1,nlobit
4301         do k=1,2
4302           z(k)=x(k)-censc(k,j,it)
4303         enddo
4304         z(3)=dwapi
4305         do k=1,3
4306           Axk=0.0D0
4307           do l=1,3
4308             Axk=Axk+gaussc(l,k,j,it)*z(l)
4309           enddo
4310           Ax(k,j)=Axk
4311         enddo
4312         expfac=0.0D0
4313         do k=1,3
4314           expfac=expfac+Ax(k,j)*z(k)
4315         enddo
4316         contr(j)=expfac
4317       enddo ! j
4318
4319 C As in the case of ebend, we want to avoid underflows in exponentiation and
4320 C subsequent NaNs and INFs in energy calculation.
4321 C Find the largest exponent
4322       emin=contr(1)
4323       do j=1,nlobit
4324         if (emin.gt.contr(j)) emin=contr(j)
4325       enddo
4326       emin=0.5D0*emin
4327
4328 C Compute the contribution to SC energy and derivatives
4329
4330       dersc12=0.0d0
4331       do j=1,nlobit
4332         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4333         escloc_i=escloc_i+expfac
4334         do k=1,2
4335           dersc(k)=dersc(k)+Ax(k,j)*expfac
4336         enddo
4337         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4338      &            +gaussc(1,2,j,it))*expfac
4339         dersc(3)=0.0d0
4340       enddo
4341
4342       dersc(1)=dersc(1)/cos(theti)**2
4343       dersc12=dersc12/cos(theti)**2
4344       escloci=-(dlog(escloc_i)-emin)
4345       do j=1,2
4346         dersc(j)=dersc(j)/escloc_i
4347       enddo
4348       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4349       return
4350       end
4351 #else
4352 c----------------------------------------------------------------------------------
4353       subroutine esc(escloc)
4354 C Calculate the local energy of a side chain and its derivatives in the
4355 C corresponding virtual-bond valence angles THETA and the spherical angles
4356 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4357 C added by Urszula Kozlowska. 07/11/2007
4358 C
4359       implicit real*8 (a-h,o-z)
4360       include 'DIMENSIONS'
4361       include 'DIMENSIONS.ZSCOPT'
4362       include 'COMMON.GEO'
4363       include 'COMMON.LOCAL'
4364       include 'COMMON.VAR'
4365       include 'COMMON.SCROT'
4366       include 'COMMON.INTERACT'
4367       include 'COMMON.DERIV'
4368       include 'COMMON.CHAIN'
4369       include 'COMMON.IOUNITS'
4370       include 'COMMON.NAMES'
4371       include 'COMMON.FFIELD'
4372       include 'COMMON.CONTROL'
4373       include 'COMMON.VECTORS'
4374       double precision x_prime(3),y_prime(3),z_prime(3)
4375      &    , sumene,dsc_i,dp2_i,x(65),
4376      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4377      &    de_dxx,de_dyy,de_dzz,de_dt
4378       double precision s1_t,s1_6_t,s2_t,s2_6_t
4379       double precision
4380      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4381      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4382      & dt_dCi(3),dt_dCi1(3)
4383       common /sccalc/ time11,time12,time112,theti,it,nlobit
4384       delta=0.02d0*pi
4385       escloc=0.0D0
4386       do i=loc_start,loc_end
4387         if (itype(i).eq.ntyp1) cycle
4388         costtab(i+1) =dcos(theta(i+1))
4389         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4390         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4391         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4392         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4393         cosfac=dsqrt(cosfac2)
4394         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4395         sinfac=dsqrt(sinfac2)
4396         it=iabs(itype(i))
4397         if (it.eq.10) goto 1
4398 c
4399 C  Compute the axes of tghe local cartesian coordinates system; store in
4400 c   x_prime, y_prime and z_prime
4401 c
4402         do j=1,3
4403           x_prime(j) = 0.00
4404           y_prime(j) = 0.00
4405           z_prime(j) = 0.00
4406         enddo
4407 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4408 C     &   dc_norm(3,i+nres)
4409         do j = 1,3
4410           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4411           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4412         enddo
4413         do j = 1,3
4414           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4415         enddo
4416 c       write (2,*) "i",i
4417 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4418 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4419 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4420 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4421 c      & " xy",scalar(x_prime(1),y_prime(1)),
4422 c      & " xz",scalar(x_prime(1),z_prime(1)),
4423 c      & " yy",scalar(y_prime(1),y_prime(1)),
4424 c      & " yz",scalar(y_prime(1),z_prime(1)),
4425 c      & " zz",scalar(z_prime(1),z_prime(1))
4426 c
4427 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4428 C to local coordinate system. Store in xx, yy, zz.
4429 c
4430         xx=0.0d0
4431         yy=0.0d0
4432         zz=0.0d0
4433         do j = 1,3
4434           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4435           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4436           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4437         enddo
4438
4439         xxtab(i)=xx
4440         yytab(i)=yy
4441         zztab(i)=zz
4442 C
4443 C Compute the energy of the ith side cbain
4444 C
4445 c        write (2,*) "xx",xx," yy",yy," zz",zz
4446         it=iabs(itype(i))
4447         do j = 1,65
4448           x(j) = sc_parmin(j,it)
4449         enddo
4450 #ifdef CHECK_COORD
4451 Cc diagnostics - remove later
4452         xx1 = dcos(alph(2))
4453         yy1 = dsin(alph(2))*dcos(omeg(2))
4454         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4455         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4456      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4457      &    xx1,yy1,zz1
4458 C,"  --- ", xx_w,yy_w,zz_w
4459 c end diagnostics
4460 #endif
4461         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4462      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4463      &   + x(10)*yy*zz
4464         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4465      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4466      & + x(20)*yy*zz
4467         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4468      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4469      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4470      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4471      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4472      &  +x(40)*xx*yy*zz
4473         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4474      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4475      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4476      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4477      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4478      &  +x(60)*xx*yy*zz
4479         dsc_i   = 0.743d0+x(61)
4480         dp2_i   = 1.9d0+x(62)
4481         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4482      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4483         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4484      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4485         s1=(1+x(63))/(0.1d0 + dscp1)
4486         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4487         s2=(1+x(65))/(0.1d0 + dscp2)
4488         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4489         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4490      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4491 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4492 c     &   sumene4,
4493 c     &   dscp1,dscp2,sumene
4494 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4495         escloc = escloc + sumene
4496 c        write (2,*) "escloc",escloc
4497 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4498 c     &  zz,xx,yy
4499         if (.not. calc_grad) goto 1
4500 #ifdef DEBUG
4501 C
4502 C This section to check the numerical derivatives of the energy of ith side
4503 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4504 C #define DEBUG in the code to turn it on.
4505 C
4506         write (2,*) "sumene               =",sumene
4507         aincr=1.0d-7
4508         xxsave=xx
4509         xx=xx+aincr
4510         write (2,*) xx,yy,zz
4511         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4512         de_dxx_num=(sumenep-sumene)/aincr
4513         xx=xxsave
4514         write (2,*) "xx+ sumene from enesc=",sumenep
4515         yysave=yy
4516         yy=yy+aincr
4517         write (2,*) xx,yy,zz
4518         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4519         de_dyy_num=(sumenep-sumene)/aincr
4520         yy=yysave
4521         write (2,*) "yy+ sumene from enesc=",sumenep
4522         zzsave=zz
4523         zz=zz+aincr
4524         write (2,*) xx,yy,zz
4525         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4526         de_dzz_num=(sumenep-sumene)/aincr
4527         zz=zzsave
4528         write (2,*) "zz+ sumene from enesc=",sumenep
4529         costsave=cost2tab(i+1)
4530         sintsave=sint2tab(i+1)
4531         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4532         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4533         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4534         de_dt_num=(sumenep-sumene)/aincr
4535         write (2,*) " t+ sumene from enesc=",sumenep
4536         cost2tab(i+1)=costsave
4537         sint2tab(i+1)=sintsave
4538 C End of diagnostics section.
4539 #endif
4540 C
4541 C Compute the gradient of esc
4542 C
4543         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4544         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4545         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4546         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4547         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4548         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4549         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4550         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4551         pom1=(sumene3*sint2tab(i+1)+sumene1)
4552      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4553         pom2=(sumene4*cost2tab(i+1)+sumene2)
4554      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4555         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4556         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4557      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4558      &  +x(40)*yy*zz
4559         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4560         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4561      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4562      &  +x(60)*yy*zz
4563         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4564      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4565      &        +(pom1+pom2)*pom_dx
4566 #ifdef DEBUG
4567         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4568 #endif
4569 C
4570         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4571         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4572      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4573      &  +x(40)*xx*zz
4574         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4575         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4576      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4577      &  +x(59)*zz**2 +x(60)*xx*zz
4578         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4579      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4580      &        +(pom1-pom2)*pom_dy
4581 #ifdef DEBUG
4582         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4583 #endif
4584 C
4585         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4586      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4587      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4588      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4589      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4590      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4591      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4592      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4593 #ifdef DEBUG
4594         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4595 #endif
4596 C
4597         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4598      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4599      &  +pom1*pom_dt1+pom2*pom_dt2
4600 #ifdef DEBUG
4601         write(2,*), "de_dt = ", de_dt,de_dt_num
4602 #endif
4603 c
4604 C
4605        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4606        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4607        cosfac2xx=cosfac2*xx
4608        sinfac2yy=sinfac2*yy
4609        do k = 1,3
4610          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4611      &      vbld_inv(i+1)
4612          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4613      &      vbld_inv(i)
4614          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4615          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4616 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4617 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4618 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4619 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4620          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4621          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4622          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4623          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4624          dZZ_Ci1(k)=0.0d0
4625          dZZ_Ci(k)=0.0d0
4626          do j=1,3
4627            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4628      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4629            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4630      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4631          enddo
4632
4633          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4634          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4635          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4636 c
4637          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4638          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4639        enddo
4640
4641        do k=1,3
4642          dXX_Ctab(k,i)=dXX_Ci(k)
4643          dXX_C1tab(k,i)=dXX_Ci1(k)
4644          dYY_Ctab(k,i)=dYY_Ci(k)
4645          dYY_C1tab(k,i)=dYY_Ci1(k)
4646          dZZ_Ctab(k,i)=dZZ_Ci(k)
4647          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4648          dXX_XYZtab(k,i)=dXX_XYZ(k)
4649          dYY_XYZtab(k,i)=dYY_XYZ(k)
4650          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4651        enddo
4652
4653        do k = 1,3
4654 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4655 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4656 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4657 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4658 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4659 c     &    dt_dci(k)
4660 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4661 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4662          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4663      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4664          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4665      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4666          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4667      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4668        enddo
4669 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4670 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4671
4672 C to check gradient call subroutine check_grad
4673
4674     1 continue
4675       enddo
4676       return
4677       end
4678 #endif
4679 c------------------------------------------------------------------------------
4680       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4681 C
4682 C This procedure calculates two-body contact function g(rij) and its derivative:
4683 C
4684 C           eps0ij                                     !       x < -1
4685 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4686 C            0                                         !       x > 1
4687 C
4688 C where x=(rij-r0ij)/delta
4689 C
4690 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4691 C
4692       implicit none
4693       double precision rij,r0ij,eps0ij,fcont,fprimcont
4694       double precision x,x2,x4,delta
4695 c     delta=0.02D0*r0ij
4696 c      delta=0.2D0*r0ij
4697       x=(rij-r0ij)/delta
4698       if (x.lt.-1.0D0) then
4699         fcont=eps0ij
4700         fprimcont=0.0D0
4701       else if (x.le.1.0D0) then
4702         x2=x*x
4703         x4=x2*x2
4704         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4705         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4706       else
4707         fcont=0.0D0
4708         fprimcont=0.0D0
4709       endif
4710       return
4711       end
4712 c------------------------------------------------------------------------------
4713       subroutine splinthet(theti,delta,ss,ssder)
4714       implicit real*8 (a-h,o-z)
4715       include 'DIMENSIONS'
4716       include 'DIMENSIONS.ZSCOPT'
4717       include 'COMMON.VAR'
4718       include 'COMMON.GEO'
4719       thetup=pi-delta
4720       thetlow=delta
4721       if (theti.gt.pipol) then
4722         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4723       else
4724         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4725         ssder=-ssder
4726       endif
4727       return
4728       end
4729 c------------------------------------------------------------------------------
4730       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4731       implicit none
4732       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4733       double precision ksi,ksi2,ksi3,a1,a2,a3
4734       a1=fprim0*delta/(f1-f0)
4735       a2=3.0d0-2.0d0*a1
4736       a3=a1-2.0d0
4737       ksi=(x-x0)/delta
4738       ksi2=ksi*ksi
4739       ksi3=ksi2*ksi
4740       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4741       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4742       return
4743       end
4744 c------------------------------------------------------------------------------
4745       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4746       implicit none
4747       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4748       double precision ksi,ksi2,ksi3,a1,a2,a3
4749       ksi=(x-x0)/delta
4750       ksi2=ksi*ksi
4751       ksi3=ksi2*ksi
4752       a1=fprim0x*delta
4753       a2=3*(f1x-f0x)-2*fprim0x*delta
4754       a3=fprim0x*delta-2*(f1x-f0x)
4755       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4756       return
4757       end
4758 C-----------------------------------------------------------------------------
4759 #ifdef CRYST_TOR
4760 C-----------------------------------------------------------------------------
4761       subroutine etor(etors,edihcnstr,fact)
4762       implicit real*8 (a-h,o-z)
4763       include 'DIMENSIONS'
4764       include 'DIMENSIONS.ZSCOPT'
4765       include 'COMMON.VAR'
4766       include 'COMMON.GEO'
4767       include 'COMMON.LOCAL'
4768       include 'COMMON.TORSION'
4769       include 'COMMON.INTERACT'
4770       include 'COMMON.DERIV'
4771       include 'COMMON.CHAIN'
4772       include 'COMMON.NAMES'
4773       include 'COMMON.IOUNITS'
4774       include 'COMMON.FFIELD'
4775       include 'COMMON.TORCNSTR'
4776       logical lprn
4777 C Set lprn=.true. for debugging
4778       lprn=.false.
4779 c      lprn=.true.
4780       etors=0.0D0
4781       do i=iphi_start,iphi_end
4782         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4783      &      .or. itype(i).eq.ntyp1) cycle
4784         itori=itortyp(itype(i-2))
4785         itori1=itortyp(itype(i-1))
4786         phii=phi(i)
4787         gloci=0.0D0
4788 C Proline-Proline pair is a special case...
4789         if (itori.eq.3 .and. itori1.eq.3) then
4790           if (phii.gt.-dwapi3) then
4791             cosphi=dcos(3*phii)
4792             fac=1.0D0/(1.0D0-cosphi)
4793             etorsi=v1(1,3,3)*fac
4794             etorsi=etorsi+etorsi
4795             etors=etors+etorsi-v1(1,3,3)
4796             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4797           endif
4798           do j=1,3
4799             v1ij=v1(j+1,itori,itori1)
4800             v2ij=v2(j+1,itori,itori1)
4801             cosphi=dcos(j*phii)
4802             sinphi=dsin(j*phii)
4803             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4804             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4805           enddo
4806         else
4807           do j=1,nterm_old
4808             v1ij=v1(j,itori,itori1)
4809             v2ij=v2(j,itori,itori1)
4810             cosphi=dcos(j*phii)
4811             sinphi=dsin(j*phii)
4812             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4813             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4814           enddo
4815         endif
4816         if (lprn)
4817      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4818      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4819      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4820         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4821 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4822       enddo
4823 ! 6/20/98 - dihedral angle constraints
4824       edihcnstr=0.0d0
4825       do i=1,ndih_constr
4826         itori=idih_constr(i)
4827         phii=phi(itori)
4828         difi=phii-phi0(i)
4829         if (difi.gt.drange(i)) then
4830           difi=difi-drange(i)
4831           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4832           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4833         else if (difi.lt.-drange(i)) then
4834           difi=difi+drange(i)
4835           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4836           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4837         endif
4838 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4839 C     &    i,itori,rad2deg*phii,
4840 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4841       enddo
4842 !      write (iout,*) 'edihcnstr',edihcnstr
4843       return
4844       end
4845 c------------------------------------------------------------------------------
4846 #else
4847       subroutine etor(etors,edihcnstr,fact)
4848       implicit real*8 (a-h,o-z)
4849       include 'DIMENSIONS'
4850       include 'DIMENSIONS.ZSCOPT'
4851       include 'COMMON.VAR'
4852       include 'COMMON.GEO'
4853       include 'COMMON.LOCAL'
4854       include 'COMMON.TORSION'
4855       include 'COMMON.INTERACT'
4856       include 'COMMON.DERIV'
4857       include 'COMMON.CHAIN'
4858       include 'COMMON.NAMES'
4859       include 'COMMON.IOUNITS'
4860       include 'COMMON.FFIELD'
4861       include 'COMMON.TORCNSTR'
4862       logical lprn
4863 C Set lprn=.true. for debugging
4864       lprn=.false.
4865 c      lprn=.true.
4866       etors=0.0D0
4867       do i=iphi_start,iphi_end
4868         if (i.le.2) cycle
4869         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4870      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
4871 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4872 C     &       .or. itype(i).eq.ntyp1) cycle
4873         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4874          if (iabs(itype(i)).eq.20) then
4875          iblock=2
4876          else
4877          iblock=1
4878          endif
4879         itori=itortyp(itype(i-2))
4880         itori1=itortyp(itype(i-1))
4881         phii=phi(i)
4882         gloci=0.0D0
4883 C Regular cosine and sine terms
4884         do j=1,nterm(itori,itori1,iblock)
4885           v1ij=v1(j,itori,itori1,iblock)
4886           v2ij=v2(j,itori,itori1,iblock)
4887           cosphi=dcos(j*phii)
4888           sinphi=dsin(j*phii)
4889           etors=etors+v1ij*cosphi+v2ij*sinphi
4890           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4891         enddo
4892 C Lorentz terms
4893 C                         v1
4894 C  E = SUM ----------------------------------- - v1
4895 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4896 C
4897         cosphi=dcos(0.5d0*phii)
4898         sinphi=dsin(0.5d0*phii)
4899         do j=1,nlor(itori,itori1,iblock)
4900           vl1ij=vlor1(j,itori,itori1)
4901           vl2ij=vlor2(j,itori,itori1)
4902           vl3ij=vlor3(j,itori,itori1)
4903           pom=vl2ij*cosphi+vl3ij*sinphi
4904           pom1=1.0d0/(pom*pom+1.0d0)
4905           etors=etors+vl1ij*pom1
4906 c          if (energy_dec) etors_ii=etors_ii+
4907 c     &                vl1ij*pom1
4908           pom=-pom*pom1*pom1
4909           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4910         enddo
4911 C Subtract the constant term
4912         etors=etors-v0(itori,itori1,iblock)
4913         if (lprn)
4914      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4915      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4916      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4917         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4918 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4919  1215   continue
4920       enddo
4921 ! 6/20/98 - dihedral angle constraints
4922       edihcnstr=0.0d0
4923       do i=1,ndih_constr
4924         itori=idih_constr(i)
4925         phii=phi(itori)
4926         difi=pinorm(phii-phi0(i))
4927         edihi=0.0d0
4928         if (difi.gt.drange(i)) then
4929           difi=difi-drange(i)
4930           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4931           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4932           edihi=0.25d0*ftors(i)*difi**4
4933         else if (difi.lt.-drange(i)) then
4934           difi=difi+drange(i)
4935           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4936           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4937           edihi=0.25d0*ftors(i)*difi**4
4938         else
4939           difi=0.0d0
4940         endif
4941         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4942      &    i,itori,rad2deg*phii,
4943      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
4944 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4945 c     &    drange(i),edihi
4946 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4947 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4948       enddo
4949 !      write (iout,*) 'edihcnstr',edihcnstr
4950       return
4951       end
4952 c----------------------------------------------------------------------------
4953       subroutine etor_d(etors_d,fact2)
4954 C 6/23/01 Compute double torsional energy
4955       implicit real*8 (a-h,o-z)
4956       include 'DIMENSIONS'
4957       include 'DIMENSIONS.ZSCOPT'
4958       include 'COMMON.VAR'
4959       include 'COMMON.GEO'
4960       include 'COMMON.LOCAL'
4961       include 'COMMON.TORSION'
4962       include 'COMMON.INTERACT'
4963       include 'COMMON.DERIV'
4964       include 'COMMON.CHAIN'
4965       include 'COMMON.NAMES'
4966       include 'COMMON.IOUNITS'
4967       include 'COMMON.FFIELD'
4968       include 'COMMON.TORCNSTR'
4969       logical lprn
4970 C Set lprn=.true. for debugging
4971       lprn=.false.
4972 c     lprn=.true.
4973       etors_d=0.0D0
4974       do i=iphi_start,iphi_end-1
4975         if (i.le.3) cycle
4976 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4977 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4978          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
4979      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
4980      &  (itype(i+1).eq.ntyp1)) cycle
4981         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4982      &     goto 1215
4983         itori=itortyp(itype(i-2))
4984         itori1=itortyp(itype(i-1))
4985         itori2=itortyp(itype(i))
4986         phii=phi(i)
4987         phii1=phi(i+1)
4988         gloci1=0.0D0
4989         gloci2=0.0D0
4990         iblock=1
4991         if (iabs(itype(i+1)).eq.20) iblock=2
4992 C Regular cosine and sine terms
4993         do j=1,ntermd_1(itori,itori1,itori2,iblock)
4994           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4995           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4996           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4997           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4998           cosphi1=dcos(j*phii)
4999           sinphi1=dsin(j*phii)
5000           cosphi2=dcos(j*phii1)
5001           sinphi2=dsin(j*phii1)
5002           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5003      &     v2cij*cosphi2+v2sij*sinphi2
5004           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5005           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5006         enddo
5007         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5008           do l=1,k-1
5009             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5010             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5011             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5012             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5013             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5014             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5015             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5016             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5017             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5018      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5019             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5020      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5021             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5022      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5023           enddo
5024         enddo
5025         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5026         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5027  1215   continue
5028       enddo
5029       return
5030       end
5031 #endif
5032 c------------------------------------------------------------------------------
5033       subroutine eback_sc_corr(esccor)
5034 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5035 c        conformational states; temporarily implemented as differences
5036 c        between UNRES torsional potentials (dependent on three types of
5037 c        residues) and the torsional potentials dependent on all 20 types
5038 c        of residues computed from AM1 energy surfaces of terminally-blocked
5039 c        amino-acid residues.
5040       implicit real*8 (a-h,o-z)
5041       include 'DIMENSIONS'
5042       include 'DIMENSIONS.ZSCOPT'
5043       include 'COMMON.VAR'
5044       include 'COMMON.GEO'
5045       include 'COMMON.LOCAL'
5046       include 'COMMON.TORSION'
5047       include 'COMMON.SCCOR'
5048       include 'COMMON.INTERACT'
5049       include 'COMMON.DERIV'
5050       include 'COMMON.CHAIN'
5051       include 'COMMON.NAMES'
5052       include 'COMMON.IOUNITS'
5053       include 'COMMON.FFIELD'
5054       include 'COMMON.CONTROL'
5055       logical lprn
5056 C Set lprn=.true. for debugging
5057       lprn=.false.
5058 c      lprn=.true.
5059 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5060       esccor=0.0D0
5061       do i=itau_start,itau_end
5062         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5063         esccor_ii=0.0D0
5064         isccori=isccortyp(itype(i-2))
5065         isccori1=isccortyp(itype(i-1))
5066         phii=phi(i)
5067         do intertyp=1,3 !intertyp
5068 cc Added 09 May 2012 (Adasko)
5069 cc  Intertyp means interaction type of backbone mainchain correlation:
5070 c   1 = SC...Ca...Ca...Ca
5071 c   2 = Ca...Ca...Ca...SC
5072 c   3 = SC...Ca...Ca...SCi
5073         gloci=0.0D0
5074         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5075      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5076      &      (itype(i-1).eq.ntyp1)))
5077      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5078      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5079      &     .or.(itype(i).eq.ntyp1)))
5080      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5081      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5082      &      (itype(i-3).eq.ntyp1)))) cycle
5083         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5084         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5085      & cycle
5086        do j=1,nterm_sccor(isccori,isccori1)
5087           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5088           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5089           cosphi=dcos(j*tauangle(intertyp,i))
5090           sinphi=dsin(j*tauangle(intertyp,i))
5091            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5092            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5093          enddo
5094 C      write (iout,*)"EBACK_SC_COR",esccor,i
5095 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5096 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5097 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5098         if (lprn)
5099      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5100      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5101      &  (v1sccor(j,1,itori,itori1),j=1,6)
5102      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5103 c        gsccor_loc(i-3)=gloci
5104        enddo !intertyp
5105       enddo
5106       return
5107       end
5108 c------------------------------------------------------------------------------
5109       subroutine multibody(ecorr)
5110 C This subroutine calculates multi-body contributions to energy following
5111 C the idea of Skolnick et al. If side chains I and J make a contact and
5112 C at the same time side chains I+1 and J+1 make a contact, an extra
5113 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5114       implicit real*8 (a-h,o-z)
5115       include 'DIMENSIONS'
5116       include 'COMMON.IOUNITS'
5117       include 'COMMON.DERIV'
5118       include 'COMMON.INTERACT'
5119       include 'COMMON.CONTACTS'
5120       double precision gx(3),gx1(3)
5121       logical lprn
5122
5123 C Set lprn=.true. for debugging
5124       lprn=.false.
5125
5126       if (lprn) then
5127         write (iout,'(a)') 'Contact function values:'
5128         do i=nnt,nct-2
5129           write (iout,'(i2,20(1x,i2,f10.5))')
5130      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5131         enddo
5132       endif
5133       ecorr=0.0D0
5134       do i=nnt,nct
5135         do j=1,3
5136           gradcorr(j,i)=0.0D0
5137           gradxorr(j,i)=0.0D0
5138         enddo
5139       enddo
5140       do i=nnt,nct-2
5141
5142         DO ISHIFT = 3,4
5143
5144         i1=i+ishift
5145         num_conti=num_cont(i)
5146         num_conti1=num_cont(i1)
5147         do jj=1,num_conti
5148           j=jcont(jj,i)
5149           do kk=1,num_conti1
5150             j1=jcont(kk,i1)
5151             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5152 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5153 cd   &                   ' ishift=',ishift
5154 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5155 C The system gains extra energy.
5156               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5157             endif   ! j1==j+-ishift
5158           enddo     ! kk
5159         enddo       ! jj
5160
5161         ENDDO ! ISHIFT
5162
5163       enddo         ! i
5164       return
5165       end
5166 c------------------------------------------------------------------------------
5167       double precision function esccorr(i,j,k,l,jj,kk)
5168       implicit real*8 (a-h,o-z)
5169       include 'DIMENSIONS'
5170       include 'COMMON.IOUNITS'
5171       include 'COMMON.DERIV'
5172       include 'COMMON.INTERACT'
5173       include 'COMMON.CONTACTS'
5174       double precision gx(3),gx1(3)
5175       logical lprn
5176       lprn=.false.
5177       eij=facont(jj,i)
5178       ekl=facont(kk,k)
5179 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5180 C Calculate the multi-body contribution to energy.
5181 C Calculate multi-body contributions to the gradient.
5182 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5183 cd   & k,l,(gacont(m,kk,k),m=1,3)
5184       do m=1,3
5185         gx(m) =ekl*gacont(m,jj,i)
5186         gx1(m)=eij*gacont(m,kk,k)
5187         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5188         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5189         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5190         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5191       enddo
5192       do m=i,j-1
5193         do ll=1,3
5194           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5195         enddo
5196       enddo
5197       do m=k,l-1
5198         do ll=1,3
5199           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5200         enddo
5201       enddo
5202       esccorr=-eij*ekl
5203       return
5204       end
5205 c------------------------------------------------------------------------------
5206 #ifdef MPL
5207       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5208       implicit real*8 (a-h,o-z)
5209       include 'DIMENSIONS'
5210       integer dimen1,dimen2,atom,indx
5211       double precision buffer(dimen1,dimen2)
5212       double precision zapas
5213       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5214      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5215      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5216       num_kont=num_cont_hb(atom)
5217       do i=1,num_kont
5218         do k=1,7
5219           do j=1,3
5220             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5221           enddo ! j
5222         enddo ! k
5223         buffer(i,indx+22)=facont_hb(i,atom)
5224         buffer(i,indx+23)=ees0p(i,atom)
5225         buffer(i,indx+24)=ees0m(i,atom)
5226         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5227       enddo ! i
5228       buffer(1,indx+26)=dfloat(num_kont)
5229       return
5230       end
5231 c------------------------------------------------------------------------------
5232       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5233       implicit real*8 (a-h,o-z)
5234       include 'DIMENSIONS'
5235       integer dimen1,dimen2,atom,indx
5236       double precision buffer(dimen1,dimen2)
5237       double precision zapas
5238       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5239      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5240      &         ees0m(ntyp,maxres),
5241      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5242       num_kont=buffer(1,indx+26)
5243       num_kont_old=num_cont_hb(atom)
5244       num_cont_hb(atom)=num_kont+num_kont_old
5245       do i=1,num_kont
5246         ii=i+num_kont_old
5247         do k=1,7
5248           do j=1,3
5249             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5250           enddo ! j
5251         enddo ! k
5252         facont_hb(ii,atom)=buffer(i,indx+22)
5253         ees0p(ii,atom)=buffer(i,indx+23)
5254         ees0m(ii,atom)=buffer(i,indx+24)
5255         jcont_hb(ii,atom)=buffer(i,indx+25)
5256       enddo ! i
5257       return
5258       end
5259 c------------------------------------------------------------------------------
5260 #endif
5261       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5262 C This subroutine calculates multi-body contributions to hydrogen-bonding
5263       implicit real*8 (a-h,o-z)
5264       include 'DIMENSIONS'
5265       include 'DIMENSIONS.ZSCOPT'
5266       include 'COMMON.IOUNITS'
5267 #ifdef MPL
5268       include 'COMMON.INFO'
5269 #endif
5270       include 'COMMON.FFIELD'
5271       include 'COMMON.DERIV'
5272       include 'COMMON.INTERACT'
5273       include 'COMMON.CONTACTS'
5274 #ifdef MPL
5275       parameter (max_cont=maxconts)
5276       parameter (max_dim=2*(8*3+2))
5277       parameter (msglen1=max_cont*max_dim*4)
5278       parameter (msglen2=2*msglen1)
5279       integer source,CorrelType,CorrelID,Error
5280       double precision buffer(max_cont,max_dim)
5281 #endif
5282       double precision gx(3),gx1(3)
5283       logical lprn,ldone
5284
5285 C Set lprn=.true. for debugging
5286       lprn=.false.
5287 #ifdef MPL
5288       n_corr=0
5289       n_corr1=0
5290       if (fgProcs.le.1) goto 30
5291       if (lprn) then
5292         write (iout,'(a)') 'Contact function values:'
5293         do i=nnt,nct-2
5294           write (iout,'(2i3,50(1x,i2,f5.2))')
5295      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5296      &    j=1,num_cont_hb(i))
5297         enddo
5298       endif
5299 C Caution! Following code assumes that electrostatic interactions concerning
5300 C a given atom are split among at most two processors!
5301       CorrelType=477
5302       CorrelID=MyID+1
5303       ldone=.false.
5304       do i=1,max_cont
5305         do j=1,max_dim
5306           buffer(i,j)=0.0D0
5307         enddo
5308       enddo
5309       mm=mod(MyRank,2)
5310 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5311       if (mm) 20,20,10
5312    10 continue
5313 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5314       if (MyRank.gt.0) then
5315 C Send correlation contributions to the preceding processor
5316         msglen=msglen1
5317         nn=num_cont_hb(iatel_s)
5318         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5319 cd      write (iout,*) 'The BUFFER array:'
5320 cd      do i=1,nn
5321 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5322 cd      enddo
5323         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5324           msglen=msglen2
5325             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5326 C Clear the contacts of the atom passed to the neighboring processor
5327         nn=num_cont_hb(iatel_s+1)
5328 cd      do i=1,nn
5329 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5330 cd      enddo
5331             num_cont_hb(iatel_s)=0
5332         endif
5333 cd      write (iout,*) 'Processor ',MyID,MyRank,
5334 cd   & ' is sending correlation contribution to processor',MyID-1,
5335 cd   & ' msglen=',msglen
5336 cd      write (*,*) 'Processor ',MyID,MyRank,
5337 cd   & ' is sending correlation contribution to processor',MyID-1,
5338 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5339         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5340 cd      write (iout,*) 'Processor ',MyID,
5341 cd   & ' has sent correlation contribution to processor',MyID-1,
5342 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5343 cd      write (*,*) 'Processor ',MyID,
5344 cd   & ' has sent correlation contribution to processor',MyID-1,
5345 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5346         msglen=msglen1
5347       endif ! (MyRank.gt.0)
5348       if (ldone) goto 30
5349       ldone=.true.
5350    20 continue
5351 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5352       if (MyRank.lt.fgProcs-1) then
5353 C Receive correlation contributions from the next processor
5354         msglen=msglen1
5355         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5356 cd      write (iout,*) 'Processor',MyID,
5357 cd   & ' is receiving correlation contribution from processor',MyID+1,
5358 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5359 cd      write (*,*) 'Processor',MyID,
5360 cd   & ' is receiving correlation contribution from processor',MyID+1,
5361 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5362         nbytes=-1
5363         do while (nbytes.le.0)
5364           call mp_probe(MyID+1,CorrelType,nbytes)
5365         enddo
5366 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5367         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5368 cd      write (iout,*) 'Processor',MyID,
5369 cd   & ' has received correlation contribution from processor',MyID+1,
5370 cd   & ' msglen=',msglen,' nbytes=',nbytes
5371 cd      write (iout,*) 'The received BUFFER array:'
5372 cd      do i=1,max_cont
5373 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5374 cd      enddo
5375         if (msglen.eq.msglen1) then
5376           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5377         else if (msglen.eq.msglen2)  then
5378           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5379           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5380         else
5381           write (iout,*)
5382      & 'ERROR!!!! message length changed while processing correlations.'
5383           write (*,*)
5384      & 'ERROR!!!! message length changed while processing correlations.'
5385           call mp_stopall(Error)
5386         endif ! msglen.eq.msglen1
5387       endif ! MyRank.lt.fgProcs-1
5388       if (ldone) goto 30
5389       ldone=.true.
5390       goto 10
5391    30 continue
5392 #endif
5393       if (lprn) then
5394         write (iout,'(a)') 'Contact function values:'
5395         do i=nnt,nct-2
5396           write (iout,'(2i3,50(1x,i2,f5.2))')
5397      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5398      &    j=1,num_cont_hb(i))
5399         enddo
5400       endif
5401       ecorr=0.0D0
5402 C Remove the loop below after debugging !!!
5403       do i=nnt,nct
5404         do j=1,3
5405           gradcorr(j,i)=0.0D0
5406           gradxorr(j,i)=0.0D0
5407         enddo
5408       enddo
5409 C Calculate the local-electrostatic correlation terms
5410       do i=iatel_s,iatel_e+1
5411         i1=i+1
5412         num_conti=num_cont_hb(i)
5413         num_conti1=num_cont_hb(i+1)
5414         do jj=1,num_conti
5415           j=jcont_hb(jj,i)
5416           do kk=1,num_conti1
5417             j1=jcont_hb(kk,i1)
5418 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5419 c     &         ' jj=',jj,' kk=',kk
5420             if (j1.eq.j+1 .or. j1.eq.j-1) then
5421 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5422 C The system gains extra energy.
5423               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5424               n_corr=n_corr+1
5425             else if (j1.eq.j) then
5426 C Contacts I-J and I-(J+1) occur simultaneously.
5427 C The system loses extra energy.
5428 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5429             endif
5430           enddo ! kk
5431           do kk=1,num_conti
5432             j1=jcont_hb(kk,i)
5433 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5434 c    &         ' jj=',jj,' kk=',kk
5435             if (j1.eq.j+1) then
5436 C Contacts I-J and (I+1)-J occur simultaneously.
5437 C The system loses extra energy.
5438 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5439             endif ! j1==j+1
5440           enddo ! kk
5441         enddo ! jj
5442       enddo ! i
5443       return
5444       end
5445 c------------------------------------------------------------------------------
5446       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5447      &  n_corr1)
5448 C This subroutine calculates multi-body contributions to hydrogen-bonding
5449       implicit real*8 (a-h,o-z)
5450       include 'DIMENSIONS'
5451       include 'DIMENSIONS.ZSCOPT'
5452       include 'COMMON.IOUNITS'
5453 #ifdef MPL
5454       include 'COMMON.INFO'
5455 #endif
5456       include 'COMMON.FFIELD'
5457       include 'COMMON.DERIV'
5458       include 'COMMON.INTERACT'
5459       include 'COMMON.CONTACTS'
5460 #ifdef MPL
5461       parameter (max_cont=maxconts)
5462       parameter (max_dim=2*(8*3+2))
5463       parameter (msglen1=max_cont*max_dim*4)
5464       parameter (msglen2=2*msglen1)
5465       integer source,CorrelType,CorrelID,Error
5466       double precision buffer(max_cont,max_dim)
5467 #endif
5468       double precision gx(3),gx1(3)
5469       logical lprn,ldone
5470
5471 C Set lprn=.true. for debugging
5472       lprn=.false.
5473       eturn6=0.0d0
5474 #ifdef MPL
5475       n_corr=0
5476       n_corr1=0
5477       if (fgProcs.le.1) goto 30
5478       if (lprn) then
5479         write (iout,'(a)') 'Contact function values:'
5480         do i=nnt,nct-2
5481           write (iout,'(2i3,50(1x,i2,f5.2))')
5482      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5483      &    j=1,num_cont_hb(i))
5484         enddo
5485       endif
5486 C Caution! Following code assumes that electrostatic interactions concerning
5487 C a given atom are split among at most two processors!
5488       CorrelType=477
5489       CorrelID=MyID+1
5490       ldone=.false.
5491       do i=1,max_cont
5492         do j=1,max_dim
5493           buffer(i,j)=0.0D0
5494         enddo
5495       enddo
5496       mm=mod(MyRank,2)
5497 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5498       if (mm) 20,20,10
5499    10 continue
5500 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5501       if (MyRank.gt.0) then
5502 C Send correlation contributions to the preceding processor
5503         msglen=msglen1
5504         nn=num_cont_hb(iatel_s)
5505         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5506 cd      write (iout,*) 'The BUFFER array:'
5507 cd      do i=1,nn
5508 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5509 cd      enddo
5510         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5511           msglen=msglen2
5512             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5513 C Clear the contacts of the atom passed to the neighboring processor
5514         nn=num_cont_hb(iatel_s+1)
5515 cd      do i=1,nn
5516 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5517 cd      enddo
5518             num_cont_hb(iatel_s)=0
5519         endif
5520 cd      write (iout,*) 'Processor ',MyID,MyRank,
5521 cd   & ' is sending correlation contribution to processor',MyID-1,
5522 cd   & ' msglen=',msglen
5523 cd      write (*,*) 'Processor ',MyID,MyRank,
5524 cd   & ' is sending correlation contribution to processor',MyID-1,
5525 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5526         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5527 cd      write (iout,*) 'Processor ',MyID,
5528 cd   & ' has sent correlation contribution to processor',MyID-1,
5529 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5530 cd      write (*,*) 'Processor ',MyID,
5531 cd   & ' has sent correlation contribution to processor',MyID-1,
5532 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5533         msglen=msglen1
5534       endif ! (MyRank.gt.0)
5535       if (ldone) goto 30
5536       ldone=.true.
5537    20 continue
5538 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5539       if (MyRank.lt.fgProcs-1) then
5540 C Receive correlation contributions from the next processor
5541         msglen=msglen1
5542         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5543 cd      write (iout,*) 'Processor',MyID,
5544 cd   & ' is receiving correlation contribution from processor',MyID+1,
5545 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5546 cd      write (*,*) 'Processor',MyID,
5547 cd   & ' is receiving correlation contribution from processor',MyID+1,
5548 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5549         nbytes=-1
5550         do while (nbytes.le.0)
5551           call mp_probe(MyID+1,CorrelType,nbytes)
5552         enddo
5553 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5554         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5555 cd      write (iout,*) 'Processor',MyID,
5556 cd   & ' has received correlation contribution from processor',MyID+1,
5557 cd   & ' msglen=',msglen,' nbytes=',nbytes
5558 cd      write (iout,*) 'The received BUFFER array:'
5559 cd      do i=1,max_cont
5560 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5561 cd      enddo
5562         if (msglen.eq.msglen1) then
5563           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5564         else if (msglen.eq.msglen2)  then
5565           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5566           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5567         else
5568           write (iout,*)
5569      & 'ERROR!!!! message length changed while processing correlations.'
5570           write (*,*)
5571      & 'ERROR!!!! message length changed while processing correlations.'
5572           call mp_stopall(Error)
5573         endif ! msglen.eq.msglen1
5574       endif ! MyRank.lt.fgProcs-1
5575       if (ldone) goto 30
5576       ldone=.true.
5577       goto 10
5578    30 continue
5579 #endif
5580       if (lprn) then
5581         write (iout,'(a)') 'Contact function values:'
5582         do i=nnt,nct-2
5583           write (iout,'(2i3,50(1x,i2,f5.2))')
5584      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5585      &    j=1,num_cont_hb(i))
5586         enddo
5587       endif
5588       ecorr=0.0D0
5589       ecorr5=0.0d0
5590       ecorr6=0.0d0
5591 C Remove the loop below after debugging !!!
5592       do i=nnt,nct
5593         do j=1,3
5594           gradcorr(j,i)=0.0D0
5595           gradxorr(j,i)=0.0D0
5596         enddo
5597       enddo
5598 C Calculate the dipole-dipole interaction energies
5599       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5600       do i=iatel_s,iatel_e+1
5601         num_conti=num_cont_hb(i)
5602         do jj=1,num_conti
5603           j=jcont_hb(jj,i)
5604           call dipole(i,j,jj)
5605         enddo
5606       enddo
5607       endif
5608 C Calculate the local-electrostatic correlation terms
5609       do i=iatel_s,iatel_e+1
5610         i1=i+1
5611         num_conti=num_cont_hb(i)
5612         num_conti1=num_cont_hb(i+1)
5613         do jj=1,num_conti
5614           j=jcont_hb(jj,i)
5615           do kk=1,num_conti1
5616             j1=jcont_hb(kk,i1)
5617 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5618 c     &         ' jj=',jj,' kk=',kk
5619             if (j1.eq.j+1 .or. j1.eq.j-1) then
5620 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5621 C The system gains extra energy.
5622               n_corr=n_corr+1
5623               sqd1=dsqrt(d_cont(jj,i))
5624               sqd2=dsqrt(d_cont(kk,i1))
5625               sred_geom = sqd1*sqd2
5626               IF (sred_geom.lt.cutoff_corr) THEN
5627                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5628      &            ekont,fprimcont)
5629 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5630 c     &         ' jj=',jj,' kk=',kk
5631                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5632                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5633                 do l=1,3
5634                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5635                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5636                 enddo
5637                 n_corr1=n_corr1+1
5638 cd               write (iout,*) 'sred_geom=',sred_geom,
5639 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5640                 call calc_eello(i,j,i+1,j1,jj,kk)
5641                 if (wcorr4.gt.0.0d0)
5642      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5643                 if (wcorr5.gt.0.0d0)
5644      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5645 c                print *,"wcorr5",ecorr5
5646 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5647 cd                write(2,*)'ijkl',i,j,i+1,j1
5648                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5649      &               .or. wturn6.eq.0.0d0))then
5650 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5651                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5652 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5653 cd     &            'ecorr6=',ecorr6
5654 cd                write (iout,'(4e15.5)') sred_geom,
5655 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5656 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5657 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5658                 else if (wturn6.gt.0.0d0
5659      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5660 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5661                   eturn6=eturn6+eello_turn6(i,jj,kk)
5662 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5663                 endif
5664               ENDIF
5665 1111          continue
5666             else if (j1.eq.j) then
5667 C Contacts I-J and I-(J+1) occur simultaneously.
5668 C The system loses extra energy.
5669 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5670             endif
5671           enddo ! kk
5672           do kk=1,num_conti
5673             j1=jcont_hb(kk,i)
5674 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5675 c    &         ' jj=',jj,' kk=',kk
5676             if (j1.eq.j+1) then
5677 C Contacts I-J and (I+1)-J occur simultaneously.
5678 C The system loses extra energy.
5679 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5680             endif ! j1==j+1
5681           enddo ! kk
5682         enddo ! jj
5683       enddo ! i
5684       return
5685       end
5686 c------------------------------------------------------------------------------
5687       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5688       implicit real*8 (a-h,o-z)
5689       include 'DIMENSIONS'
5690       include 'COMMON.IOUNITS'
5691       include 'COMMON.DERIV'
5692       include 'COMMON.INTERACT'
5693       include 'COMMON.CONTACTS'
5694       double precision gx(3),gx1(3)
5695       logical lprn
5696       lprn=.false.
5697       eij=facont_hb(jj,i)
5698       ekl=facont_hb(kk,k)
5699       ees0pij=ees0p(jj,i)
5700       ees0pkl=ees0p(kk,k)
5701       ees0mij=ees0m(jj,i)
5702       ees0mkl=ees0m(kk,k)
5703       ekont=eij*ekl
5704       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5705 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5706 C Following 4 lines for diagnostics.
5707 cd    ees0pkl=0.0D0
5708 cd    ees0pij=1.0D0
5709 cd    ees0mkl=0.0D0
5710 cd    ees0mij=1.0D0
5711 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5712 c    &   ' and',k,l
5713 c     write (iout,*)'Contacts have occurred for peptide groups',
5714 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5715 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5716 C Calculate the multi-body contribution to energy.
5717       ecorr=ecorr+ekont*ees
5718       if (calc_grad) then
5719 C Calculate multi-body contributions to the gradient.
5720       do ll=1,3
5721         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5722         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5723      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5724      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5725         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5726      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5727      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5728         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5729         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5730      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5731      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5732         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5733      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5734      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5735       enddo
5736       do m=i+1,j-1
5737         do ll=1,3
5738           gradcorr(ll,m)=gradcorr(ll,m)+
5739      &     ees*ekl*gacont_hbr(ll,jj,i)-
5740      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5741      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5742         enddo
5743       enddo
5744       do m=k+1,l-1
5745         do ll=1,3
5746           gradcorr(ll,m)=gradcorr(ll,m)+
5747      &     ees*eij*gacont_hbr(ll,kk,k)-
5748      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5749      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5750         enddo
5751       enddo
5752       endif
5753       ehbcorr=ekont*ees
5754       return
5755       end
5756 C---------------------------------------------------------------------------
5757       subroutine dipole(i,j,jj)
5758       implicit real*8 (a-h,o-z)
5759       include 'DIMENSIONS'
5760       include 'DIMENSIONS.ZSCOPT'
5761       include 'COMMON.IOUNITS'
5762       include 'COMMON.CHAIN'
5763       include 'COMMON.FFIELD'
5764       include 'COMMON.DERIV'
5765       include 'COMMON.INTERACT'
5766       include 'COMMON.CONTACTS'
5767       include 'COMMON.TORSION'
5768       include 'COMMON.VAR'
5769       include 'COMMON.GEO'
5770       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5771      &  auxmat(2,2)
5772       iti1 = itortyp(itype(i+1))
5773       if (j.lt.nres-1) then
5774         if (itype(j).le.ntyp) then
5775           itj1 = itortyp(itype(j+1))
5776         else
5777           itj=ntortyp+1
5778         endif
5779       else
5780         itj1=ntortyp+1
5781       endif
5782       do iii=1,2
5783         dipi(iii,1)=Ub2(iii,i)
5784         dipderi(iii)=Ub2der(iii,i)
5785         dipi(iii,2)=b1(iii,iti1)
5786         dipj(iii,1)=Ub2(iii,j)
5787         dipderj(iii)=Ub2der(iii,j)
5788         dipj(iii,2)=b1(iii,itj1)
5789       enddo
5790       kkk=0
5791       do iii=1,2
5792         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5793         do jjj=1,2
5794           kkk=kkk+1
5795           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5796         enddo
5797       enddo
5798       if (.not.calc_grad) return
5799       do kkk=1,5
5800         do lll=1,3
5801           mmm=0
5802           do iii=1,2
5803             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5804      &        auxvec(1))
5805             do jjj=1,2
5806               mmm=mmm+1
5807               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5808             enddo
5809           enddo
5810         enddo
5811       enddo
5812       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5813       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5814       do iii=1,2
5815         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5816       enddo
5817       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5818       do iii=1,2
5819         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5820       enddo
5821       return
5822       end
5823 C---------------------------------------------------------------------------
5824       subroutine calc_eello(i,j,k,l,jj,kk)
5825 C
5826 C This subroutine computes matrices and vectors needed to calculate
5827 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5828 C
5829       implicit real*8 (a-h,o-z)
5830       include 'DIMENSIONS'
5831       include 'DIMENSIONS.ZSCOPT'
5832       include 'COMMON.IOUNITS'
5833       include 'COMMON.CHAIN'
5834       include 'COMMON.DERIV'
5835       include 'COMMON.INTERACT'
5836       include 'COMMON.CONTACTS'
5837       include 'COMMON.TORSION'
5838       include 'COMMON.VAR'
5839       include 'COMMON.GEO'
5840       include 'COMMON.FFIELD'
5841       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5842      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5843       logical lprn
5844       common /kutas/ lprn
5845 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5846 cd     & ' jj=',jj,' kk=',kk
5847 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5848       do iii=1,2
5849         do jjj=1,2
5850           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5851           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5852         enddo
5853       enddo
5854       call transpose2(aa1(1,1),aa1t(1,1))
5855       call transpose2(aa2(1,1),aa2t(1,1))
5856       do kkk=1,5
5857         do lll=1,3
5858           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5859      &      aa1tder(1,1,lll,kkk))
5860           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5861      &      aa2tder(1,1,lll,kkk))
5862         enddo
5863       enddo
5864       if (l.eq.j+1) then
5865 C parallel orientation of the two CA-CA-CA frames.
5866         if (i.gt.1 .and. itype(i).le.ntyp) then
5867           iti=itortyp(itype(i))
5868         else
5869           iti=ntortyp+1
5870         endif
5871         itk1=itortyp(itype(k+1))
5872         itj=itortyp(itype(j))
5873         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5874           itl1=itortyp(itype(l+1))
5875         else
5876           itl1=ntortyp+1
5877         endif
5878 C A1 kernel(j+1) A2T
5879 cd        do iii=1,2
5880 cd          write (iout,'(3f10.5,5x,3f10.5)')
5881 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5882 cd        enddo
5883         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5884      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5885      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5886 C Following matrices are needed only for 6-th order cumulants
5887         IF (wcorr6.gt.0.0d0) THEN
5888         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5889      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5890      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5891         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5892      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5893      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5894      &   ADtEAderx(1,1,1,1,1,1))
5895         lprn=.false.
5896         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5897      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5898      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5899      &   ADtEA1derx(1,1,1,1,1,1))
5900         ENDIF
5901 C End 6-th order cumulants
5902 cd        lprn=.false.
5903 cd        if (lprn) then
5904 cd        write (2,*) 'In calc_eello6'
5905 cd        do iii=1,2
5906 cd          write (2,*) 'iii=',iii
5907 cd          do kkk=1,5
5908 cd            write (2,*) 'kkk=',kkk
5909 cd            do jjj=1,2
5910 cd              write (2,'(3(2f10.5),5x)')
5911 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5912 cd            enddo
5913 cd          enddo
5914 cd        enddo
5915 cd        endif
5916         call transpose2(EUgder(1,1,k),auxmat(1,1))
5917         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5918         call transpose2(EUg(1,1,k),auxmat(1,1))
5919         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5920         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5921         do iii=1,2
5922           do kkk=1,5
5923             do lll=1,3
5924               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5925      &          EAEAderx(1,1,lll,kkk,iii,1))
5926             enddo
5927           enddo
5928         enddo
5929 C A1T kernel(i+1) A2
5930         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5931      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5932      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5933 C Following matrices are needed only for 6-th order cumulants
5934         IF (wcorr6.gt.0.0d0) THEN
5935         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5936      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5937      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5938         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5939      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5940      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5941      &   ADtEAderx(1,1,1,1,1,2))
5942         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5943      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5944      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5945      &   ADtEA1derx(1,1,1,1,1,2))
5946         ENDIF
5947 C End 6-th order cumulants
5948         call transpose2(EUgder(1,1,l),auxmat(1,1))
5949         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5950         call transpose2(EUg(1,1,l),auxmat(1,1))
5951         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5952         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5953         do iii=1,2
5954           do kkk=1,5
5955             do lll=1,3
5956               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5957      &          EAEAderx(1,1,lll,kkk,iii,2))
5958             enddo
5959           enddo
5960         enddo
5961 C AEAb1 and AEAb2
5962 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5963 C They are needed only when the fifth- or the sixth-order cumulants are
5964 C indluded.
5965         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5966         call transpose2(AEA(1,1,1),auxmat(1,1))
5967         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5968         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5969         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5970         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5971         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5972         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5973         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5974         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5975         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5976         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5977         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5978         call transpose2(AEA(1,1,2),auxmat(1,1))
5979         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5980         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5981         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5982         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5983         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5984         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5985         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5986         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5987         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5988         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5989         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5990 C Calculate the Cartesian derivatives of the vectors.
5991         do iii=1,2
5992           do kkk=1,5
5993             do lll=1,3
5994               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5995               call matvec2(auxmat(1,1),b1(1,iti),
5996      &          AEAb1derx(1,lll,kkk,iii,1,1))
5997               call matvec2(auxmat(1,1),Ub2(1,i),
5998      &          AEAb2derx(1,lll,kkk,iii,1,1))
5999               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6000      &          AEAb1derx(1,lll,kkk,iii,2,1))
6001               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6002      &          AEAb2derx(1,lll,kkk,iii,2,1))
6003               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6004               call matvec2(auxmat(1,1),b1(1,itj),
6005      &          AEAb1derx(1,lll,kkk,iii,1,2))
6006               call matvec2(auxmat(1,1),Ub2(1,j),
6007      &          AEAb2derx(1,lll,kkk,iii,1,2))
6008               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6009      &          AEAb1derx(1,lll,kkk,iii,2,2))
6010               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6011      &          AEAb2derx(1,lll,kkk,iii,2,2))
6012             enddo
6013           enddo
6014         enddo
6015         ENDIF
6016 C End vectors
6017       else
6018 C Antiparallel orientation of the two CA-CA-CA frames.
6019         if (i.gt.1 .and. itype(i).le.ntyp) then
6020           iti=itortyp(itype(i))
6021         else
6022           iti=ntortyp+1
6023         endif
6024         itk1=itortyp(itype(k+1))
6025         itl=itortyp(itype(l))
6026         itj=itortyp(itype(j))
6027         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6028           itj1=itortyp(itype(j+1))
6029         else
6030           itj1=ntortyp+1
6031         endif
6032 C A2 kernel(j-1)T A1T
6033         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6034      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6035      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6036 C Following matrices are needed only for 6-th order cumulants
6037         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6038      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6039         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6040      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6041      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6042         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6043      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6044      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6045      &   ADtEAderx(1,1,1,1,1,1))
6046         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6047      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6048      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6049      &   ADtEA1derx(1,1,1,1,1,1))
6050         ENDIF
6051 C End 6-th order cumulants
6052         call transpose2(EUgder(1,1,k),auxmat(1,1))
6053         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6054         call transpose2(EUg(1,1,k),auxmat(1,1))
6055         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6056         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6057         do iii=1,2
6058           do kkk=1,5
6059             do lll=1,3
6060               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6061      &          EAEAderx(1,1,lll,kkk,iii,1))
6062             enddo
6063           enddo
6064         enddo
6065 C A2T kernel(i+1)T A1
6066         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6067      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6068      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6069 C Following matrices are needed only for 6-th order cumulants
6070         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6071      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6072         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6073      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6074      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6075         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6076      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6077      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6078      &   ADtEAderx(1,1,1,1,1,2))
6079         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6080      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6081      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6082      &   ADtEA1derx(1,1,1,1,1,2))
6083         ENDIF
6084 C End 6-th order cumulants
6085         call transpose2(EUgder(1,1,j),auxmat(1,1))
6086         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6087         call transpose2(EUg(1,1,j),auxmat(1,1))
6088         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6089         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6090         do iii=1,2
6091           do kkk=1,5
6092             do lll=1,3
6093               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6094      &          EAEAderx(1,1,lll,kkk,iii,2))
6095             enddo
6096           enddo
6097         enddo
6098 C AEAb1 and AEAb2
6099 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6100 C They are needed only when the fifth- or the sixth-order cumulants are
6101 C indluded.
6102         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6103      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6104         call transpose2(AEA(1,1,1),auxmat(1,1))
6105         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6106         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6107         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6108         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6109         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6110         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6111         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6112         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6113         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6114         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6115         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6116         call transpose2(AEA(1,1,2),auxmat(1,1))
6117         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6118         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6119         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6120         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6121         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6122         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6123         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6124         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6125         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6126         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6127         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6128 C Calculate the Cartesian derivatives of the vectors.
6129         do iii=1,2
6130           do kkk=1,5
6131             do lll=1,3
6132               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6133               call matvec2(auxmat(1,1),b1(1,iti),
6134      &          AEAb1derx(1,lll,kkk,iii,1,1))
6135               call matvec2(auxmat(1,1),Ub2(1,i),
6136      &          AEAb2derx(1,lll,kkk,iii,1,1))
6137               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6138      &          AEAb1derx(1,lll,kkk,iii,2,1))
6139               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6140      &          AEAb2derx(1,lll,kkk,iii,2,1))
6141               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6142               call matvec2(auxmat(1,1),b1(1,itl),
6143      &          AEAb1derx(1,lll,kkk,iii,1,2))
6144               call matvec2(auxmat(1,1),Ub2(1,l),
6145      &          AEAb2derx(1,lll,kkk,iii,1,2))
6146               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6147      &          AEAb1derx(1,lll,kkk,iii,2,2))
6148               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6149      &          AEAb2derx(1,lll,kkk,iii,2,2))
6150             enddo
6151           enddo
6152         enddo
6153         ENDIF
6154 C End vectors
6155       endif
6156       return
6157       end
6158 C---------------------------------------------------------------------------
6159       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6160      &  KK,KKderg,AKA,AKAderg,AKAderx)
6161       implicit none
6162       integer nderg
6163       logical transp
6164       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6165      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6166      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6167       integer iii,kkk,lll
6168       integer jjj,mmm
6169       logical lprn
6170       common /kutas/ lprn
6171       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6172       do iii=1,nderg
6173         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6174      &    AKAderg(1,1,iii))
6175       enddo
6176 cd      if (lprn) write (2,*) 'In kernel'
6177       do kkk=1,5
6178 cd        if (lprn) write (2,*) 'kkk=',kkk
6179         do lll=1,3
6180           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6181      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6182 cd          if (lprn) then
6183 cd            write (2,*) 'lll=',lll
6184 cd            write (2,*) 'iii=1'
6185 cd            do jjj=1,2
6186 cd              write (2,'(3(2f10.5),5x)')
6187 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6188 cd            enddo
6189 cd          endif
6190           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6191      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6192 cd          if (lprn) then
6193 cd            write (2,*) 'lll=',lll
6194 cd            write (2,*) 'iii=2'
6195 cd            do jjj=1,2
6196 cd              write (2,'(3(2f10.5),5x)')
6197 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6198 cd            enddo
6199 cd          endif
6200         enddo
6201       enddo
6202       return
6203       end
6204 C---------------------------------------------------------------------------
6205       double precision function eello4(i,j,k,l,jj,kk)
6206       implicit real*8 (a-h,o-z)
6207       include 'DIMENSIONS'
6208       include 'DIMENSIONS.ZSCOPT'
6209       include 'COMMON.IOUNITS'
6210       include 'COMMON.CHAIN'
6211       include 'COMMON.DERIV'
6212       include 'COMMON.INTERACT'
6213       include 'COMMON.CONTACTS'
6214       include 'COMMON.TORSION'
6215       include 'COMMON.VAR'
6216       include 'COMMON.GEO'
6217       double precision pizda(2,2),ggg1(3),ggg2(3)
6218 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6219 cd        eello4=0.0d0
6220 cd        return
6221 cd      endif
6222 cd      print *,'eello4:',i,j,k,l,jj,kk
6223 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6224 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6225 cold      eij=facont_hb(jj,i)
6226 cold      ekl=facont_hb(kk,k)
6227 cold      ekont=eij*ekl
6228       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6229       if (calc_grad) then
6230 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6231       gcorr_loc(k-1)=gcorr_loc(k-1)
6232      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6233       if (l.eq.j+1) then
6234         gcorr_loc(l-1)=gcorr_loc(l-1)
6235      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6236       else
6237         gcorr_loc(j-1)=gcorr_loc(j-1)
6238      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6239       endif
6240       do iii=1,2
6241         do kkk=1,5
6242           do lll=1,3
6243             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6244      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6245 cd            derx(lll,kkk,iii)=0.0d0
6246           enddo
6247         enddo
6248       enddo
6249 cd      gcorr_loc(l-1)=0.0d0
6250 cd      gcorr_loc(j-1)=0.0d0
6251 cd      gcorr_loc(k-1)=0.0d0
6252 cd      eel4=1.0d0
6253 cd      write (iout,*)'Contacts have occurred for peptide groups',
6254 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6255 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6256       if (j.lt.nres-1) then
6257         j1=j+1
6258         j2=j-1
6259       else
6260         j1=j-1
6261         j2=j-2
6262       endif
6263       if (l.lt.nres-1) then
6264         l1=l+1
6265         l2=l-1
6266       else
6267         l1=l-1
6268         l2=l-2
6269       endif
6270       do ll=1,3
6271 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6272         ggg1(ll)=eel4*g_contij(ll,1)
6273         ggg2(ll)=eel4*g_contij(ll,2)
6274         ghalf=0.5d0*ggg1(ll)
6275 cd        ghalf=0.0d0
6276         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6277         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6278         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6279         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6280 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6281         ghalf=0.5d0*ggg2(ll)
6282 cd        ghalf=0.0d0
6283         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6284         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6285         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6286         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6287       enddo
6288 cd      goto 1112
6289       do m=i+1,j-1
6290         do ll=1,3
6291 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6292           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6293         enddo
6294       enddo
6295       do m=k+1,l-1
6296         do ll=1,3
6297 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6298           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6299         enddo
6300       enddo
6301 1112  continue
6302       do m=i+2,j2
6303         do ll=1,3
6304           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6305         enddo
6306       enddo
6307       do m=k+2,l2
6308         do ll=1,3
6309           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6310         enddo
6311       enddo
6312 cd      do iii=1,nres-3
6313 cd        write (2,*) iii,gcorr_loc(iii)
6314 cd      enddo
6315       endif
6316       eello4=ekont*eel4
6317 cd      write (2,*) 'ekont',ekont
6318 cd      write (iout,*) 'eello4',ekont*eel4
6319       return
6320       end
6321 C---------------------------------------------------------------------------
6322       double precision function eello5(i,j,k,l,jj,kk)
6323       implicit real*8 (a-h,o-z)
6324       include 'DIMENSIONS'
6325       include 'DIMENSIONS.ZSCOPT'
6326       include 'COMMON.IOUNITS'
6327       include 'COMMON.CHAIN'
6328       include 'COMMON.DERIV'
6329       include 'COMMON.INTERACT'
6330       include 'COMMON.CONTACTS'
6331       include 'COMMON.TORSION'
6332       include 'COMMON.VAR'
6333       include 'COMMON.GEO'
6334       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6335       double precision ggg1(3),ggg2(3)
6336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6337 C                                                                              C
6338 C                            Parallel chains                                   C
6339 C                                                                              C
6340 C          o             o                   o             o                   C
6341 C         /l\           / \             \   / \           / \   /              C
6342 C        /   \         /   \             \ /   \         /   \ /               C
6343 C       j| o |l1       | o |              o| o |         | o |o                C
6344 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6345 C      \i/   \         /   \ /             /   \         /   \                 C
6346 C       o    k1             o                                                  C
6347 C         (I)          (II)                (III)          (IV)                 C
6348 C                                                                              C
6349 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6350 C                                                                              C
6351 C                            Antiparallel chains                               C
6352 C                                                                              C
6353 C          o             o                   o             o                   C
6354 C         /j\           / \             \   / \           / \   /              C
6355 C        /   \         /   \             \ /   \         /   \ /               C
6356 C      j1| o |l        | o |              o| o |         | o |o                C
6357 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6358 C      \i/   \         /   \ /             /   \         /   \                 C
6359 C       o     k1            o                                                  C
6360 C         (I)          (II)                (III)          (IV)                 C
6361 C                                                                              C
6362 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6363 C                                                                              C
6364 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6365 C                                                                              C
6366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6367 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6368 cd        eello5=0.0d0
6369 cd        return
6370 cd      endif
6371 cd      write (iout,*)
6372 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6373 cd     &   ' and',k,l
6374       itk=itortyp(itype(k))
6375       itl=itortyp(itype(l))
6376       itj=itortyp(itype(j))
6377       eello5_1=0.0d0
6378       eello5_2=0.0d0
6379       eello5_3=0.0d0
6380       eello5_4=0.0d0
6381 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6382 cd     &   eel5_3_num,eel5_4_num)
6383       do iii=1,2
6384         do kkk=1,5
6385           do lll=1,3
6386             derx(lll,kkk,iii)=0.0d0
6387           enddo
6388         enddo
6389       enddo
6390 cd      eij=facont_hb(jj,i)
6391 cd      ekl=facont_hb(kk,k)
6392 cd      ekont=eij*ekl
6393 cd      write (iout,*)'Contacts have occurred for peptide groups',
6394 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6395 cd      goto 1111
6396 C Contribution from the graph I.
6397 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6398 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6399       call transpose2(EUg(1,1,k),auxmat(1,1))
6400       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6401       vv(1)=pizda(1,1)-pizda(2,2)
6402       vv(2)=pizda(1,2)+pizda(2,1)
6403       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6404      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6405       if (calc_grad) then
6406 C Explicit gradient in virtual-dihedral angles.
6407       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6408      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6409      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6410       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6411       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6412       vv(1)=pizda(1,1)-pizda(2,2)
6413       vv(2)=pizda(1,2)+pizda(2,1)
6414       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6415      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6416      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6417       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6418       vv(1)=pizda(1,1)-pizda(2,2)
6419       vv(2)=pizda(1,2)+pizda(2,1)
6420       if (l.eq.j+1) then
6421         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6422      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6423      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6424       else
6425         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6426      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6427      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6428       endif
6429 C Cartesian gradient
6430       do iii=1,2
6431         do kkk=1,5
6432           do lll=1,3
6433             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6434      &        pizda(1,1))
6435             vv(1)=pizda(1,1)-pizda(2,2)
6436             vv(2)=pizda(1,2)+pizda(2,1)
6437             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6438      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6439      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6440           enddo
6441         enddo
6442       enddo
6443 c      goto 1112
6444       endif
6445 c1111  continue
6446 C Contribution from graph II
6447       call transpose2(EE(1,1,itk),auxmat(1,1))
6448       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6449       vv(1)=pizda(1,1)+pizda(2,2)
6450       vv(2)=pizda(2,1)-pizda(1,2)
6451       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6452      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6453       if (calc_grad) then
6454 C Explicit gradient in virtual-dihedral angles.
6455       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6456      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6457       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6458       vv(1)=pizda(1,1)+pizda(2,2)
6459       vv(2)=pizda(2,1)-pizda(1,2)
6460       if (l.eq.j+1) then
6461         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6462      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6463      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6464       else
6465         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6466      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6467      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6468       endif
6469 C Cartesian gradient
6470       do iii=1,2
6471         do kkk=1,5
6472           do lll=1,3
6473             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6474      &        pizda(1,1))
6475             vv(1)=pizda(1,1)+pizda(2,2)
6476             vv(2)=pizda(2,1)-pizda(1,2)
6477             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6478      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6479      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6480           enddo
6481         enddo
6482       enddo
6483 cd      goto 1112
6484       endif
6485 cd1111  continue
6486       if (l.eq.j+1) then
6487 cd        goto 1110
6488 C Parallel orientation
6489 C Contribution from graph III
6490         call transpose2(EUg(1,1,l),auxmat(1,1))
6491         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6492         vv(1)=pizda(1,1)-pizda(2,2)
6493         vv(2)=pizda(1,2)+pizda(2,1)
6494         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6495      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6496         if (calc_grad) then
6497 C Explicit gradient in virtual-dihedral angles.
6498         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6499      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6500      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6501         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6502         vv(1)=pizda(1,1)-pizda(2,2)
6503         vv(2)=pizda(1,2)+pizda(2,1)
6504         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6505      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6506      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6507         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6508         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6509         vv(1)=pizda(1,1)-pizda(2,2)
6510         vv(2)=pizda(1,2)+pizda(2,1)
6511         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6512      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6513      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6514 C Cartesian gradient
6515         do iii=1,2
6516           do kkk=1,5
6517             do lll=1,3
6518               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6519      &          pizda(1,1))
6520               vv(1)=pizda(1,1)-pizda(2,2)
6521               vv(2)=pizda(1,2)+pizda(2,1)
6522               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6523      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6524      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6525             enddo
6526           enddo
6527         enddo
6528 cd        goto 1112
6529         endif
6530 C Contribution from graph IV
6531 cd1110    continue
6532         call transpose2(EE(1,1,itl),auxmat(1,1))
6533         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6534         vv(1)=pizda(1,1)+pizda(2,2)
6535         vv(2)=pizda(2,1)-pizda(1,2)
6536         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6537      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6538         if (calc_grad) then
6539 C Explicit gradient in virtual-dihedral angles.
6540         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6541      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6542         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6543         vv(1)=pizda(1,1)+pizda(2,2)
6544         vv(2)=pizda(2,1)-pizda(1,2)
6545         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6546      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6547      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6548 C Cartesian gradient
6549         do iii=1,2
6550           do kkk=1,5
6551             do lll=1,3
6552               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6553      &          pizda(1,1))
6554               vv(1)=pizda(1,1)+pizda(2,2)
6555               vv(2)=pizda(2,1)-pizda(1,2)
6556               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6557      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6558      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6559             enddo
6560           enddo
6561         enddo
6562         endif
6563       else
6564 C Antiparallel orientation
6565 C Contribution from graph III
6566 c        goto 1110
6567         call transpose2(EUg(1,1,j),auxmat(1,1))
6568         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6569         vv(1)=pizda(1,1)-pizda(2,2)
6570         vv(2)=pizda(1,2)+pizda(2,1)
6571         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6572      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6573         if (calc_grad) then
6574 C Explicit gradient in virtual-dihedral angles.
6575         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6576      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6577      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6578         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6579         vv(1)=pizda(1,1)-pizda(2,2)
6580         vv(2)=pizda(1,2)+pizda(2,1)
6581         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6582      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6583      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6584         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6585         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6586         vv(1)=pizda(1,1)-pizda(2,2)
6587         vv(2)=pizda(1,2)+pizda(2,1)
6588         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6589      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6591 C Cartesian gradient
6592         do iii=1,2
6593           do kkk=1,5
6594             do lll=1,3
6595               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6596      &          pizda(1,1))
6597               vv(1)=pizda(1,1)-pizda(2,2)
6598               vv(2)=pizda(1,2)+pizda(2,1)
6599               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6600      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6601      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6602             enddo
6603           enddo
6604         enddo
6605 cd        goto 1112
6606         endif
6607 C Contribution from graph IV
6608 1110    continue
6609         call transpose2(EE(1,1,itj),auxmat(1,1))
6610         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6611         vv(1)=pizda(1,1)+pizda(2,2)
6612         vv(2)=pizda(2,1)-pizda(1,2)
6613         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6614      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6615         if (calc_grad) then
6616 C Explicit gradient in virtual-dihedral angles.
6617         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6618      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6619         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6620         vv(1)=pizda(1,1)+pizda(2,2)
6621         vv(2)=pizda(2,1)-pizda(1,2)
6622         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6623      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6624      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6625 C Cartesian gradient
6626         do iii=1,2
6627           do kkk=1,5
6628             do lll=1,3
6629               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6630      &          pizda(1,1))
6631               vv(1)=pizda(1,1)+pizda(2,2)
6632               vv(2)=pizda(2,1)-pizda(1,2)
6633               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6634      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6635      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6636             enddo
6637           enddo
6638         enddo
6639       endif
6640       endif
6641 1112  continue
6642       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6643 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6644 cd        write (2,*) 'ijkl',i,j,k,l
6645 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6646 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6647 cd      endif
6648 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6649 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6650 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6651 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6652       if (calc_grad) then
6653       if (j.lt.nres-1) then
6654         j1=j+1
6655         j2=j-1
6656       else
6657         j1=j-1
6658         j2=j-2
6659       endif
6660       if (l.lt.nres-1) then
6661         l1=l+1
6662         l2=l-1
6663       else
6664         l1=l-1
6665         l2=l-2
6666       endif
6667 cd      eij=1.0d0
6668 cd      ekl=1.0d0
6669 cd      ekont=1.0d0
6670 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6671       do ll=1,3
6672         ggg1(ll)=eel5*g_contij(ll,1)
6673         ggg2(ll)=eel5*g_contij(ll,2)
6674 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6675         ghalf=0.5d0*ggg1(ll)
6676 cd        ghalf=0.0d0
6677         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6678         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6679         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6680         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6681 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6682         ghalf=0.5d0*ggg2(ll)
6683 cd        ghalf=0.0d0
6684         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6685         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6686         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6687         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6688       enddo
6689 cd      goto 1112
6690       do m=i+1,j-1
6691         do ll=1,3
6692 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6693           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6694         enddo
6695       enddo
6696       do m=k+1,l-1
6697         do ll=1,3
6698 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6699           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6700         enddo
6701       enddo
6702 c1112  continue
6703       do m=i+2,j2
6704         do ll=1,3
6705           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6706         enddo
6707       enddo
6708       do m=k+2,l2
6709         do ll=1,3
6710           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6711         enddo
6712       enddo
6713 cd      do iii=1,nres-3
6714 cd        write (2,*) iii,g_corr5_loc(iii)
6715 cd      enddo
6716       endif
6717       eello5=ekont*eel5
6718 cd      write (2,*) 'ekont',ekont
6719 cd      write (iout,*) 'eello5',ekont*eel5
6720       return
6721       end
6722 c--------------------------------------------------------------------------
6723       double precision function eello6(i,j,k,l,jj,kk)
6724       implicit real*8 (a-h,o-z)
6725       include 'DIMENSIONS'
6726       include 'DIMENSIONS.ZSCOPT'
6727       include 'COMMON.IOUNITS'
6728       include 'COMMON.CHAIN'
6729       include 'COMMON.DERIV'
6730       include 'COMMON.INTERACT'
6731       include 'COMMON.CONTACTS'
6732       include 'COMMON.TORSION'
6733       include 'COMMON.VAR'
6734       include 'COMMON.GEO'
6735       include 'COMMON.FFIELD'
6736       double precision ggg1(3),ggg2(3)
6737 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6738 cd        eello6=0.0d0
6739 cd        return
6740 cd      endif
6741 cd      write (iout,*)
6742 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6743 cd     &   ' and',k,l
6744       eello6_1=0.0d0
6745       eello6_2=0.0d0
6746       eello6_3=0.0d0
6747       eello6_4=0.0d0
6748       eello6_5=0.0d0
6749       eello6_6=0.0d0
6750 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6751 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6752       do iii=1,2
6753         do kkk=1,5
6754           do lll=1,3
6755             derx(lll,kkk,iii)=0.0d0
6756           enddo
6757         enddo
6758       enddo
6759 cd      eij=facont_hb(jj,i)
6760 cd      ekl=facont_hb(kk,k)
6761 cd      ekont=eij*ekl
6762 cd      eij=1.0d0
6763 cd      ekl=1.0d0
6764 cd      ekont=1.0d0
6765       if (l.eq.j+1) then
6766         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6767         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6768         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6769         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6770         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6771         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6772       else
6773         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6774         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6775         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6776         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6777         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6778           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6779         else
6780           eello6_5=0.0d0
6781         endif
6782         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6783       endif
6784 C If turn contributions are considered, they will be handled separately.
6785       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6786 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6787 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6788 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6789 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6790 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6791 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6792 cd      goto 1112
6793       if (calc_grad) then
6794       if (j.lt.nres-1) then
6795         j1=j+1
6796         j2=j-1
6797       else
6798         j1=j-1
6799         j2=j-2
6800       endif
6801       if (l.lt.nres-1) then
6802         l1=l+1
6803         l2=l-1
6804       else
6805         l1=l-1
6806         l2=l-2
6807       endif
6808       do ll=1,3
6809         ggg1(ll)=eel6*g_contij(ll,1)
6810         ggg2(ll)=eel6*g_contij(ll,2)
6811 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6812         ghalf=0.5d0*ggg1(ll)
6813 cd        ghalf=0.0d0
6814         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6815         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6816         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6817         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6818         ghalf=0.5d0*ggg2(ll)
6819 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6820 cd        ghalf=0.0d0
6821         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6822         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6823         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6824         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6825       enddo
6826 cd      goto 1112
6827       do m=i+1,j-1
6828         do ll=1,3
6829 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6830           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6831         enddo
6832       enddo
6833       do m=k+1,l-1
6834         do ll=1,3
6835 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6836           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6837         enddo
6838       enddo
6839 1112  continue
6840       do m=i+2,j2
6841         do ll=1,3
6842           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6843         enddo
6844       enddo
6845       do m=k+2,l2
6846         do ll=1,3
6847           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6848         enddo
6849       enddo
6850 cd      do iii=1,nres-3
6851 cd        write (2,*) iii,g_corr6_loc(iii)
6852 cd      enddo
6853       endif
6854       eello6=ekont*eel6
6855 cd      write (2,*) 'ekont',ekont
6856 cd      write (iout,*) 'eello6',ekont*eel6
6857       return
6858       end
6859 c--------------------------------------------------------------------------
6860       double precision function eello6_graph1(i,j,k,l,imat,swap)
6861       implicit real*8 (a-h,o-z)
6862       include 'DIMENSIONS'
6863       include 'DIMENSIONS.ZSCOPT'
6864       include 'COMMON.IOUNITS'
6865       include 'COMMON.CHAIN'
6866       include 'COMMON.DERIV'
6867       include 'COMMON.INTERACT'
6868       include 'COMMON.CONTACTS'
6869       include 'COMMON.TORSION'
6870       include 'COMMON.VAR'
6871       include 'COMMON.GEO'
6872       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6873       logical swap
6874       logical lprn
6875       common /kutas/ lprn
6876 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6877 C                                                                              C
6878 C      Parallel       Antiparallel                                             C
6879 C                                                                              C
6880 C          o             o                                                     C
6881 C         /l\           /j\                                                    C
6882 C        /   \         /   \                                                   C
6883 C       /| o |         | o |\                                                  C
6884 C     \ j|/k\|  /   \  |/k\|l /                                                C
6885 C      \ /   \ /     \ /   \ /                                                 C
6886 C       o     o       o     o                                                  C
6887 C       i             i                                                        C
6888 C                                                                              C
6889 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6890       itk=itortyp(itype(k))
6891       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6892       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6893       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6894       call transpose2(EUgC(1,1,k),auxmat(1,1))
6895       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6896       vv1(1)=pizda1(1,1)-pizda1(2,2)
6897       vv1(2)=pizda1(1,2)+pizda1(2,1)
6898       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6899       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6900       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6901       s5=scalar2(vv(1),Dtobr2(1,i))
6902 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6903       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6904       if (.not. calc_grad) return
6905       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6906      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6907      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6908      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6909      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6910      & +scalar2(vv(1),Dtobr2der(1,i)))
6911       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6912       vv1(1)=pizda1(1,1)-pizda1(2,2)
6913       vv1(2)=pizda1(1,2)+pizda1(2,1)
6914       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6915       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6916       if (l.eq.j+1) then
6917         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6918      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6919      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6920      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6921      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6922       else
6923         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6924      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6925      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6926      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6927      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6928       endif
6929       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6930       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6931       vv1(1)=pizda1(1,1)-pizda1(2,2)
6932       vv1(2)=pizda1(1,2)+pizda1(2,1)
6933       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6934      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6935      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6936      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6937       do iii=1,2
6938         if (swap) then
6939           ind=3-iii
6940         else
6941           ind=iii
6942         endif
6943         do kkk=1,5
6944           do lll=1,3
6945             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6946             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6947             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6948             call transpose2(EUgC(1,1,k),auxmat(1,1))
6949             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6950      &        pizda1(1,1))
6951             vv1(1)=pizda1(1,1)-pizda1(2,2)
6952             vv1(2)=pizda1(1,2)+pizda1(2,1)
6953             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6954             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6955      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6956             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6957      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6958             s5=scalar2(vv(1),Dtobr2(1,i))
6959             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6960           enddo
6961         enddo
6962       enddo
6963       return
6964       end
6965 c----------------------------------------------------------------------------
6966       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6967       implicit real*8 (a-h,o-z)
6968       include 'DIMENSIONS'
6969       include 'DIMENSIONS.ZSCOPT'
6970       include 'COMMON.IOUNITS'
6971       include 'COMMON.CHAIN'
6972       include 'COMMON.DERIV'
6973       include 'COMMON.INTERACT'
6974       include 'COMMON.CONTACTS'
6975       include 'COMMON.TORSION'
6976       include 'COMMON.VAR'
6977       include 'COMMON.GEO'
6978       logical swap
6979       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6980      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6981       logical lprn
6982       common /kutas/ lprn
6983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6984 C                                                                              C
6985 C      Parallel       Antiparallel                                             C
6986 C                                                                              C
6987 C          o             o                                                     C
6988 C     \   /l\           /j\   /                                                C
6989 C      \ /   \         /   \ /                                                 C
6990 C       o| o |         | o |o                                                  C
6991 C     \ j|/k\|      \  |/k\|l                                                  C
6992 C      \ /   \       \ /   \                                                   C
6993 C       o             o                                                        C
6994 C       i             i                                                        C
6995 C                                                                              C
6996 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6997 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6998 C AL 7/4/01 s1 would occur in the sixth-order moment,
6999 C           but not in a cluster cumulant
7000 #ifdef MOMENT
7001       s1=dip(1,jj,i)*dip(1,kk,k)
7002 #endif
7003       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7004       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7005       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7006       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7007       call transpose2(EUg(1,1,k),auxmat(1,1))
7008       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7009       vv(1)=pizda(1,1)-pizda(2,2)
7010       vv(2)=pizda(1,2)+pizda(2,1)
7011       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7012 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7013 #ifdef MOMENT
7014       eello6_graph2=-(s1+s2+s3+s4)
7015 #else
7016       eello6_graph2=-(s2+s3+s4)
7017 #endif
7018 c      eello6_graph2=-s3
7019       if (.not. calc_grad) return
7020 C Derivatives in gamma(i-1)
7021       if (i.gt.1) then
7022 #ifdef MOMENT
7023         s1=dipderg(1,jj,i)*dip(1,kk,k)
7024 #endif
7025         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7026         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7027         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7028         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7029 #ifdef MOMENT
7030         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7031 #else
7032         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7033 #endif
7034 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7035       endif
7036 C Derivatives in gamma(k-1)
7037 #ifdef MOMENT
7038       s1=dip(1,jj,i)*dipderg(1,kk,k)
7039 #endif
7040       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7041       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7042       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7043       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7044       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7045       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7046       vv(1)=pizda(1,1)-pizda(2,2)
7047       vv(2)=pizda(1,2)+pizda(2,1)
7048       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7049 #ifdef MOMENT
7050       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7051 #else
7052       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7053 #endif
7054 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7055 C Derivatives in gamma(j-1) or gamma(l-1)
7056       if (j.gt.1) then
7057 #ifdef MOMENT
7058         s1=dipderg(3,jj,i)*dip(1,kk,k)
7059 #endif
7060         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7061         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7062         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7063         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7064         vv(1)=pizda(1,1)-pizda(2,2)
7065         vv(2)=pizda(1,2)+pizda(2,1)
7066         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7067 #ifdef MOMENT
7068         if (swap) then
7069           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7070         else
7071           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7072         endif
7073 #endif
7074         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7075 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7076       endif
7077 C Derivatives in gamma(l-1) or gamma(j-1)
7078       if (l.gt.1) then
7079 #ifdef MOMENT
7080         s1=dip(1,jj,i)*dipderg(3,kk,k)
7081 #endif
7082         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7083         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7084         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7085         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7086         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7087         vv(1)=pizda(1,1)-pizda(2,2)
7088         vv(2)=pizda(1,2)+pizda(2,1)
7089         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7090 #ifdef MOMENT
7091         if (swap) then
7092           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7093         else
7094           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7095         endif
7096 #endif
7097         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7098 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7099       endif
7100 C Cartesian derivatives.
7101       if (lprn) then
7102         write (2,*) 'In eello6_graph2'
7103         do iii=1,2
7104           write (2,*) 'iii=',iii
7105           do kkk=1,5
7106             write (2,*) 'kkk=',kkk
7107             do jjj=1,2
7108               write (2,'(3(2f10.5),5x)')
7109      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7110             enddo
7111           enddo
7112         enddo
7113       endif
7114       do iii=1,2
7115         do kkk=1,5
7116           do lll=1,3
7117 #ifdef MOMENT
7118             if (iii.eq.1) then
7119               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7120             else
7121               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7122             endif
7123 #endif
7124             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7125      &        auxvec(1))
7126             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7127             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7128      &        auxvec(1))
7129             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7130             call transpose2(EUg(1,1,k),auxmat(1,1))
7131             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7132      &        pizda(1,1))
7133             vv(1)=pizda(1,1)-pizda(2,2)
7134             vv(2)=pizda(1,2)+pizda(2,1)
7135             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7136 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7137 #ifdef MOMENT
7138             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7139 #else
7140             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7141 #endif
7142             if (swap) then
7143               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7144             else
7145               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7146             endif
7147           enddo
7148         enddo
7149       enddo
7150       return
7151       end
7152 c----------------------------------------------------------------------------
7153       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7154       implicit real*8 (a-h,o-z)
7155       include 'DIMENSIONS'
7156       include 'DIMENSIONS.ZSCOPT'
7157       include 'COMMON.IOUNITS'
7158       include 'COMMON.CHAIN'
7159       include 'COMMON.DERIV'
7160       include 'COMMON.INTERACT'
7161       include 'COMMON.CONTACTS'
7162       include 'COMMON.TORSION'
7163       include 'COMMON.VAR'
7164       include 'COMMON.GEO'
7165       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7166       logical swap
7167 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7168 C                                                                              C
7169 C      Parallel       Antiparallel                                             C
7170 C                                                                              C
7171 C          o             o                                                     C
7172 C         /l\   /   \   /j\                                                    C
7173 C        /   \ /     \ /   \                                                   C
7174 C       /| o |o       o| o |\                                                  C
7175 C       j|/k\|  /      |/k\|l /                                                C
7176 C        /   \ /       /   \ /                                                 C
7177 C       /     o       /     o                                                  C
7178 C       i             i                                                        C
7179 C                                                                              C
7180 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7181 C
7182 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7183 C           energy moment and not to the cluster cumulant.
7184       iti=itortyp(itype(i))
7185       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7186         itj1=itortyp(itype(j+1))
7187       else
7188         itj1=ntortyp+1
7189       endif
7190       itk=itortyp(itype(k))
7191       itk1=itortyp(itype(k+1))
7192       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7193         itl1=itortyp(itype(l+1))
7194       else
7195         itl1=ntortyp+1
7196       endif
7197 #ifdef MOMENT
7198       s1=dip(4,jj,i)*dip(4,kk,k)
7199 #endif
7200       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7201       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7202       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7203       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7204       call transpose2(EE(1,1,itk),auxmat(1,1))
7205       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7206       vv(1)=pizda(1,1)+pizda(2,2)
7207       vv(2)=pizda(2,1)-pizda(1,2)
7208       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7209 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7210 #ifdef MOMENT
7211       eello6_graph3=-(s1+s2+s3+s4)
7212 #else
7213       eello6_graph3=-(s2+s3+s4)
7214 #endif
7215 c      eello6_graph3=-s4
7216       if (.not. calc_grad) return
7217 C Derivatives in gamma(k-1)
7218       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7219       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7220       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7221       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7222 C Derivatives in gamma(l-1)
7223       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7224       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7225       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7226       vv(1)=pizda(1,1)+pizda(2,2)
7227       vv(2)=pizda(2,1)-pizda(1,2)
7228       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7229       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7230 C Cartesian derivatives.
7231       do iii=1,2
7232         do kkk=1,5
7233           do lll=1,3
7234 #ifdef MOMENT
7235             if (iii.eq.1) then
7236               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7237             else
7238               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7239             endif
7240 #endif
7241             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7242      &        auxvec(1))
7243             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7244             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7245      &        auxvec(1))
7246             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7247             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7248      &        pizda(1,1))
7249             vv(1)=pizda(1,1)+pizda(2,2)
7250             vv(2)=pizda(2,1)-pizda(1,2)
7251             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7252 #ifdef MOMENT
7253             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7254 #else
7255             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7256 #endif
7257             if (swap) then
7258               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7259             else
7260               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7261             endif
7262 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7263           enddo
7264         enddo
7265       enddo
7266       return
7267       end
7268 c----------------------------------------------------------------------------
7269       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7270       implicit real*8 (a-h,o-z)
7271       include 'DIMENSIONS'
7272       include 'DIMENSIONS.ZSCOPT'
7273       include 'COMMON.IOUNITS'
7274       include 'COMMON.CHAIN'
7275       include 'COMMON.DERIV'
7276       include 'COMMON.INTERACT'
7277       include 'COMMON.CONTACTS'
7278       include 'COMMON.TORSION'
7279       include 'COMMON.VAR'
7280       include 'COMMON.GEO'
7281       include 'COMMON.FFIELD'
7282       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7283      & auxvec1(2),auxmat1(2,2)
7284       logical swap
7285 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7286 C                                                                              C
7287 C      Parallel       Antiparallel                                             C
7288 C                                                                              C
7289 C          o             o                                                     C
7290 C         /l\   /   \   /j\                                                    C
7291 C        /   \ /     \ /   \                                                   C
7292 C       /| o |o       o| o |\                                                  C
7293 C     \ j|/k\|      \  |/k\|l                                                  C
7294 C      \ /   \       \ /   \                                                   C
7295 C       o     \       o     \                                                  C
7296 C       i             i                                                        C
7297 C                                                                              C
7298 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7299 C
7300 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7301 C           energy moment and not to the cluster cumulant.
7302 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7303       iti=itortyp(itype(i))
7304       itj=itortyp(itype(j))
7305       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7306         itj1=itortyp(itype(j+1))
7307       else
7308         itj1=ntortyp+1
7309       endif
7310       itk=itortyp(itype(k))
7311       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7312         itk1=itortyp(itype(k+1))
7313       else
7314         itk1=ntortyp+1
7315       endif
7316       itl=itortyp(itype(l))
7317       if (l.lt.nres-1) then
7318         itl1=itortyp(itype(l+1))
7319       else
7320         itl1=ntortyp+1
7321       endif
7322 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7323 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7324 cd     & ' itl',itl,' itl1',itl1
7325 #ifdef MOMENT
7326       if (imat.eq.1) then
7327         s1=dip(3,jj,i)*dip(3,kk,k)
7328       else
7329         s1=dip(2,jj,j)*dip(2,kk,l)
7330       endif
7331 #endif
7332       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7333       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7334       if (j.eq.l+1) then
7335         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7336         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7337       else
7338         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7339         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7340       endif
7341       call transpose2(EUg(1,1,k),auxmat(1,1))
7342       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7343       vv(1)=pizda(1,1)-pizda(2,2)
7344       vv(2)=pizda(2,1)+pizda(1,2)
7345       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7346 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7347 #ifdef MOMENT
7348       eello6_graph4=-(s1+s2+s3+s4)
7349 #else
7350       eello6_graph4=-(s2+s3+s4)
7351 #endif
7352       if (.not. calc_grad) return
7353 C Derivatives in gamma(i-1)
7354       if (i.gt.1) then
7355 #ifdef MOMENT
7356         if (imat.eq.1) then
7357           s1=dipderg(2,jj,i)*dip(3,kk,k)
7358         else
7359           s1=dipderg(4,jj,j)*dip(2,kk,l)
7360         endif
7361 #endif
7362         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7363         if (j.eq.l+1) then
7364           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7365           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7366         else
7367           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7368           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7369         endif
7370         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7371         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7372 cd          write (2,*) 'turn6 derivatives'
7373 #ifdef MOMENT
7374           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7375 #else
7376           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7377 #endif
7378         else
7379 #ifdef MOMENT
7380           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7381 #else
7382           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7383 #endif
7384         endif
7385       endif
7386 C Derivatives in gamma(k-1)
7387 #ifdef MOMENT
7388       if (imat.eq.1) then
7389         s1=dip(3,jj,i)*dipderg(2,kk,k)
7390       else
7391         s1=dip(2,jj,j)*dipderg(4,kk,l)
7392       endif
7393 #endif
7394       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7395       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7396       if (j.eq.l+1) then
7397         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7398         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7399       else
7400         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7401         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7402       endif
7403       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7404       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7405       vv(1)=pizda(1,1)-pizda(2,2)
7406       vv(2)=pizda(2,1)+pizda(1,2)
7407       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7408       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7409 #ifdef MOMENT
7410         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7411 #else
7412         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7413 #endif
7414       else
7415 #ifdef MOMENT
7416         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7417 #else
7418         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7419 #endif
7420       endif
7421 C Derivatives in gamma(j-1) or gamma(l-1)
7422       if (l.eq.j+1 .and. l.gt.1) then
7423         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7424         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7425         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7426         vv(1)=pizda(1,1)-pizda(2,2)
7427         vv(2)=pizda(2,1)+pizda(1,2)
7428         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7429         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7430       else if (j.gt.1) then
7431         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7432         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7433         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7434         vv(1)=pizda(1,1)-pizda(2,2)
7435         vv(2)=pizda(2,1)+pizda(1,2)
7436         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7437         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7438           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7439         else
7440           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7441         endif
7442       endif
7443 C Cartesian derivatives.
7444       do iii=1,2
7445         do kkk=1,5
7446           do lll=1,3
7447 #ifdef MOMENT
7448             if (iii.eq.1) then
7449               if (imat.eq.1) then
7450                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7451               else
7452                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7453               endif
7454             else
7455               if (imat.eq.1) then
7456                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7457               else
7458                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7459               endif
7460             endif
7461 #endif
7462             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7463      &        auxvec(1))
7464             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7465             if (j.eq.l+1) then
7466               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7467      &          b1(1,itj1),auxvec(1))
7468               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7469             else
7470               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7471      &          b1(1,itl1),auxvec(1))
7472               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7473             endif
7474             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7475      &        pizda(1,1))
7476             vv(1)=pizda(1,1)-pizda(2,2)
7477             vv(2)=pizda(2,1)+pizda(1,2)
7478             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7479             if (swap) then
7480               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7481 #ifdef MOMENT
7482                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7483      &             -(s1+s2+s4)
7484 #else
7485                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7486      &             -(s2+s4)
7487 #endif
7488                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7489               else
7490 #ifdef MOMENT
7491                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7492 #else
7493                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7494 #endif
7495                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7496               endif
7497             else
7498 #ifdef MOMENT
7499               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7500 #else
7501               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7502 #endif
7503               if (l.eq.j+1) then
7504                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7505               else
7506                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7507               endif
7508             endif
7509           enddo
7510         enddo
7511       enddo
7512       return
7513       end
7514 c----------------------------------------------------------------------------
7515       double precision function eello_turn6(i,jj,kk)
7516       implicit real*8 (a-h,o-z)
7517       include 'DIMENSIONS'
7518       include 'DIMENSIONS.ZSCOPT'
7519       include 'COMMON.IOUNITS'
7520       include 'COMMON.CHAIN'
7521       include 'COMMON.DERIV'
7522       include 'COMMON.INTERACT'
7523       include 'COMMON.CONTACTS'
7524       include 'COMMON.TORSION'
7525       include 'COMMON.VAR'
7526       include 'COMMON.GEO'
7527       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7528      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7529      &  ggg1(3),ggg2(3)
7530       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7531      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7532 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7533 C           the respective energy moment and not to the cluster cumulant.
7534       eello_turn6=0.0d0
7535       j=i+4
7536       k=i+1
7537       l=i+3
7538       iti=itortyp(itype(i))
7539       itk=itortyp(itype(k))
7540       itk1=itortyp(itype(k+1))
7541       itl=itortyp(itype(l))
7542       itj=itortyp(itype(j))
7543 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7544 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7545 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7546 cd        eello6=0.0d0
7547 cd        return
7548 cd      endif
7549 cd      write (iout,*)
7550 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7551 cd     &   ' and',k,l
7552 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7553       do iii=1,2
7554         do kkk=1,5
7555           do lll=1,3
7556             derx_turn(lll,kkk,iii)=0.0d0
7557           enddo
7558         enddo
7559       enddo
7560 cd      eij=1.0d0
7561 cd      ekl=1.0d0
7562 cd      ekont=1.0d0
7563       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7564 cd      eello6_5=0.0d0
7565 cd      write (2,*) 'eello6_5',eello6_5
7566 #ifdef MOMENT
7567       call transpose2(AEA(1,1,1),auxmat(1,1))
7568       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7569       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7570       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7571 #else
7572       s1 = 0.0d0
7573 #endif
7574       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7575       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7576       s2 = scalar2(b1(1,itk),vtemp1(1))
7577 #ifdef MOMENT
7578       call transpose2(AEA(1,1,2),atemp(1,1))
7579       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7580       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7581       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7582 #else
7583       s8=0.0d0
7584 #endif
7585       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7586       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7587       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7588 #ifdef MOMENT
7589       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7590       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7591       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7592       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7593       ss13 = scalar2(b1(1,itk),vtemp4(1))
7594       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7595 #else
7596       s13=0.0d0
7597 #endif
7598 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7599 c      s1=0.0d0
7600 c      s2=0.0d0
7601 c      s8=0.0d0
7602 c      s12=0.0d0
7603 c      s13=0.0d0
7604       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7605       if (calc_grad) then
7606 C Derivatives in gamma(i+2)
7607 #ifdef MOMENT
7608       call transpose2(AEA(1,1,1),auxmatd(1,1))
7609       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7610       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7611       call transpose2(AEAderg(1,1,2),atempd(1,1))
7612       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7613       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7614 #else
7615       s8d=0.0d0
7616 #endif
7617       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7618       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7619       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7620 c      s1d=0.0d0
7621 c      s2d=0.0d0
7622 c      s8d=0.0d0
7623 c      s12d=0.0d0
7624 c      s13d=0.0d0
7625       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7626 C Derivatives in gamma(i+3)
7627 #ifdef MOMENT
7628       call transpose2(AEA(1,1,1),auxmatd(1,1))
7629       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7630       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7631       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7632 #else
7633       s1d=0.0d0
7634 #endif
7635       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7636       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7637       s2d = scalar2(b1(1,itk),vtemp1d(1))
7638 #ifdef MOMENT
7639       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7640       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7641 #endif
7642       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7643 #ifdef MOMENT
7644       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7645       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7646       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7647 #else
7648       s13d=0.0d0
7649 #endif
7650 c      s1d=0.0d0
7651 c      s2d=0.0d0
7652 c      s8d=0.0d0
7653 c      s12d=0.0d0
7654 c      s13d=0.0d0
7655 #ifdef MOMENT
7656       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7657      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7658 #else
7659       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7660      &               -0.5d0*ekont*(s2d+s12d)
7661 #endif
7662 C Derivatives in gamma(i+4)
7663       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7664       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7665       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7666 #ifdef MOMENT
7667       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7668       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7669       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7670 #else
7671       s13d = 0.0d0
7672 #endif
7673 c      s1d=0.0d0
7674 c      s2d=0.0d0
7675 c      s8d=0.0d0
7676 C      s12d=0.0d0
7677 c      s13d=0.0d0
7678 #ifdef MOMENT
7679       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7680 #else
7681       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7682 #endif
7683 C Derivatives in gamma(i+5)
7684 #ifdef MOMENT
7685       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7686       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7687       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7688 #else
7689       s1d = 0.0d0
7690 #endif
7691       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7692       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7693       s2d = scalar2(b1(1,itk),vtemp1d(1))
7694 #ifdef MOMENT
7695       call transpose2(AEA(1,1,2),atempd(1,1))
7696       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7697       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7698 #else
7699       s8d = 0.0d0
7700 #endif
7701       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7702       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7703 #ifdef MOMENT
7704       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7705       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7706       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7707 #else
7708       s13d = 0.0d0
7709 #endif
7710 c      s1d=0.0d0
7711 c      s2d=0.0d0
7712 c      s8d=0.0d0
7713 c      s12d=0.0d0
7714 c      s13d=0.0d0
7715 #ifdef MOMENT
7716       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7717      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7718 #else
7719       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7720      &               -0.5d0*ekont*(s2d+s12d)
7721 #endif
7722 C Cartesian derivatives
7723       do iii=1,2
7724         do kkk=1,5
7725           do lll=1,3
7726 #ifdef MOMENT
7727             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7728             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7729             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7730 #else
7731             s1d = 0.0d0
7732 #endif
7733             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7734             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7735      &          vtemp1d(1))
7736             s2d = scalar2(b1(1,itk),vtemp1d(1))
7737 #ifdef MOMENT
7738             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7739             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7740             s8d = -(atempd(1,1)+atempd(2,2))*
7741      &           scalar2(cc(1,1,itl),vtemp2(1))
7742 #else
7743             s8d = 0.0d0
7744 #endif
7745             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7746      &           auxmatd(1,1))
7747             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7748             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7749 c      s1d=0.0d0
7750 c      s2d=0.0d0
7751 c      s8d=0.0d0
7752 c      s12d=0.0d0
7753 c      s13d=0.0d0
7754 #ifdef MOMENT
7755             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7756      &        - 0.5d0*(s1d+s2d)
7757 #else
7758             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7759      &        - 0.5d0*s2d
7760 #endif
7761 #ifdef MOMENT
7762             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7763      &        - 0.5d0*(s8d+s12d)
7764 #else
7765             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7766      &        - 0.5d0*s12d
7767 #endif
7768           enddo
7769         enddo
7770       enddo
7771 #ifdef MOMENT
7772       do kkk=1,5
7773         do lll=1,3
7774           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7775      &      achuj_tempd(1,1))
7776           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7777           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7778           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7779           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7780           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7781      &      vtemp4d(1))
7782           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7783           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7784           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7785         enddo
7786       enddo
7787 #endif
7788 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7789 cd     &  16*eel_turn6_num
7790 cd      goto 1112
7791       if (j.lt.nres-1) then
7792         j1=j+1
7793         j2=j-1
7794       else
7795         j1=j-1
7796         j2=j-2
7797       endif
7798       if (l.lt.nres-1) then
7799         l1=l+1
7800         l2=l-1
7801       else
7802         l1=l-1
7803         l2=l-2
7804       endif
7805       do ll=1,3
7806         ggg1(ll)=eel_turn6*g_contij(ll,1)
7807         ggg2(ll)=eel_turn6*g_contij(ll,2)
7808         ghalf=0.5d0*ggg1(ll)
7809 cd        ghalf=0.0d0
7810         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7811      &    +ekont*derx_turn(ll,2,1)
7812         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7813         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7814      &    +ekont*derx_turn(ll,4,1)
7815         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7816         ghalf=0.5d0*ggg2(ll)
7817 cd        ghalf=0.0d0
7818         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7819      &    +ekont*derx_turn(ll,2,2)
7820         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7821         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7822      &    +ekont*derx_turn(ll,4,2)
7823         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7824       enddo
7825 cd      goto 1112
7826       do m=i+1,j-1
7827         do ll=1,3
7828           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7829         enddo
7830       enddo
7831       do m=k+1,l-1
7832         do ll=1,3
7833           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7834         enddo
7835       enddo
7836 1112  continue
7837       do m=i+2,j2
7838         do ll=1,3
7839           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7840         enddo
7841       enddo
7842       do m=k+2,l2
7843         do ll=1,3
7844           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7845         enddo
7846       enddo
7847 cd      do iii=1,nres-3
7848 cd        write (2,*) iii,g_corr6_loc(iii)
7849 cd      enddo
7850       endif
7851       eello_turn6=ekont*eel_turn6
7852 cd      write (2,*) 'ekont',ekont
7853 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7854       return
7855       end
7856 crc-------------------------------------------------
7857 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7858       subroutine Eliptransfer(eliptran)
7859       implicit real*8 (a-h,o-z)
7860       include 'DIMENSIONS'
7861       include 'COMMON.GEO'
7862       include 'COMMON.VAR'
7863       include 'COMMON.LOCAL'
7864       include 'COMMON.CHAIN'
7865       include 'COMMON.DERIV'
7866       include 'COMMON.INTERACT'
7867       include 'COMMON.IOUNITS'
7868       include 'COMMON.CALC'
7869       include 'COMMON.CONTROL'
7870       include 'COMMON.SPLITELE'
7871       include 'COMMON.SBRIDGE'
7872 C this is done by Adasko
7873 C      print *,"wchodze"
7874 C structure of box:
7875 C      water
7876 C--bordliptop-- buffore starts
7877 C--bufliptop--- here true lipid starts
7878 C      lipid
7879 C--buflipbot--- lipid ends buffore starts
7880 C--bordlipbot--buffore ends
7881       eliptran=0.0
7882       do i=1,nres
7883 C       do i=1,1
7884         if (itype(i).eq.ntyp1) cycle
7885
7886         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
7887         if (positi.le.0) positi=positi+boxzsize
7888 C        print *,i
7889 C first for peptide groups
7890 c for each residue check if it is in lipid or lipid water border area
7891        if ((positi.gt.bordlipbot)
7892      &.and.(positi.lt.bordliptop)) then
7893 C the energy transfer exist
7894         if (positi.lt.buflipbot) then
7895 C what fraction I am in
7896          fracinbuf=1.0d0-
7897      &        ((positi-bordlipbot)/lipbufthick)
7898 C lipbufthick is thickenes of lipid buffore
7899          sslip=sscalelip(fracinbuf)
7900          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
7901          eliptran=eliptran+sslip*pepliptran
7902          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
7903          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
7904 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
7905         elseif (positi.gt.bufliptop) then
7906          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
7907          sslip=sscalelip(fracinbuf)
7908          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
7909          eliptran=eliptran+sslip*pepliptran
7910          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
7911          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
7912 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
7913 C          print *, "doing sscalefor top part"
7914 C         print *,i,sslip,fracinbuf,ssgradlip
7915         else
7916          eliptran=eliptran+pepliptran
7917 C         print *,"I am in true lipid"
7918         endif
7919 C       else
7920 C       eliptran=elpitran+0.0 ! I am in water
7921        endif
7922        enddo
7923 C       print *, "nic nie bylo w lipidzie?"
7924 C now multiply all by the peptide group transfer factor
7925 C       eliptran=eliptran*pepliptran
7926 C now the same for side chains
7927 CV       do i=1,1
7928        do i=1,nres
7929         if (itype(i).eq.ntyp1) cycle
7930         positi=(mod(c(3,i+nres),boxzsize))
7931         if (positi.le.0) positi=positi+boxzsize
7932 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
7933 c for each residue check if it is in lipid or lipid water border area
7934 C       respos=mod(c(3,i+nres),boxzsize)
7935 C       print *,positi,bordlipbot,buflipbot
7936        if ((positi.gt.bordlipbot)
7937      & .and.(positi.lt.bordliptop)) then
7938 C the energy transfer exist
7939         if (positi.lt.buflipbot) then
7940          fracinbuf=1.0d0-
7941      &     ((positi-bordlipbot)/lipbufthick)
7942 C lipbufthick is thickenes of lipid buffore
7943          sslip=sscalelip(fracinbuf)
7944          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
7945          eliptran=eliptran+sslip*liptranene(itype(i))
7946          gliptranx(3,i)=gliptranx(3,i)
7947      &+ssgradlip*liptranene(itype(i))
7948          gliptranc(3,i-1)= gliptranc(3,i-1)
7949      &+ssgradlip*liptranene(itype(i))
7950 C         print *,"doing sccale for lower part"
7951         elseif (positi.gt.bufliptop) then
7952          fracinbuf=1.0d0-
7953      &((bordliptop-positi)/lipbufthick)
7954          sslip=sscalelip(fracinbuf)
7955          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
7956          eliptran=eliptran+sslip*liptranene(itype(i))
7957          gliptranx(3,i)=gliptranx(3,i)
7958      &+ssgradlip*liptranene(itype(i))
7959          gliptranc(3,i-1)= gliptranc(3,i-1)
7960      &+ssgradlip*liptranene(itype(i))
7961 C          print *, "doing sscalefor top part",sslip,fracinbuf
7962         else
7963          eliptran=eliptran+liptranene(itype(i))
7964 C         print *,"I am in true lipid"
7965         endif
7966         endif ! if in lipid or buffor
7967 C       else
7968 C       eliptran=elpitran+0.0 ! I am in water
7969        enddo
7970        return
7971        end
7972
7973
7974 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7975
7976       SUBROUTINE MATVEC2(A1,V1,V2)
7977       implicit real*8 (a-h,o-z)
7978       include 'DIMENSIONS'
7979       DIMENSION A1(2,2),V1(2),V2(2)
7980 c      DO 1 I=1,2
7981 c        VI=0.0
7982 c        DO 3 K=1,2
7983 c    3     VI=VI+A1(I,K)*V1(K)
7984 c        Vaux(I)=VI
7985 c    1 CONTINUE
7986
7987       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7988       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7989
7990       v2(1)=vaux1
7991       v2(2)=vaux2
7992       END
7993 C---------------------------------------
7994       SUBROUTINE MATMAT2(A1,A2,A3)
7995       implicit real*8 (a-h,o-z)
7996       include 'DIMENSIONS'
7997       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7998 c      DIMENSION AI3(2,2)
7999 c        DO  J=1,2
8000 c          A3IJ=0.0
8001 c          DO K=1,2
8002 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8003 c          enddo
8004 c          A3(I,J)=A3IJ
8005 c       enddo
8006 c      enddo
8007
8008       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8009       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8010       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8011       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8012
8013       A3(1,1)=AI3_11
8014       A3(2,1)=AI3_21
8015       A3(1,2)=AI3_12
8016       A3(2,2)=AI3_22
8017       END
8018
8019 c-------------------------------------------------------------------------
8020       double precision function scalar2(u,v)
8021       implicit none
8022       double precision u(2),v(2)
8023       double precision sc
8024       integer i
8025       scalar2=u(1)*v(1)+u(2)*v(2)
8026       return
8027       end
8028
8029 C-----------------------------------------------------------------------------
8030
8031       subroutine transpose2(a,at)
8032       implicit none
8033       double precision a(2,2),at(2,2)
8034       at(1,1)=a(1,1)
8035       at(1,2)=a(2,1)
8036       at(2,1)=a(1,2)
8037       at(2,2)=a(2,2)
8038       return
8039       end
8040 c--------------------------------------------------------------------------
8041       subroutine transpose(n,a,at)
8042       implicit none
8043       integer n,i,j
8044       double precision a(n,n),at(n,n)
8045       do i=1,n
8046         do j=1,n
8047           at(j,i)=a(i,j)
8048         enddo
8049       enddo
8050       return
8051       end
8052 C---------------------------------------------------------------------------
8053       subroutine prodmat3(a1,a2,kk,transp,prod)
8054       implicit none
8055       integer i,j
8056       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8057       logical transp
8058 crc      double precision auxmat(2,2),prod_(2,2)
8059
8060       if (transp) then
8061 crc        call transpose2(kk(1,1),auxmat(1,1))
8062 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8063 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8064
8065            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8066      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8067            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8068      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8069            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8070      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8071            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8072      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8073
8074       else
8075 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8076 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8077
8078            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8079      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8080            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8081      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8082            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8083      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8084            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8085      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8086
8087       endif
8088 c      call transpose2(a2(1,1),a2t(1,1))
8089
8090 crc      print *,transp
8091 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8092 crc      print *,((prod(i,j),i=1,2),j=1,2)
8093
8094       return
8095       end
8096 C-----------------------------------------------------------------------------
8097       double precision function scalar(u,v)
8098       implicit none
8099       double precision u(3),v(3)
8100       double precision sc
8101       integer i
8102       sc=0.0d0
8103       do i=1,3
8104         sc=sc+u(i)*v(i)
8105       enddo
8106       scalar=sc
8107       return
8108       end
8109 C-----------------------------------------------------------------------
8110       double precision function sscale(r)
8111       double precision r,gamm
8112       include "COMMON.SPLITELE"
8113       if(r.lt.r_cut-rlamb) then
8114         sscale=1.0d0
8115       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8116         gamm=(r-(r_cut-rlamb))/rlamb
8117         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8118       else
8119         sscale=0d0
8120       endif
8121       return
8122       end
8123 C-----------------------------------------------------------------------
8124 C-----------------------------------------------------------------------
8125       double precision function sscagrad(r)
8126       double precision r,gamm
8127       include "COMMON.SPLITELE"
8128       if(r.lt.r_cut-rlamb) then
8129         sscagrad=0.0d0
8130       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8131         gamm=(r-(r_cut-rlamb))/rlamb
8132         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8133       else
8134         sscagrad=0.0d0
8135       endif
8136       return
8137       end
8138 C-----------------------------------------------------------------------
8139 C-----------------------------------------------------------------------
8140       double precision function sscalelip(r)
8141       double precision r,gamm
8142       include "COMMON.SPLITELE"
8143 C      if(r.lt.r_cut-rlamb) then
8144 C        sscale=1.0d0
8145 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8146 C        gamm=(r-(r_cut-rlamb))/rlamb
8147         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8148 C      else
8149 C        sscale=0d0
8150 C      endif
8151       return
8152       end
8153 C-----------------------------------------------------------------------
8154       double precision function sscagradlip(r)
8155       double precision r,gamm
8156       include "COMMON.SPLITELE"
8157 C     if(r.lt.r_cut-rlamb) then
8158 C        sscagrad=0.0d0
8159 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8160 C        gamm=(r-(r_cut-rlamb))/rlamb
8161         sscagradlip=r*(6*r-6.0d0)
8162 C      else
8163 C        sscagrad=0.0d0
8164 C      endif
8165       return
8166       end
8167
8168 C-----------------------------------------------------------------------
8169