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