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